#!/usr/local/bin/klone
(setq max-level *maxint*)
(setq *package* 'R)

;; some preloads for efficiency
(dolist (filename '("setqn.kl" "require.kl" "defstruct.kl" "numeric.kl" 
      "basename.kl" "cgi.kl" "filedatabase.kl" "++.kl" "+=.kl" "stack-dump.kl"
      "sh.kl" "statparams.kl" "octal.kl" "date.kl" "cur-date.kl" 
      "file-type.kl" "trap-error.kl" "replace-string.kl" "file-lock.kl" 
      "print-stack.kl"
  ))
  (load filename)
)

;; This script manages a collection of databases for registering users to
;; oenologie meetings.
;; It automatically handles one base per subdir in the dir %dir, with 
;; inclusion of the "index.html" files it founds there
;; Author: Colas Nahaboo http://www.inria.fr/koala/colas

;;=============================================================================
;;                    Global vars
;;=============================================================================

;; %url and %dir are the base of sub-bases named by the sub-dirs present there
(setqn
  ;; things you must change---------------------------------------------------
  %url "http://www.inria.fr/cgi-bin/nph-colas-oenologie"
  %dir "/htdocs/files/koala/oenologie/reunions"
;;  %url "http://localhost/cgi-bin/nph-colas-oenologie-reservation"
;;  %dir "/var/www/webspace/pages/reservation/"
  %maintainer "Colas.Nahaboo@sophia.inria.fr"
  %links (vector 
    :oenologie ["page d'oenologie de l'INRIA Sophia" 
    "http://www.inria.fr/koala/oenologie" 
    "http://www.inria.fr/koala/oenologie/images/icon1s.jpg"]
    :reunion [(+ "réunion du " %name) %url]
    :back ["page précédente" (getenv "REFERER_URL")]
    :reunions (vector "liste des réunions" (copy %url) 
    "http://www.inria.fr/koala/oenologie/images/icon2s.jpg")
  )
  
  %body-file "index.html"
  
  %page-title "Oenologie Sophia"
  %page-color "#FFCCCC"
  %page-background ()
  %page-links [:oenologie]
  %page-header ()
  %page-footer ()
  
  %page-error-title "Oenologie Sophia: error"
  %page-error-color "#FFAAAA"
  %page-error-background %page-background
  %page-error-links %page-links
  %page-error-header %page-header
  %page-error-footer %page-footer
)

;; To administrate the base, use %url/name/admin

;;; things you dont need to change--------------------------------------------
(fdb:defstruct User
  :name
  :email
  :notes
  :number
)

;; add here the path of the klone library accesible for cgi scripts:
;;(insert *load-pathname* 0 "/users/colas/Klone/src/kl")

;; misc defs, internal use
(setq %nil :reservation-nil)
(setq Q html:quote-pre)
(setq %name ())
(if (/= #\/ (get %dir -1)) (nconc %dir "/")) ;dir must be /-terminated
(setq PF print-format)

;;=============================================================================
;;                    main dispatch
;;=============================================================================

(defun main (&aux
    (re (regcomp "^[/]([^/]+)([/].*)?$"))
  )
  (stack-dump-on-error t *maxint* () print-stack-dump:pre-handler
    print-stack-dump:post-handler)

  (cgi:init :error (+ %dir "ERRORS"))
  (if (and (regexec re cgi:path-info)
      (= 'directory (file-type (+ %dir (regsub re 1))))
    ) (progn
      (setq %name (regsub re 1))
      (nconc %dir %name "/")
      (setq *current-directory* %dir)
      (nconc %url "/" %name)
      (setq cgi:path-info (regsub re 2))
  ))
  (setq %basefile "database.fdb")
  (catch '%Error
  ;; first, decide what want the user?
    (if
      (not %name)			;list of reunions
      (show-all-reunions)

      (or (= cgi:path-info "/")		;no subpart? mainpage
	(= cgi:path-info "")) 
      (show-main-page)

      (= cgi:path-info "/users/add")	;form to add an user to the database
      (add-user)
      (= cgi:path-info "/users/edit")	;form to edit an existing user
      (edit-user cgi:query-string)
      
      (= cgi:path-info "/users/add/commit") ;perform add user
      (register-user cgi:arguments)
      (= cgi:path-info "/users/edit/commit") ;perform edit user
      (register-user-edit cgi:query-string cgi:arguments)
      (= cgi:path-info "/users/delete/commit") ;perform delete user
      (delete-user cgi:query-string)
      
      (= cgi:path-info "/maillist")
      (maillist)
      (= cgi:path-info "/htmllist")
      (htmllist)

      ;; Maintenance commands
      (= cgi:path-info "/admin")
      (admin-commands cgi:query-string)
      
      (PF "%0: Unknown command: %1!\n" %url cgi:path-info) ; problem!
  ))
  (cgi:end :validity 15)
)

;;=============================================================================
;;                    Directory of meetings
;;=============================================================================

(defun show-all-reunions (&aux 
    (fd (open (copy "") :type :string :direction :io))
    (info (+ %dir %body-file))
    (dirlist (list))
  )
  (if (file-stats info) 
    (PF fd "%0\n" (String (open info)))
  )
  (PF fd "<hr>\n<h2>Liste des inscriptions aux reunions</h2>\n<ul>\n")
  (with (*current-directory* %dir)
    (dolist (dir (directory))
      (if (= 'directory (file-type dir))
	(lappend dirlist dir)
  )))
  (sort dirlist dirsort)
  (dolist (dir dirlist)
    (PF fd "<li><a href=\"%0/%1\">%1</a>\n" %url dir)
  )
  (PF fd "</ul>\n")
  (%page (String fd) :title (+ "Oenologie: réunions"))
)

;; util to sort subdir names by dates , english and french
;; dirs MUST be in form either D_M_Y+rest or M_D_Y+rest
;; months must be the name, full french or english or 3-chars english
;; year can be 2 or 4 digit. Day can be a number or X or XX (X will be sorted
;; first in month, XX last)
(setq dirsort-ref1 (regcomp "^([0-9xX]+)_([a-zA-Z_-]+)_([0-9]+)"))
(setq dirsort-ref2 (regcomp dirsort-ref1))
(setq dirsort-ree1 (regcomp "^([a-zA-Z_-]+)_([0-9xX]+)_([0-9]+)"))
(setq dirsort-ree2 (regcomp dirsort-ree1))
(defun dirsort (d1 d2 &aux n1 n2)
  (if (and (regexec dirsort-ref1 d1) (regexec dirsort-ref2 d2))
    (compare (dirsort-numdate dirsort-ref1 1 2 3) ;french order DMY
      (dirsort-numdate dirsort-ref2 1 2 3))
    (and (regexec dirsort-ree1 d1) (regexec dirsort-ree2 d2))
    (compare (dirsort-numdate dirsort-ree1 2 1 3) ;english order MDY
      (dirsort-numdate dirsort-ree2 2 1 3))
    (compare d1 d2)			;otherwise, alphabetical
))

(defun dirsort-numdate (re n1 n2 n3 &aux n (year (Int (regsub re n3)))
    (day (tolower (regsub re n1)))
  )
  (setq n (if (= "x" day) 0 (seek day #\x) 9999 (Int day)))
  (incf n (* 40 (get '("janv"1 "janu"1 "jan "1 "fevr"2 "febr"2 "feb "2
	  "mars"3 "marc"3 "mar "3 "avri"4 "apri"4 "apr "4 "mai "5 "may "5
	  "juin"6 "june"6 "jun "6 "juil"7 "july"7 "jul"7
	  "aout"8 "augu"8 "aug "8 "sept"9 "sep "9 "octo"10 "oct "10
	  "nove"11 "nov"11 "dece"12 "dec "12
	) (tolower (subseq (regsub re n2) 0 4)) 0
  )))
  (incf n (* 500 (if (> year 1900) year
	(< year 70) (+ year 2000)
	(+ year 1900)
  )))
  n
)

;;=============================================================================
;;                    Main page of a meeting (listing)
;;=============================================================================

(defun show-main-page (&aux 
    (fd (open (copy "") :type :string :direction :io))
    (info (+ %dir %body-file))
    (valid-users 0)
  )
  (open-base)
  (if (file-stats info) 
    (PF fd "%0\n" (String (open info)))
  )
  (PF fd <hr>
    <h2>Liste des inscrits</h2>
    Cliquer sur un nom pour l'éditer ou l'enlever, ou 
    <a href="%0/users/add">clicker ici pour ajouter</a> 
    un nouveau participant (vous ou quelqu'un d'autre). Pour mailer à tous 
    les inscrits, il y a la <a href="%0/maillist">liste des emails des 
    inscrits</a> (fichier texte). Pour le compte rendu, il y a la 
    <a href="%0/htmllist">liste des inscrits en html</a> (fichier texte).
      <ul> %url
  )
  (fdb:dolist (record %base)
    (if (and record (rname record)) (progn
	(incf valid-users)
	(PF fd "<li><a href=\"%0/users/edit?%1\">%2</a> %4%3" %url 
	  (Q (rid record)) (Q (rname record)) (Q (rnotes record))
	  (if (and (rnumber record) (> (rnumber record) 1)) (progn
	      (incf valid-users (- (rnumber record) 1))
	      (PF String "(%0 pers.) " (rnumber record))
	    ) ""
  )))))
  (PF fd "</ul>\n(%0 participant%1 inscrit%1)" 
    (if (> valid-users 0) valid-users "aucun")
    (if (> valid-users 1) "s" "")
  )
  
  (%page (String fd) :title (+ "Oenologie: réunion du " %name)
    :links [:reunions :oenologie]
  )
)

;;=============================================================================
;;                    mailing list
;;=============================================================================

(defun maillist (&aux notfirst)
  (open-base)
  (fdb:dolist (record %base)
    (if (and record (remail record) (/= "" (remail record))) (progn
	(PF "%1%0" (remail record) (if notfirst ",\n\t" ""))
	(setq notfirst t)
  )))
  (PF "\n")
  (cgi:end :mimetype "text/plain" :validity 15)
  (exit 0)
)

;;=============================================================================
;;                    htmling list
;;=============================================================================

(defun htmllist (&aux (valid-users 0))
  (open-base)
  (fdb:dolist (record %base)		;count users
    (if (and record (rname record))
	(incf valid-users (if (rnumber record) (rnumber record) 1))
  ))
  
  (PF "<hr>\n<h2>Liste des %0 participants</h2>\n<ul>\n" valid-users)
  (fdb:dolist (record %base)
    (PF "  <li> %0%1\n" (rname record) 
      (if (and (rnumber record) (> (rnumber record) 1)) " +..." "")
  ))
  (PF "</ul>\n<hr>\n")
  (cgi:end :mimetype "text/plain")
  (exit 0)
)

;;=============================================================================
;;                    Form to add user
;;=============================================================================

(defun add-user ()
  (PF   <HEAD><TITLE>Oenologie: ajout d'un utilisateur</TITLE></HEAD>
	<BODY BGCOLOR="#FFCCCC"><h1>Oenologie: ajout d'un utilisateur pour le %1</h1>
    <form method="post" action="%0/users/add/commit">
Nouvel utilisateur:<br>
<p>
Nom: <input name=name size=70 type=text><br>
Email: <input name=email size=70 type=text><br>
<table><tr><td width=50></td><td>
<small><i>Un mail de confirmation sera envoyé à cette adresse pour toute 
modification / deletion de cet utilisateur de cette base de données.
<br>Comme ce mail est envoyé localement, vous pouvez juste taper votre login 
sans le @sophia.inria.fr si votre email est a l'INRIA Sophia
</i></small></td></tr></table><br>Nombre de personnes: %2<br>
<b>(Prière de signaler et donner les noms+prénoms exacts des gens nécessitant 
une demande de laisser-passer, y compris vous-même éventuellement)</b><br>
Notes: <textarea name=notes cols=70 rows=4></textarea><br>
<table><tr><td width=50></td><td>
<small><i>(Seront affichées derrière votre nom dans la liste)
</i></small></td></tr></table><br>
<input type=submit value="Enregistrer">
cet utilisateur, ou <a href="%0">annuler</a> la saisie et revenir à la liste
    </BODY>
    
%url %name (select-number 1)
  )
)

;;=============================================================================
;;                    Form to edit/delete user
;;=============================================================================
;;;TODO
(defun edit-user (name &aux record)
  (open-base) 
  (setq record (find-record-of-name name))
  (PF   <HEAD><TITLE>Oenologie: edition d'un utilisateur</TITLE></HEAD>
    <BODY BGCOLOR="#FFCCCC"><h1>Oenologie: édition d'un utilisateur pour le %5</h1>
    <form method="post" action="%0/users/edit/commit?%4">
    Modifier les données de l'utilisateur:<br>
<p>
    Nom: <b>%1</b><br>
    Email: <input name=email size=70 type=text value=%2><br>
<table><tr><td width=50></td><td>
<small><i>Un mail de confirmation sera envoyé à cette adresse pour toute 
modification / deletion de cet utilisateur de cette base de données.
<br>Comme ce mail est envoyé localement, vous pouvez juste taper votre login 
sans le @sophia.inria.fr si votre email est a l'INRIA Sophia
</i></small></td></tr></table><br>Nombre de personnes: %6<br>
<b>(Prière de signaler et donner les noms+prénoms exacts des gens nécessitant 
une demande de laisser-passer, y compris vous-même éventuellement)</b><br>
Notes: <textarea name=notes cols=70 rows=4>%3</textarea><br>
<table><tr><td width=50></td><td>
<small><i>(Seront affichées derrière votre nom dans la liste)
</i></small></td></tr></table><br>
    <input type=submit value="Enregistrer">ces modifications, ou
 <a href="%0">annuler</a> toute modification et revenir à la liste.
    <hr>
    Vous pouvez aussi <a href="%0/users/delete/commit?%4">SUPPRIMER</a>
    (immédiatement, sans confirmation) cet utilisateur.
    </BODY>
    
    %url (html:quote-pre (rname record)) (html:quote-pre (remail record))
    (html:quote-pre (rnotes record))(rid record)
    %name (select-number (rnumber record))
  )
)

;;=============================================================================
;;                    perform user delete
;;=============================================================================
;;;TODO
(defun delete-user (name &aux record)
  (open-base)
  (setq record (find-record-of-name name))
  (%page 
    (if (fdb:delete-record %base record)
      (PF String "Une erreur a eu lieu, je n'ai pas pu supprimer <b>%0</b> 
           pour le %1!\n" (Q name) %name)
      (progn (log :delete record)
	(PF String "Ok, <b>%0</b> supprimé de la liste du %1
<br>(Un reload pourra être nécessaire pour updater la liste)\n" (Q name) %name)
      )
    )
    :title "Supression" :heading "" :links [:reunion]
  )
)

;;=============================================================================
;;                    perfmorm user add
;;=============================================================================

(defun register-user (args &aux
    (name (trim-whitespace (get args "name" "")))
    (id (html:quote-values name))
    (email (trim-whitespace (get args "email" "")))
    (notes (get args "notes" ""))
    (number (Int (get args "number" 1)))
    record
  )
  (catch 'Return
    (if (= "" name) (throw 'Return
	(%page "ERROR! le champ Nom: doit être rempli!"
	  :title "Formulaire incomplet" :links [:back]
	)
    ))
    (open-base)
    (fdb:dolist (record %base)
      (if (= (rname record) name) (throw 'Return
	  (%page (PF String 
	    L'utilisateur <b>%0</b> existe déja! Vous ne pouvez pas le rajouter, mais seulement
	    <ul>
	    <li><a href="%1/users/edit?%2">l'éditer</a>
	    <li><a href="%1/users/delete/commit?%2">le supprimer</a>
	    </ul>
	     (Q name) %url id
	    )
	    :title "Double inscription!"
    ))))
    (setq record (fdb:add-record %base))
    (User-name record name)
    (User-email record email)
    (User-notes record notes)
    (User-number record number)
    (%page 
      (if (fdb:save-record %base record)
	(PF String "Une erreur a eu lieu, je n'ai pas pu enregistrer <b>%0</b> 
           pour le %1!\n" (Q name) %name)
	(progn (log :add record)
	  (PF String "Ok, <b>%0</b> ajouté à liste du %1
<br>(Un reload pourra être nécessaire pour le voir)\n" (Q name) %name)
	)
      )
      :title "Ajout" :heading "" :links [:reunion]
)))

;;=============================================================================
;;                    perfmorm user edit
;;=============================================================================

(defun register-user-edit (name args &aux
    (id (html:quote-values name))
    (email (trim-whitespace (get args "email" "")))
    (notes (get args "notes" ""))
    (number (Int (get args "number" 1)))
    record
    oldmail
  )
  (catch 'Return
    (open-base)
    (setq record (find-record-of-name name))
    (setq record (fdb:edit-record %base record))
    (if (typep record String) (throw 'Return
	(%page (PF String "Erreur! utilisateur <b>%0</b> 
en cours d'édition par ailleurs dans la base %1!" (Q name) %name)
	  :title "Double edition" :links [:back]
      ))
      
      (not record) (throw 'Return
	(%page (PF String "Erreur! utilisateur <b>%0</b> 
non trouvé dans la base du %1!" (Q name) %name)
	  :title "Non trouve" :links [:back]
      ))
      
      (progn
	(upgrade-record record)
	(setq oldmail (remail record))
	(User-email record email)
	(User-notes record notes)
	(User-number record number)
	(%page (if (fdb:save-record %base record)
	    (PF String "Une erreur a eu lieu, je n'ai pas pu enregistrer
                        les modifications à <b>%0</b> pour le %1!\n" 
	      (Q name) %name)
	    (progn (log :change record oldmail)
	      (PF String "Ok, modifications à <b>%0</b> enregistrées pour 
                          liste du %1
<br>(Un reload pourra être nécessaire pour les voir)\n" (Q name) %name))
	  )
	  :title "Modification" :heading "" :links [:reunion]
)))))

;;=============================================================================
;;                    misc utils
;;=============================================================================

(defun open-base ()
  (setq %base (fdb:open %basefile))
  (if (/= %basefile (fdb:Base-filename %base)) (progn
      (fdb:update-filename %basefile)
      (setq %base (fdb:open %basefile))
  ))
  (if (not %base) (progn
      (fdb:create %basefile User)
      (sh chmod a+rw ,%basefile)
      (setq %base (fdb:open %basefile))
  ))
)

(setq rname User-name)
(defun rid (record) (html:quote-values (rname record)))
(setq remail User-email)
(setq rnotes User-notes)
(setq rnumber User-number)

(defun upgrade-record (r)		;from previous versions
  (if (< (length r) (length User))
    (put r (- (length User) 1) ())
))

(defun find-record-of-name (name)
  (catch 'Found
    (fdb:dolist (record %base)
      (if (= (rname record) name) (throw 'Found record))
    )
    (%error (PF String "name not found in base: %0" name))
  )
)

(defun trim-whitespace (string &aux
    (res (copy ""))
    (re (regcomp "^([ \t\n]*)([^ \t\n]+)"))
    (offset 0)
  )
  (while (regexec re string offset)
    (if (and (/= 0 (length res)) 
	(/= 0 (length (regsub re 1)))) (nconc res " "))
    (nconc res (regsub re 2))
    (setq offset #[re 2 1])
  )
  res
)

;; trace

(defunq T (&rest args &aux 
    (T::fd (open (copy "") :type :string :direction :io)))
  (with (*standard-output* T::fd *standard-error* *standard-output*)
    (apply PV args)
  )
  (PF "<pre>\n%0\n</pre>\n" (Q (String T::fd)))
)

;;=============================================================================
;;                    HTML generation
;;=============================================================================

(defun %page (body &key
    (title %page-title)
    heading			;default same as title, "" to have nothing
    (color %page-color)
    (background %page-background)
    (links %page-links)
    (header %page-header)
    (footer %page-footer)
  )
  (if (not heading) (setq heading title))
  (PF "<HEAD><TITLE>%0</TITLE></HEAD><BODY %2%3 %4%5>%7
    %1\n%6\n<hr>\n%8\n%9</BODY>\n"
    title				;0
    (if (= "" heading) "" (+ "<h1>" heading "</h1>")) ;1
    (if color "BGCOLOR=" "")		;2
    (if color (+ "\"" color "\"") "")	;3
    (if background "BACKGROUND=" "")	;4
    (if background (+ "\"" background "\"") "")	;5
    body				;6
    (if header header "")		;7
    (if links (%page-format-links links) "") ;8
    (if footer footer "")		;9
  )
)

(defun %error (&rest args)
  (with (%page-title %page-error-title
      %page-color %page-error-color
      %page-background %page-error-background
      %page-links %page-error-links
      %page-header %page-error-header
      %page-footer %page-error-footer
    )
    (apply %page args)
  )
  (throw '%Error)
)

;; links can be a list of text and url, image and trailer
(defun %page-format-links (links &aux link
    (fd (open (copy "") :type :string :direction :io)))
  (if links (progn
      (PF fd "Retourner à:\n")
      (dolist (link-tag links)
	(if (setq link (getn %links link-tag)) 
	  (with (url (eval (get link 1 %url))
	      text (eval (get link 0 "click here"))
	      trailer (eval (get link 3 ""))
	      image (eval (getn link 2))
	    )
	    (if image
	      (PF fd "<br><a href=\"%0\"><img src=\"%3\" border=0 align=center> %1</a> %2\n" 
		url text trailer image)
	      (PF fd "<br><a href=\"%0\">%1</a> %2\n" url text trailer)
	    )
      )))
      (PF fd "\n")
  ))
  (String fd)
)

(defun select-number (num &aux 
    (n (if num num 1))
    (fd (open (copy "") :type :string :direction :io))
  )
  (PF fd "<select name=\"number\">\n")
  (dotimes (i 10)
    (PF fd "<option%1>%0</option>\n" (+ i 1) 
      (if (= (+ i 1) num) " selected" "")
  ))
  (PF fd "</select>\n")
  (String fd)
)

;;=============================================================================
;;                    Logging, monitoring
;;=============================================================================

(defun log (command record &optional oldmail &aux
    (logfile (+ %dir "LOG"))
    (mailcommand "mail")
    commandlist
  )
  (with (logfd (open logfile :direction :output))
    (PF logfd "%0: [%1] %l2 %l3 %l5 %l4 | REMOTE_HOST=%l5 REMOTE_ADDR=%l6 REMOTE_USER=%l7 REMOTE_IDENT=%l8\n" (html:date) command
      (rname record) (remail record) (rnotes record) (rnumber record)
      (getenv "REMOTE_HOST") (getenv "REMOTE_ADDR")
      (getenv "REMOTE_USER") (getenv "REMOTE_IDENT")
    )
    (close logfd)
  )
  (sh chmod a+rw ,logfile)
  (if (and (remail record) (/= "" (remail record))) (progn
      (if (file-stats "/usr/ucb/mail") (setq mailcommand "/usr/ucb/mail"))
      (setq commandlist (list mailcommand "-s" (+ %page-title 
	    " Compte rendu d'inscription pour le " %name) (remail record))
      )
      (if (and oldmail (/= "" oldmail)) (lappend commandlist oldmail))	
      (setq pid (system  commandlist :input 'in))
      (PF in "Rapport de modification vous concernant effectuée sur le fichier
d\x27inscription pour la réunion Oenologie Sophia du %1\n
url: %0\n\nL\x27utilisateur:  %2\na été %3 le:  %4\npar:  %5 %6\n%7\n%8\n"
	%url %name (Q (rname record))
	(get '(:add "ajouté" :delete "supprimmé" :change "modifié") command)
	(html:date) (getenv "REMOTE_HOST") (getenv "REMOTE_ADDR")
	(getenv "REMOTE_USER") (getenv "REMOTE_IDENT")
      )
      (close in)
      (wait pid)
)))

;;=============================================================================
;;                    admin commands
;;=============================================================================
;; a set of commands to administrate a database
;; use by going to a database list and add /admin to the URL

(defun admin-commands (command)
  (if 
    (= command "chmod") (sh chmod a+rw ,%basefile)
    (= command "unlock") (unlock-base)
    (= command "list") (list-base)
    (= command "log") (list-log)
    (= command "clean") (clean-base)
    (= (subseq command 0 4) "kill") (kill-pid (Int (subseq command 4)))
    t
    (PF <HTML><TITLE>Admin commands</TITLE>
<BODY BGCOLOR=\"#FFAAAA\">
Admin commands: <ul>
<li><a href="%0/admin?log">list the log</a> of the base
<li><a href="%0/admin?chmod">chmod a+rw</a> the base
<li><a href="%0/admin?unlock">unlock all records</a> in the base
<li><a href="%0/admin?list">lists contents</a> of the base
<li><a href="%0/admin?clean">checks and clean</a> the base
<li>kill pid: by appending <b>?killXXX</b> to this URL, with XXX pid
</ul>
<a href="%0">main page</a>
</BODY>
      %url
    )
  )
)

(defun kill-pid (n)
  (sh kill ,n)
)

(defun unlock-base ()
  (open-base)
  (PF <HTML><TITLE>unlocking records</TITLE><BODY>Unlocking records:<ul>)
  (fdb:dolist (record %base)
    (if (fdb:Record->locked? record) (progn
	(PF "<li>unlocking <b>%0</b>\n" 
	  (if (rname record) (Q (rname record)) "***EMPTY***")
	)
	(fdb:Record->locked? record ())(fdb:Record->lock-date record ())
  )))
  (PF "</ul></BODY>\n")
  (fdb::write-base (fdb:Base-filename %base) %base)
)

(defun list-base (&aux (fd (open (copy "") :type :string :direction :io)))
  (open-base)
  (PF "<HTML><TITLE>internal base list %0</TITLE><BODY>\n<pre>\n" %name)
  (with (*standard-output* fd)
    (fdb:base-pp %base)
  )
  (PF "%0</pre></BODY>\n" (Q (String fd)))
)

(defun list-log (&aux (fd (open (copy "") :type :string :direction :io)))
  (PF "<HTML><TITLE>base log list %0</TITLE><BODY>\n<pre>\n" %name)
  (with (*standard-output* fd lines (list) lfd (open (+ %dir "LOG")))
    (catch 'EOF (while t (insert lines 0 (read-line lfd))))
    (dolist (line lines)
      (PF fd "%0\n" line)
    )
  )
  (PF "%0</pre></BODY>\n" (Q (String fd)))
)

(defun clean-base (&aux 
    (count 0)
    (todel (list))
    res
  )
  (open-base)
  (PF "<HTML><TITLE>base check %0</TITLE><BODY>\nbad records:\n<ol>" %name)
  (fdb:dolist (record %base)
    (if (or (not record)
	(not (rname record))
      ) (progn
	(incf count)
	(PF "<li>%0\n" (Q (PF String "%l0" record)))
	(lappend todel record)
      )
      (upgrade-record record)
  ))  
  (PF "</ol>%0 records found bad.\n" count)
  (if todel (PF "<p> removing these bad records:<ol>\n"))
  (dolist (record todel)
    (if (setq res (fdb:delete-record %base record))
      (PF "<li> *** DELETION FAILED: %0\n" (Q res))
      (PF "<li> OK, deleted!\n")
  ))
  (PF "%0</BODY>\n" (if todel "</ol>"))
)

;;=============================================================================
;;                    error handler
;;=============================================================================

(defun print-stack-dump:pre-handler (&rest args &aux 
    (date (html:date))
    s
    (dump (open (copy "") :type :string :direction :io))
  )
  (with (print-stack-dump:output dump
      print-stack-dump:exit-after ()
      print-stack-dump:print-local-vars t
      print-stack-dump:print-all-vars t
    ) 
    (apply print-stack-dump args)
  )
  (setq cgi:out-string
    (print-format String "<HTML><TITLE>Script Error!</TITLE>
<BODY BGCOLOR=\"#FFAAAA\">
Sorry, this cgi-script crashed in error. Please mail the maintainer:
<br><b>%2</b>
<br>that an error occured in
<br><b>%0</b>
<br>on
<br><b>%1</b><hr><pre>
%3
</pre>
</BODY></HTML>\n" %url date %maintainer (Q (String dump))))

  (cgi:end :validity 15)
      
  (print-format *standard-error* "\n%2\n### ERROR in %0\n### on %1\n"
    %url date
    "========================================================================="
  )
)

(defun print-stack-dump:post-handler () (flush ())(sh sleep 2) (exit 0) )

(main)

;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***

