#!/usr/local/bin/klone
(setq max-level *maxint*)
(setq *package* 'A)
;;=============================================================================
;; Global vars
;;=============================================================================
;; %url and %dir are the base of sub-bases named by the sub-dirs present there
;; things you must change---------------------------------------------------
URL = "http://www.inria.fr/cgi-bin/nph-colas-aucland"
;; URL = "http://localhost/cgi-bin/nph-colas-aucland"
DIR = "/htdocs/files/koala/aucland"
;;DIR = "/var/www/webspace/pages/aucland"
MAINTAINER = "Colas.Nahaboo@sophia.inria.fr"
PAGE-COLOR = "#FFDDBB"
TITLE = "Aucland concours Einstein"
BASEFILE = "einstein.kdb"
PRE-TEXT = "Ont déja répondu au concours aucland (à faire avant le
12 Novembre), à l'URL http://www.aucland.fr/accdb/viewItem.asp?IDI=118544 (attention: il faut d'abord s'identifier sur aucland, puis suivre le lien, et remplir le formulaire en bas de page), avec le nombre de bonnes réponses
anticipées:\n
La bonne réponse est:
Nom de l'objet: Le livre L'EVOLUTION DES IDEES EN PHYSIQUE exposant La Theorie de la Relativité
Inventeur: Albert Einstein
"
POST-TEXT = "
Ajoutez votre réponse à la base:"
;; To administrate the base, use %url/name/admin
;;; things you dont need to change--------------------------------------------
(fdb:defstruct User
:name ; the name of the User
:number ; his proposed number
)
;; add here the path of the klone library accesible for cgi scripts:
;;(insert *load-pathname* 0 "/users/colas/Klone/src/kl")
;; 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)
)
;; misc defs, internal use
(if (/= #\/ (get DIR -1)) (nconc DIR "/")) ;dir must be /-terminated
(setq PF print-format)
(setq Q html:quote-pre)
;;=============================================================================
;; main dispatch
;;=============================================================================
(defun main (&aux
(re (regcomp "^[/]delete[/](.+)$"))
)
(stack-dump-on-error t *maxint* () print-stack-dump:pre-handler
print-stack-dump:post-handler) ;full stack dump on errors
(goto-dir DIR)
(cgi:init :error (+ DIR "ERRORS"))
;; first, decide what want the user?
(if
(= cgi:path-info "") ;no subpart? mainpage
(show-main-page)
(= cgi:path-info "/admin") ;admin functions
(admin-page)
(= cgi:path-info "/add")
(add-entry
(trim-whitespace (get cgi:arguments "name"))
(trim-whitespace (get cgi:arguments "number"))
)
(re cgi:path-info) ;delete user
(delete-user (html:unquote-values (re 1)))
(PF "Unknown command!\n") ;there is a ball in the soup
)
(cgi:end)
)
;;=============================================================================
;; Main page: List database
;;=============================================================================
(defun show-main-page ()
(PF "%0%0
\n%2\n"
TITLE PAGE-COLOR PRE-TEXT
)
(open-base)
(sort BASE.records compare-records) ;sort per number
(fdb:dolist (record BASE)
(PF "
%0 %1\n" record.number record.name)
)
(PF "\n%0\n
\n" POST-TEXT URL)
)
(defun compare-records (r1 r2)
(compare r1.number r2.number)
)
(defun add-entry (name number &aux)
(catch 'Return
(if (= "" name) (throw 'Return
(PAGE "ERROR! le champ Nom: doit être rempli!"
:title "Formulaire incomplet"
))
(not (match "^[0-9]+$" number)) (throw 'Return
(PAGE "ERROR! le champ Nombre: doit être un nombre positif!"
:title "Formulaire incomplet"
))
)
(open-base)
(fdb:dolist (record BASE)
(when (= record.name name)
(setq record (fdb:edit-record BASE record))
record.number = number
(throw 'Return (PAGE (if (fdb:save-record BASE record)
(PF String "Une erreur a eu lieu, je n'ai pas pu enregistrer
le nom %0\n" name)
(PF String "Ok, done. Retour.\n" URL)
)
:title "Ajout"
))))
;; If we are here, we must add
record = (fdb:add-record BASE)
record.name = name
record.number = number
(PAGE (if (fdb:save-record BASE record)
(PF String "Une erreur a eu lieu, je n'ai pas pu enregistrer
le nom %0\n" name)
(PF String "Ok, done. Retour.\n" URL)
)
:title "Ajout"
)
)
)
;;=============================================================================
;; Admin
;;=============================================================================
(defun admin-page ()
(PF "%0%0
\n%2\n"
TITLE PAGE-COLOR (+ PRE-TEXT "\nAdministration functions")
)
(open-base)
(sort BASE.records compare-records) ;sort per number
(fdb:dolist (record BASE)
(PF "
DELETE %0 %1\n"
record.number record.name URL (html:quote-values record.name))
)
(PF "\n
\n")
)
(defun delete-user (name)
(open-base)
(setq record (find-record-of-name name))
(PAGE
(if (and record (fdb:delete-record BASE record))
(PF String "Une erreur a eu lieu, je n'ai pas pu supprimer %0\n"
(Q name))
(PF String "Ok, %0 supprimé. Retour.\n"
(Q name) URL)
)
:title "Supression"
)
)
;;=============================================================================
;; misc utils
;;=============================================================================
;; read base, locks it. Creates it if it does not exist
(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))
))
)
(defun find-record-of-name (name)
(catch 'Found
(fdb:dolist (record BASE)
(if (= record.name name) (throw 'Found record))
)
()
)
)
(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 "\n%0\n
\n" (Q (String T::fd)))
)
(defun goto-dir (dir &aux)
(when (/= 'directory (file-type dir))
(wait (system (list "rm" "-f" dir)))
(wait (system (list "mkdir" "-p" dir)))
(wait (system (list "chmod" "a+rwx" dir)))
)
*current-directory* = DIR
)
;;=============================================================================
;; error handler
;;=============================================================================
(defun PAGE (body &key
(title "Error!")
heading ;default same as title, "" to have nothing
(color "#FFCCCC")
(background ())
(header "")
(footer "")
)
(if (not heading) (setq heading title))
(PF "%0%7
%1\n%6\n
\n%8\n%9\n"
title ;0
(if (= "" heading) "" (+ "" heading "
")) ;1
(if color "BGCOLOR=" "") ;2
(if color (+ "\"" color "\"") "") ;3
(if background "BACKGROUND=" "") ;4
(if background (+ "\"" background "\"") "") ;5
body ;6
(if header header "") ;7
"" ;8 links
(if footer footer "") ;9
)
)
(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 "Script Error!
Sorry, this cgi-script crashed in error. Please mail the maintainer:
%2
that an error occured in
%0
on
%1
%3
\n" URL date MAINTAINER (Q (String dump))))
(cgi:end)
(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: ***