/{view,control}.scm
+;; parts:
+;; 'both => load control and view (anything other than view or control
+;; 'view => load view only
+;; 'control => load control only
+(define (session:call-parts self page #!key (parts 'both))
(sdat-set-curr-page! self page)
- ;; (session:log self "page-dir-style: " (sdat-get-page-dir-style self))
- (let* ((dir-style ;; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
- (sdat-get-page-dir-style self))
- (dir (string-append (sdat-get-sroot self)
- (if dir-style
- (conc "/pages/")
- (conc "/pages/" page))))
- (control (string-append dir (if dir-style
- (conc page "_ctrl.scm")
- "/control.scm")))
- (view (string-append dir (if dir-style
- (conc page "_view.scm")
- "/view.scm")))
- (load-view (and (file-exists? view)
- (or (eq? parts 'both)(eq? parts 'view))))
- (load-control (and (file-exists? control)
- (or (eq? parts 'both)(eq? parts 'control))))
- (view-dat '()))
- ;; (session:log self "dir-style: " dir-style)
- ;; (sugar "/home/matt/kiatoa/stml/sugar.scm" ))
- ;; (print "dir=" dir " control=" control " view=" view " load-view=" load-view " load=control=" load-control)
- (if load-control
- (begin
- (load control)
- (session:set-called! self page)))
- ;; move this to where it gets exectuted only once
- ;;
- ;;(s:log "s:b yields " (s:b "blah"))
- (if load-view
- ;; option one:
- ;;
- ;; (let ((inp (open-input-string
- ;; (files-read->string "/home/matt/kiatoa/stml/sugar.scm"
- ;; view))))
- ;; (map
- ;; (lambda (x)
- ;; (cond
- ;; ((list? x) x)
- ;; ((string? x) x)
- ;; (else '())))
- ;; (port-map eval (lambda ()
- ;; (read inp)))))
- ;;
- ;; option two:
- ;;
- (let* (;; (inps (map open-input-file (list view))) ;; sugar view)))
- (p (open-input-file view)) ;; (apply make-concatenated-port inps))
- (dat (process-port p)))
- ;;(map
- ;; (lambda (x)
- ;; (cond
- ;; ((list? x) x)
- ;; ((string? x) x)
- ;; (else '())))
- ;; (port-map eval (lambda ()(read p))))))
- ;; (map close-input-port inps)
- (close-input-port p)
- dat)
- (list "Page not found " page "
"))))
-
-;;(define (session:call self page)
-;; (session:call-parts self page 'both))
+ (let* ((dir-style (sdat-get-page-dir-style self));; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
+ (dir (string-append (sdat-get-sroot self)
+ (if dir-style
+ (conc "/pages/")
+ (conc "/pages/" page)))))
+ (case dir-style
+ ;; NB// Stored always loads both control and view
+ ((stored)
+ ((eval (string->symbol (conc "pages:" page)))
+ self ;; the session
+ (sdat-get-conn self) ;; the db connection
+ (sdat-get-shared-hash self) ;; a shared hash table for passing data to/from page calls
+ ))
+ ((flat)
+ (let* ((so-file (conc dir page ".so"))
+ (scm-file (conc dir page ".scm"))
+ (src-file (or (file-exists? so-file)
+ (file-exists? scm-file))))
+ (if src-file
+ (begin
+ (load src-file)
+ ((eval (string->symbol (conc "pages:" page)))
+ self ;; the session
+ (sdat-get-conn self) ;; the db connection
+ (sdat-get-shared-hash self) ;; a shared hash table for passing data to/from page calls
+ ))
+ (list "Page not found " page "
"))))
+ ;; first the control
+ ;; (let ((control-file (conc "pages/" page "_ctrl.scm"))
+ ;; (view-file (conc "pages/" page "_view.scm")))
+ ;; (if (and (file-exists? control-file)
+ ;; (not (eq? parts 'view)))
+ ;; (begin
+ ;; (session:set-called! self page)
+ ;; (load control-file)))
+ ;; (if (file-exists? view-file)
+ ;; (if (not (eq? parts 'control))
+ ;; (session:process-file view-file))
+ ;; (list "Page not found " page "
")))
+ ((dir) "ERROR: dir style not yet re-implemented")
+ (else
+ (list "ERROR: page-dir-style must be stored, dir or flat, got " dir-style)))))
(define (session:call self page parts)
(session:call-parts self page 'both))
-(define (session:load-model self model)
- (let ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm"))
- (model.so (string-append (sdat-get-sroot self) "/models/" model ".so")))
- (if (file-exists? model.so)
- (load model.so)
- (if (file-exists? model.scm)
- (load model.scm)
- (s:log "ERROR: model " model.scm " not found")))))
-
-(define (session:model-path self model)
- (string-append (sdat-get-sroot self) "/models/" model ".scm"))
+;; (define (session:load-model self model)
+;; (let ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm"))
+;; (model.so (string-append (sdat-get-sroot self) "/models/" model ".so")))
+;; (if (file-exists? model.so)
+;; (load model.so)
+;; (if (file-exists? model.scm)
+;; (load model.scm)
+;; (s:log "ERROR: model " model.scm " not found")))))
+
+;; (define (session:model-path self model)
+;; (string-append (sdat-get-sroot self) "/models/" model ".scm"))
(define (session:pp-formdat self)
(let ((dat (formdat:all->strings (sdat-get-formdat self))))
(string-intersperse dat "
")))
Index: setup.scm
==================================================================
--- setup.scm
+++ setup.scm
@@ -10,14 +10,10 @@
(declare (unit setup))
(declare (uses session))
(require-extension srfi-69)
(require-extension regex)
-;;
-(define s:session (make-sdat))
-(session:initialize s:session)
-
;; use this for getting data from page to page when scope and evals
;; get in the way
(define s:local-vars (make-hash-table))
(define (s:local-set! k v)
@@ -24,17 +20,13 @@
(hash-table-set! s:local-vars k v))
(define (s:local-get k)
(hash-table-ref/default s:local-vars k #f))
-(session:setup s:session)
-
(define (s:log . msg)
(apply session:log s:session msg))
-(session:get-vars s:session)
-
(define (s:set-err . args)
(sdat-set-curr-err! s:session args))
;; Usage: (s:get-err s:big)
(define (s:get-err wrapperfunc)
@@ -101,10 +93,15 @@
(define (s:load-model model)
(session:load-model s:session model))
(define (s:model-path model)
(session:model-path s:session model))
+
+;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
+;;
+(define (s:get-page-params)
+ (sdat-get-page-params s:session))
(define (s:db)
(sdat-get-conn s:session))
(define (s:never-called-page? page)
ADDED stml.meta
Index: stml.meta
==================================================================
--- /dev/null
+++ stml.meta
@@ -0,0 +1,20 @@
+(
+; Your egg's license:
+(license "LGPL")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category misc)
+
+; A list of eggs mpeg3 depends on. If none, you can omit this declaration
+; altogether. If you are making an egg for chicken 3 and you need to use
+; procedures from the `files' unit, be sure to include the `files' egg in the
+; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
+; `depends' is an alias to `needs'.
+(needs srfi-69)
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "Primitive argument processor."))
Index: stml.scm
==================================================================
--- stml.scm
+++ stml.scm
@@ -64,10 +64,12 @@
(define (s:code . args) (s:common-tag "CODE" args))
(define (s:div . args) (s:common-tag "DIV" args))
(define (s:h1 . args) (s:common-tag "H1" args))
(define (s:h2 . args) (s:common-tag "H2" args))
(define (s:h3 . args) (s:common-tag "H3" args))
+(define (s:h4 . args) (s:common-tag "H4" args))
+(define (s:h5 . args) (s:common-tag "H5" args))
(define (s:head . args) (s:common-tag "HEAD" args))
(define (s:html . args) (s:common-tag "HTML" args))
(define (s:i . args) (s:common-tag "I" args))
(define (s:img . args) (s:common-tag "IMG" args))
(define (s:input . args) (s:common-tag "INPUT" args))
ADDED stml.setup
Index: stml.setup
==================================================================
--- /dev/null
+++ stml.setup
@@ -0,0 +1,18 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;;;; margs.setup
+
+;; compile the code into a dynamically loadable shared object
+;; (will generate margs.so)
+;; (compile -s margs.scm)
+
+;; Install as extension library
+(install-extension 'stml "stml.so")
+
ADDED stmlcommon.scm
Index: stmlcommon.scm
==================================================================
--- /dev/null
+++ stmlcommon.scm
@@ -0,0 +1,65 @@
+;; Copyright 2007-2011, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;; (require-extension syntax-case)
+;; (declare (run-time-macros))
+
+(include "requirements.scm")
+(declare (uses cookie))
+(declare (uses html-filter))
+(declare (uses misc-stml))
+(declare (uses formdat))
+(declare (uses stml))
+(declare (uses session))
+(declare (uses setup)) ;; s:session gets created here
+(declare (uses sqltbl))
+(declare (uses keystore))
+
+(define (stml:cgi-session session)
+ (session:initialize session)
+ (session:setup session)
+ (session:get-vars session)
+
+ (sdat-set-log-port! session ;; (current-error-port))
+ (open-output-file (sdat-get-logfile session) #:append))
+ (s:validate-inputs)
+ (session:run-actions session)
+ (sdat-set-pagedat! session
+ (append (sdat-get-pagedat session)
+ (s:call (sdat-get-toppage session))))
+ (if (eq? (sdat-get-page-type session) 'html) ;; default is html.
+ (session:cgi-out session)
+ (session:alt-out session))
+ (session:save-vars session)
+ (session:close session))
+
+(define (stml:main proc)
+ (handle-exceptions
+ exn
+ (begin
+ (print "Content-type: text/html")
+ (print "")
+ (print " EXCEPTION ")
+ (print " QUERY_STRING is: " (get-environment-variable "QUERY_STRING") "
")
+ (print "")
+ ;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+ (print-error-message exn)
+ (print-call-chain)
+ (print "
")
+ (print "")
+ (for-each (lambda (var)
+ (print "| " (car var) " | " (cdr var) " |
"))
+ (get-environment-variables))
+ (print "
")
+ (print ""))
+
+ (if proc (proc s:session) (stml:cgi-session s:session))
+ ;; (raise-error)
+ ;; (exit)
+ ))
ADDED stmlmodule.scm
Index: stmlmodule.scm
==================================================================
--- /dev/null
+++ stmlmodule.scm
@@ -0,0 +1,14 @@
+;; Copyright 2007-2011, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;; (require-extension syntax-case)
+;; (declare (run-time-macros))
+
+(include "stmlcommon.scm")
+
Index: stmlrun.scm
==================================================================
--- stmlrun.scm
+++ stmlrun.scm
@@ -10,49 +10,9 @@
;; PURPOSE.
;; (require-extension syntax-case)
;; (declare (run-time-macros))
-(handle-exceptions
- exn
- (begin
- (print "Content-type: text/html")
- (print "")
- (print " EXCEPTION ")
- (print " QUERY_STRING is: " (get-environment-variable "QUERY_STRING") "
")
- (print "")
- ;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
- (print-error-message exn)
- (print-call-chain)
- (print "
")
- (print "")
- (for-each (lambda (var)
- (print "| " (car var) " | " (cdr var) " |
"))
- (get-environment-variables))
- (print "
")
- (print ""))
- (include "requirements.scm")
- (declare (uses cookie))
- (declare (uses html-filter))
- (declare (uses misc-stml))
- (declare (uses formdat))
- (declare (uses stml))
- (declare (uses session))
- (declare (uses setup)) ;; s:session gets created here
- (declare (uses sqltbl))
- (declare (uses keystore))
-
- (sdat-set-log-port! s:session ;; (current-error-port))
- (open-output-file (sdat-get-logfile s:session) #:append))
- (s:validate-inputs)
- (session:run-actions s:session)
- (sdat-set-pagedat! s:session
- (append (sdat-get-pagedat s:session)
- (s:call (sdat-get-toppage s:session))))
- (if (eq? (sdat-get-page-type s:session) 'html) ;; default is html.
- (session:cgi-out s:session)
- (session:alt-out s:session))
- (session:save-vars s:session)
- (session:close s:session)
- ;; (raise-error)
- ;; (exit)
- )
+;; (include "stmlcommon.scm")
+(require-library stml)
+
+(stml:main #f)