xhtml.l

A very small LISP implementation with several packages and demo programs.

                  ((=T (car L))
                     (if (setq U (eval (cadr L) E))
                        (<li> (pack (if (or (<> U *Url) (caddr L)) 'cmd 'act) N)
                           (<href> (eval (car L) E) (urlMT U *Menu 1 (caddr L))) )
                        (<li> (pack 'cmd N)
                           (ht:Prin (eval (car L) E)) ) ) )
                  ((bit? M *Menu)
                     (<li> (pack 'sub N)
                        (<href>
                           (eval (cadr L) E)
                           (urlMT *Url (| M *Menu) *Tab *ID) ) )
                     (setq M (>> -1 M))
                     (recur (L)
                        (for X (cddr L)
                           (when (=T (car X))
                              (recurse X)
                              (setq M (>> -1 M)) ) ) ) )
                  (NIL
                     (<li> (pack 'top N)
                        (<href>
                           (eval (cadr L) E)
                           (urlMT *Url (x| M *Menu) *Tab *ID) )
                        (setq M (>> -1 M))
                        (recurse (cddr L) (inc N) (inc E)) ) ) ) ) ) ) ) )


# Tabs
(de <tab> Lst
   (<table> 'tab NIL NIL
      (for (N . L) Lst
         (if (= N *Tab)
            (<td> 'top (ht:Prin (eval (car L) 1)))
            (<td> 'sub
               (<href> (eval (car L) 1) (urlMT *Url *Menu N *ID)) ) ) ) )
   (htPrin (get Lst *Tab -1) 2) )


### DB Linkage ###
(de mkUrl (Lst)
   (pack (pop 'Lst) '?
      (make
         (while Lst
            (and
               (sym? (car Lst))
               (= `(char '*) (char (car Lst)))
               (link (pop 'Lst) '=) )
            (link (ht:Fmt (pop 'Lst)))
            (and Lst (link '&)) ) ) ) )

(de <$> (Str Obj Msg)
   (cond
      ((not Obj) (ht:Prin Str))
      ((=T Obj) (<href> Str (pack Msg Str)))
      ((send (or Msg 'url>) Obj)
         (<href> Str (mkUrl @)) )
      (T (ht:Prin Str)) ) )

# Links to previous and next object
(de stepBtn (Var Cls Hook Msg)
   (default Msg 'url>)
   (<span> 'step
      (let
         (K
            (cond
               ((isa '+Key (meta *ID Var))
                  (get *ID Var) )
               ((isa '+Fold (meta *ID Var))
                  (cons (fold (get *ID Var)) *ID) )
               (T (cons (get *ID Var) *ID)) )
            Q1 (init (tree Var Cls Hook) K NIL)
            Q2 (init (tree Var Cls Hook) K T) )
         (or (get *ID T) (step Q1 T))
         (if (and (step Q1 T) (send Msg @))
            (<href> "<<<" (mkUrl @))
            (prin "&lt;&lt;&lt;") )
         (prin "&nbsp;--&nbsp;")
         (or (get *ID T) (step Q2 T))
         (if (and (step Q2 T) (send Msg @))
            (<href> ">>>" (mkUrl @))
            (prin "&gt;&gt;&gt;") ) ) ) )

# Character Separated Values
(off "*CSV")

(de csv ("Nm" . "Prg")
   (let "*CSV" (pack "+" (tmp "Nm" ".txt"))
      (run "Prg")
      (<href> "CSV" (tmp "Nm" ".txt")) ) )

(de <+> (Str Obj Msg)
   (<$> Str Obj Msg)
   (and "*CSV" (out @ (prin Str "^I"))) )

(de <-> (Str Obj Msg)
   (<$> Str Obj Msg)
   (and "*CSV" (out @ (prinl Str))) )


# Interactive tree
(de <tree> ("Url" "Path" "Tree" "Able?" "Excl?" "Expand" "Print")
   (default "Print" 'ht:Prin)
   (let ("Pos" "Tree"  "F" (pop '"Path")  "A" 0)
      (when "Path"
         (loop
            (and "F"
               (not (cdr "Path"))
               (map
                  '((L)
                     (when (pair (car L)) (set L (caar L))) )
                  "Pos" ) )
            (T (atom (car (setq "Pos" (nth "Pos" (abs (pop '"Path")))))))
            (NIL "Path")
            (setq "Pos" (cdar "Pos")) )
         (set "Pos"
            (if (atom (car "Pos"))
               (cons (car "Pos") ("Expand" (car "Pos")))
               (caar "Pos") ) ) )
      (setq "Pos" (car "Pos"))
      ("tree" "Tree")
      "Tree" ) )

(de "tree" ("Tree" "Lst")
   (prinl "<ul>")
   (for ("N" . "X") "Tree"
      (prin "<li><a id=\"T" (inc '"A") "\"></a>")
      (cond
         ((pair "X")
            (let "L" (append "Lst" (cons "N"))
               (<href> (if (== "X" "Pos") "<+>" "[+]")
                  (pack "Url"
                     '? (ht:Fmt (cons NIL "L"))
                     "#T" (max 1 (- "A" 12)) ) )
               (space)
               ("Print" (car "X"))
               (and (cdr "X") ("tree" @ "L")) ) )
         (("Able?" "X")
            (let "L" (append "Lst" (cons (- "N")))
               (<href> (if (== "X" "Pos") "< >" "[ ]")
                  (pack "Url"
                     "?" (ht:Fmt (cons ("Excl?" "X") "L"))
                     "#T" (max 1 (- "A" 12)) ) )
               (space)
               ("Print" "X") ) )
         (T ("Print" "X")) )
      (prin "</li>") )
   (prinl "</ul>") )


### HTML form ###
(de <post> (Attr Url . Prg)
   (prin
      "<form enctype=\"multipart/form-data\" action=\""
      (sesId Url)
      (and *JS "\" onsubmit=\"return doPost(this);")
      "\" method=\"post\">" )
   (tag 'fieldset Attr 2 Prg)
   (prinl "</form>") )

(de htmlVar ("Var")
   (prin "name=\"")
   (if (pair "Var")
      (prin (car "Var") "(" (ht:Fmt (cdr "Var")) ")")
      (prin "Var") )
   (prin "\"") )

(de htmlVal ("Var")
   (if (pair "Var")
      (cdr (assoc (cdr "Var") (val (car "Var"))))
      (val "Var") ) )

(de <label> (Attr . Prg)
   (tag 'label Attr 2 Prg) )

(de <field> (N "Var" Max Flg)
   (prin "<input type=\"text\" ")
   (htmlVar "Var")
   (prin " value=\"")
   (ht:Prin (htmlVal "Var"))
   (prin "\" size=\"")
   (if (lt0 N)
      (prin (- N) "\" style=\"text-align: right;\"")
      (prin N "\"") )
   (and Max (prin " maxlength=\"" Max "\""))
   (dfltCss "field")
   (and Flg (prin " readonly=\"readonly\""))
   (prinl "/>") )

(de <hidden> ("Var" Val)
   (prin "<input type=\"hidden\" ")
   (htmlVar "Var")
   (prin " value=\"")
   (ht:Prin Val)
   (prinl "\"/>") )

(de <passwd> (N "Var" Max Flg)
   (prin "<input type=\"password\" ")
   (htmlVar "Var")
   (prin " value=\"")
   (ht:Prin (htmlVal "Var"))
   (prin "\" size=\"" N "\"")
   (and Max (prin " maxlength=\"" Max "\""))
   (dfltCss "passwd")
   (and Flg (prin " disabled=\"disabled\""))
   (prinl "/>") )

(de <upload> (N "Var" Flg)
   (prin "<input type=\"file\" ")
   (htmlVar "Var")
   (prin " value=\"")
   (ht:Prin (htmlVal "Var"))
   (prin "\" size=\"" N "\"")
   (dfltCss "upload")
   (and Flg (prin " disabled=\"disabled\""))
   (prinl "/>") )

(de <area> (Cols Rows "Var" Flg)
   (prin "<textarea ")
   (htmlVar "Var")
   (prin " cols=\"" Cols "\" rows=\"" Rows "\" wrap=\"off\"")
   (dfltCss "area")
   (and Flg (prin " readonly=\"readonly\""))
   (prin '>)
   (ht:Prin (htmlVal "Var"))
   (prinl "</textarea>") )

(de <select> (Lst "Var" Flg)
   (prin "<select ")
   (htmlVar "Var")
   (dfltCss "select")
   (prin '>)
   (for "X" Lst
      (let "V" (if (atom "X") "X" (cdr "X"))
         (prin
            "<option"
            (and (pair "X") (pack " value=\"" "V" "\""))
            (cond
               ((= "V" (htmlVal "Var")) " selected=\"selected\"")
               (Flg " disabled=\"disabled\"") )
            '> ) )
      (ht:Prin (if (atom "X") "X" (car "X")))
      (prin "</option>") )
   (prinl "</select>") )

(de <check> ("Var" Flg)
   (prin "<input type=\"hidden\" ")
   (htmlVar "Var")
   (prin " value=\"" (and Flg (htmlVal "Var")) "\">")
   (prin "<input type=\"checkbox\" ")
   (htmlVar "Var")
   (prin " value=\"T\"" (and (htmlVal "Var") " checked=\"checked\""))
   (dfltCss "check")
   (and Flg (prin " disabled=\"disabled\""))
   (prinl "/>") )

(de <radio> ("Var" Val Flg)
   (prin "<input type=\"radio\" ")
   (htmlVar "Var")
   (prin
      " value=\"" Val "\""
      (and (= Val (htmlVal "Var")) " checked=\"checked\"") )
   (dfltCss "radio")
   (and Flg (prin " disabled=\"disabled\""))
   (prinl "/>") )

(de <submit> (S "Var" Flg JS)
   (prin "<input type=\"submit\"")
   (and "Var" (space) (htmlVar "Var"))
   (prin " value=\"")
   (ht:Prin S)
   (prin "\"")
   (and *JS JS (prin " onclick=\"return doBtn(this);\""))
   (dfltCss "submit")
   (and Flg (prin " disabled=\"disabled\""))
   (prinl "/>") )

(de <image> (Src "Var" Flg JS)
   (prin "<input type=\"image\"")
   (and "Var" (space) (htmlVar "Var"))
   (prin " src=\"" (sesId Src) "\"")
   (and *JS JS (prin " onclick=\"return doBtn(this);\""))
   (dfltCss "image")
   (and Flg (prin " disabled=\"disabled\""))
   (prinl "/>") )

(de <reset> (S Flg)
   (prin "<input type=\"reset\" value=\"")
   (ht:Prin S)
   (prin "\"")
   (dfltCss "reset")
   (and Flg (prin " disabled=\"disabled\""))
   (prinl "/>") )

# vi:et:ts=3:sw=3