(defstruct (folder-info (:print-object 

                         (lambda (obj str) (format str "[~S / ~S]" 

                                                   (length (folder-info-content obj))

                                                   (folder-info-proplist obj)))))
  
  content

  proplist)



(defstruct url-info

  proplist)


  
(defun build-reader (filename)

  (let ((inpstream (open filename :direction :input)))

    (if inpstream

        (values inpstream #'(lambda () (read-line inpstream nil nil))))))


(defun build-scanner (reader)

  #' (lambda ()

        (let ((line (funcall reader)))

          (loop

           while (not (null line)) do

          (cond

           ((start-with "#URL" line) (return (read-url reader)))

           ((start-with "#FOLDER" line) (return (read-folder reader)))

           ((start-with "-" line) (return "-"))

           (t (setf line (funcall reader))))))))


(defun read-url (reader)

  (let ((pl (read-proplist reader)))

    (make-url-info :proplist pl)))


(defun read-folder (reader)

  (let ((pl (read-proplist reader)))

    (make-folder-info :proplist pl :content nil)))


(defun read-proplist (reader)

  (loop

   with line = (funcall reader)

   with proplist-result = nil

   while (un-empty-line-p line) do

   (setf proplist-result (append proplist-result (analyze-line line)))
 
   (setf line (funcall reader))
   
   finally (return proplist-result)))


(defun analyze-line (line)

  (let ((pos (position #\= line)))

    (when pos

      (list (subseq line (position-if 
                          
                          #'(lambda (x) 

                              (and (graphic-char-p x) (not (char= x #\Space)))) line) pos)

            (subseq line (+ pos 1) (length line))))))


(defun un-empty-line-p (line)

  (and (stringp line)

       (find-if #'(lambda (x) (and (graphic-char-p x) (not (char= x #\Space)))) line)))



(defun start-with (str1 str2)
  (and
   (>= (length str2) (length str1))
   (string= str1 str2 :start2 0 :end2 (length str1))))
     
    


(defun parse-infoliste (scanner symb)

  (let ((retval nil)
        (aktsymb symb))

    (loop

     with retval1 = nil

     while (infoblock-start-p aktsymb) do
     
     (multiple-value-setq (retval1 aktsymb) (parse-infoblock scanner aktsymb))

     (setf retval (append retval retval1))

     finally (return (values retval aktsymb)))))



(defun infoblock-start-p (symb)

  (or (folder-info-p symb) (url-info-p symb)))


(defun parse-infoblock (scanner symb)

  (cond

   ((url-info-p symb)
    
    (values (list symb) (funcall scanner)))

   ((folder-info-p symb)

    (let ((retval symb)
          (retval1 nil)
          (aktsymb (funcall scanner)))

      (multiple-value-setq (retval1 aktsymb) (parse-infoliste scanner aktsymb))

      (setf (folder-info-content retval) retval1)

      (when (not (and (stringp aktsymb) (start-with "-" aktsymb)))

        (error "parse-infoblock: missing '-'"))

      (values (list retval) (funcall scanner))))))


;;
;; parse-file is the first main function of this package
;;
;; filename is a file in the opera bookmark format, e.g. opera6.adr
;;
;; the return value is a hierarchical data structure representing the
;;
;; bookmark hierarchy in the file filename
;;


(defun parse-file (filename)

  (let ((scanner)

         (istr)

         (reader)

         (symb)

         (retval))

    (multiple-value-setq (istr reader) (build-reader filename))

    (setf scanner (build-scanner reader))

    (setf symb (funcall scanner))

    (multiple-value-setq (retval symb) (parse-infoliste scanner symb))

    (close istr)

    retval))

;;
;; tree-select operates on the data structure (parsetree) representing a bookmark hierarchy
;;
;; and returns the same data structure
;;
;; indlist is a list of indices into parsetree consisting of numbers and the symbol 'c
;;
;; the leading index i of indlist selects a part of parsetree which is:
;;
;; the i-th element of a list if parsetree is on the outer level a list (zero-indexed)
;;
;; the content of a folder if parsetree is on the outer level a folder (i must be 'c)
;;
;; on the result of this choice tree-select is applied recursively with (cdr indlist) as new indlist
;;


(defun tree-select (parsetree &rest indlist)

  (let ()

    (cond

     ((null indlist) parsetree)

     ((folder-info-p parsetree)

      (let ()

        (if (eql (car indlist) 'c)

            (apply #'tree-select (folder-info-content parsetree) (cdr indlist))

          (apply #'tree-select (nth (car indlist) (folder-info-content parsetree)) (cdr indlist)))))

     ((listp parsetree)

      (apply #'tree-select (nth (car indlist) parsetree) (cdr indlist)))

     (t (error "tree select: illegal index")))))


;;
;; tree-export exports a hierarchical bookmark datastructure parsetree as filename
;;



(defun tree-export (parsetree filename)

  (with-open-file (ostr filename :direction :output :if-exists :overwrite :if-does-not-exist :create)

    (write-preamble ostr)

    (tree-export-1 0 ostr parsetree)))



(defparameter *indentincr* 4)



(defun tree-export-1 (indentlevel ostr parsetree)

  (cond

   ((url-info-p parsetree) (print-url-info indentlevel ostr parsetree))

   ((listp parsetree)

    (let ()

      (print-list-start indentlevel ostr)

      (loop

       for el in parsetree do

       (tree-export-1 (+ indentlevel *indentincr*) ostr el))

      (print-list-end indentlevel ostr)))

   ((folder-info-p parsetree) 

    (let ()

      (print-folder-info indentlevel ostr parsetree)

      (tree-export-1 (+ indentlevel *indentincr*) ostr (folder-info-content parsetree))))))


(defun nblanks (n)

  (make-string n :initial-element #\Space))


(defun print-url-info (ilevel ostr ptree)

  (format ostr "~A<DT><A HREF=\"~A\" ADD_DATE=\"~A\" LAST_VISIT=\"~A\">~A</A>~%"

          (nblanks ilevel) (get-prop "URL" ptree) (get-prop "CREATED" ptree) (get-prop "VISITED" ptree)

          (get-prop "NAME" ptree)))


(defun print-folder-info (ilevel ostr ptree)

  (format ostr "~A<DT><H3 FOLDED ADD_DATE=\"~A\">~A</H3>~%"

          (nblanks ilevel) (get-prop "CREATED" ptree) (get-prop "NAME" ptree)))



(defun get-prop (str parseelem)

  (let* ((proplist
         
          (cond ((url-info-p parseelem) (url-info-proplist parseelem))

               ((folder-info-p parseelem) (folder-info-proplist parseelem))))
         
         (pos (position str proplist :test #'string=)))

    (if pos

        (nth (1+ pos) proplist)

      "")))






(defun print-list-start (ilevel ostr)

  (format ostr "~A<DL><p>~%" (nblanks ilevel)))


(defun print-list-end (ilevel ostr)

  (format ostr "~A</DL><p>~%" (nblanks ilevel)))


 

      

(defun write-preamble (ostr)

  (let ()

    (format ostr "<!DOCTYPE NETSCAPE-Bookmark-file-1>~%")
      
    (format ostr "<!-- This is an automatically generated file.~%")

    (format ostr "It will be read and overwritten.~%")

    (format ostr "Do Not Edit! -->~%")
    
    (format ostr "<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=UTF-8\">~%")
   
    (format ostr "<TITLE>Bookmarks</TITLE>~%")
 
    (format ostr "<H1>Bookmarks</H1>~%~%")))


(defun do-it (filename)

  (let ((ptree (parse-file filename)))

    (setf ptree (tree-select ptree 1))

    (setf ptree (folder-info-content ptree))

    (tree-export ptree "bm.html")))


;;
;; subs-in-string substitutes newstr for oldstr in str
;; 
;; it is currently not used in this collection of functions
;;


(defun subs-in-string (oldstr newstr str)

  (let ((out "")
        (buffer "")
        (oldstridx 0))

    (loop

     with i = 0

     while (< i (length str)) do

     (cond

      ((string= (subseq str i (1+ i)) 
                (subseq oldstr oldstridx (1+ oldstridx)))

       (let ()

         (setf buffer (concatenate 'string buffer (subseq str i (1+ i))))
         (setf oldstridx (1+ oldstridx))
         (setf i (1+ i))
         (when (>= oldstridx (length oldstr))
           (setf out (concatenate 'string out newstr))
           (setf buffer "")
           (setf oldstridx 0))))

      ((> oldstridx 0)

       (let ()
         
         (setf i (1+ (- i oldstridx)))
         (setf out (concatenate 'string out (subseq buffer 0 1)))
         (setf oldstridx 0)
         (setf buffer "")))

      (t

       (let ()

         (setf out (concatenate 'string out (subseq str i (1+ i))))

         (setf i (1+ i)))))

     finally (return (concatenate 'string out buffer)))))