From: drewc Date: Fri, 7 Sep 2007 00:16:44 +0000 (-0700) Subject: nuke more cruft X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/c448dd7d1fa2159b781a83bd6bb782c8e36f1472 nuke more cruft darcs-hash:20070907001644-39164-44d18557f790c0cf3fab8f7ab95ab9d2b4863efe.gz --- diff --git a/bin/start.lisp b/bin/start.lisp deleted file mode 100644 index 3a89ff5..0000000 --- a/bin/start.lisp +++ /dev/null @@ -1,86 +0,0 @@ -;; -*- lisp -*- - -(in-package :common-lisp-user) - -#+cmu -(defun init-cmu-mp () - ;; this isn't strictly necessary, but scheduling feels very coarse - ;; without startup-idle-and-top-level-loops, leading to answer delays - ;; of about 1s per request. - (unless (find-if - #'(lambda (proc) (string= (mp:process-name proc) "Top Level Loop")) - (mp:all-processes)) - (mp::startup-idle-and-top-level-loops))) - -#+cmu -(init-cmu-mp) - -;;;; * UCW server initialization "script" - -;;;; This file is meant to be loaded by ucwctl, but you can use it a -;;;; general "startup ucw" file as well. You should customize this -;;;; script to load/prepare your application. - -;;;; ** Loadup dependencies - -;;;; Load arnesi first so we can set arnesi::*call/cc-returns* before -;;;; ucw is compiled and loaded. -(asdf:oos 'asdf:load-op :arnesi) -(setf arnesi::*call/cc-returns* nil) - -;;;; Load up UCW itself -(asdf:oos 'asdf:load-op :ucw) - -(in-package :it.bese.ucw-user) - -#+(and sbcl sb-unicode) -(setf (external-format-for :slime) :utf-8-unix - (external-format-for :url) :utf-8 - (external-format-for :http-emacsen) :utf-8-unix - (external-format-for :http-lispish) :utf-8) - -;;;; Load the default applications systems - -(asdf:oos 'asdf:load-op :ucw.examples) -(asdf:oos 'asdf:load-op :ucw.admin) -(asdf:oos 'asdf:load-op :lisp-on-lines) -(asdf:oos 'asdf:load-op :lisp-on-lines.example) - -;;;; Let there be swank. -(swank:create-server :port 4007) - -;;;; Finally startup the server - -;;;; ** Finally startup the server - -(ucw:create-server :backend :araneida - - ;; :httpd - ;; :mod-lisp - ;; :aserve - :host "merlin.tech.coop" - :port 8082 - :applications (list - lol::*lol-example-application*) - :inspect-components nil - :log-root-directory (make-pathname :name nil :type nil - :directory (append (pathname-directory *load-truename*) - (list :up "logs")) - :defaults *load-truename*) - :log-level +info+ - :start-p t) - -;;;; ** Allocate one database connection per thread : - -(defmethod araneida:handle-request-response :around ((handler ucw::ucw-handler) method request) - (clsql:with-database (my-db '("localhost" "lol" "lol" "lol") :pool t) - (clsql:with-default-database (my-db) - (call-next-method)))) - -(publish-directory (server.backend *default-server*) #P"/home/drewc/src/site/lisp-on-lines/wwwroot/dojo/" "/dojo/") -(publish-directory (server.backend *default-server*) #P"/home/drewc/src/site/lisp-on-lines/wwwroot/prototype/" "/prototype/") - -(publish-directory (server.backend *default-server*) #P"/home/drewc/src/sunrise/wwwroot/" "/") - - - diff --git a/src/components/ajax.lisp b/src/components/ajax.lisp deleted file mode 100644 index b7fc38c..0000000 --- a/src/components/ajax.lisp +++ /dev/null @@ -1,224 +0,0 @@ -(in-package :lisp-on-lines) - -;;;; for when there is nothing left to display. -(defcomponent empty-page (window-component) - ()) - -(defmethod render-on ((res response) (self empty-page)) - "didnt find a thing") - -(defcomponent auto-complete () - ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)) - (output-id :accessor output-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)) - (client-value - :accessor client-value - :initform "" - :documentation "The string the user has, so far, insterted.") - (index - :accessor index - :initform nil - :documentation "The index (for use with NTH) in list-of-values of the item selected via Ajax") - (list-of-values - :accessor list-of-values - :initform '() - :documentation "The list generated by values-generator") - (values-generator :accessor values-generator :initarg :values-generator - :documentation "Function which, when passed the auto-complete component, returns a list of objects.") - (value - :accessor value - :initform nil - :documentation "The lisp value of the object selecting in the drop down") - (as-value :accessor as-value :initarg :as-value - :documentation "Function which, when passed a value, returns the string to put in the text box.") - (render-it :accessor render-it :initarg :render - :documentation "Function which, when passed the component and one of the values render it (the value).") - (input-size :accessor input-size :initarg :input-size :initform 20) - (submit-on-select-p - :accessor submit-on-select-p - :initarg :submit-on-select-p - :initform t) - (output-component-name :accessor output-component-name :initarg :output-comonent-name :initform 'auto-complete-output))) - -(defmethod js-on-complete ((l auto-complete)) - `(lambda (transport) - (setf (slot-value (document.get-element-by-id ,(output-id l)) - 'inner-h-t-m-l) - transport.response-text))) - -(defmacro make-action-url (component action) - " -There has got to be something like this buried in UCW somewhere, -but here's what i use." - `(ucw::print-uri-to-string - (compute-url ,component - :action-id (ucw::make-new-action (ucw::context.current-frame *context*) - (lambda () - (arnesi:with-call/cc - ,action)))))) - -(defun generate-ajax-request (js-url &optional js-options) - `(new - (*Ajax.*Request - ,js-url - ,js-options))) - -(defmacro with-ajax-request (js-url &rest js-options) - `(generate-ajax-request-for-url - ,js-url - ,@js-options)) - -(defmacro with-ajax-action ((component) &body action) - `(generate-ajax-request - (make-action-url ,component (progn ,@action)))) - - -(defun make-auto-complete-url (input-id) - "creates a url that calls the auto-complete entry-point for INPUT-ID." - (format nil "auto-complete.ucw?&auto-complete-id=~A&~A=~A" - input-id "session" - (ucw::session.id (ucw::context.session ucw::*context*)))) - -(defmethod/cc on-submit ((l auto-complete)) - ()) - -(defmethod js-on-select ((l auto-complete)) - "the javascript that is called when an item is selected" - (when (submit-on-select-p l) - `(progn - (set-action-parameter ,(register-action - (lambda () - (arnesi:with-call/cc - (on-submit l))))) - (submit-form)))) - - -(defmethod render ( (l auto-complete)) - ;; session-values are stored in an eql hash table. - (let ((input-key (intern (input-id l)))) - ;; We are storing the input components in the session, - ;; keyed on the string that we also use as the id for - ;; the input field. - - (unless (get-session-value input-key) - (setf (get-session-value input-key) l)) - - ;; A hidden field to hold the index number selected via javascript - ( trail-length count)) - (incf count) - (find-call-stack-for-crumbs - (when (slot-boundp component 'ucw::calling-component) - (slot-value component 'ucw::calling-component)) - (cons component list-of-parents))) - (t - list-of-parents)))) - (loop - :for c - :on (find-call-stack-for-crumbs self nil) - :do (let ((c c)) - (<:as-html " / ") - (if (cdr c) - ( - (ITEMS LIST) -GENERATOR :offset &optional (offset integer) => (new-offset integer) -GENERATOR :chunk-size (size integer) => (new-chunk-size integer) -GENERATOR :chunks => (total-number-of-chunks integer) -GENERATOR (:have-previous-p|:have-next-p) => (v boolean).")) - -(defmethod make-range-list-generator ((instance clsql:standard-db-object) &key query (chunk-size 20) (offset 0)) - (let ((view-class (class-of instance)) - (current-offset offset) - (last-select-size 0)) - (labels ((guess-total-size () - (car - (apply #'clsql:select - (clsql:sql-count (clsql:sql-expression :attribute '*)) - :from (clsql:sql-expression :table (slot-value view-class 'clsql:view-table)) - (append query '(:flatp t))))) - (select-items (offset size) - (apply #'clsql:select (class-name view-class) - (append query - `(:limit ,(+ size 1) :offset ,(* (- offset 1) size) :flatp t)))) - (chunks () - (multiple-value-bind (q rem) - (floor (guess-total-size) chunk-size) - (if (zerop rem) q (+ q 1))))) - (lambda (cmd &optional num) - (setf current-offset - (case cmd - (:first 1) - (:last (chunks)) - (:next (+ 1 current-offset)) - (:previous (max 1 (- current-offset 1))) - ((:current :offset) (if num (max 1 num) current-offset)) - (otherwise current-offset))) - (ecase cmd - ((:first :last :next :previous :current) - (let ((items (select-items current-offset chunk-size))) - (setf last-select-size (length items)) - (when (> last-select-size chunk-size) - (nbutlast items)) - items)) - (:chunks (chunks)) - (:chunk-size (when num (setf chunk-size num)) - chunk-size) - (:offset current-offset) - (:have-previous-p (> current-offset 1)) - (:have-next-p (> last-select-size chunk-size))))))) - -(defcomponent range-list (mewa::mewa-list-presentation) - ((offset :accessor range-list.offset - :initform 0 - :backtrack t - :documentation "Which of the windows we're currently looking at.") - (window-size :accessor range-list.window-size :initform 20 :initarg :window-size) - (generator :reader range-list.generator) - (generator-args :reader range-list.generator-args :initarg generator-args :initform nil)) - (:documentation "Component for showing the user a set of data one \"window\" at a time. - -The data set is presented one \"window\" at a time with links to -the the first, previous, next and last window. Each window shows -at most WINDOW-SIZE elements of the data. -The GENERATOR is used to get a data to display every time. -It is produced by MAKE-RANGE-LIST-GENERATOR as -MAKE-RANGE-LIST-GENERATOR INSTANCE :chunk-size WINDOW-SIZE GENERATOR-ARGS")) - -(defmethod range-list.generator :before ((self range-list)) - (unless (slot-boundp self 'generator) - (create-generator self))) - -(defmethod create-generator ((self range-list) &rest args) - (with-slots (instance generator generator-args window-size offset) - self - (when args - (setf generator-args args)) - (setf generator - (apply 'make-range-list-generator instance :chunk-size window-size generator-args) - offset 0) - (funcall generator :offset offset))) - -(defmethod range-list.have-previous-p ((self range-list)) - "Returns true if we have a window before the current one." - (funcall (range-list.generator self) :have-previous-p)) - -(defmethod range-list.have-next-p ((self range-list)) - "Returns true if we have a window after the current one." - (funcall (range-list.generator self) :have-next-p)) - -(defmethod range-list.fetch-items ((self range-list) op) - (prog2 - (ecase op ((:first :last :current :next :previous) t)) - (funcall (range-list.generator self) op) - (setf (range-list.offset self) - (funcall (range-list.generator self) :offset)))) - -(defmethod/cc scroll ((self range-list) op) - (funcall (range-list.generator self) :offset (range-list.offset self)) - (setf (mewa::instances self) - (range-list.fetch-items self op))) - -(defmethod/cc scroll-to-page ((self range-list) window-number) - (setf (range-list.offset self) window-number) - (scroll self :current)) - -(defmethod present ((self range-list)) - (when (zerop (range-list.offset self)) - (scroll self :current)) - (<:table :class (css-class self) - (<:tr - (<:td (call-next-method))) - (<:tr - (<:td - (<:table :class "range-list-navigation" - (<:tr - (<:td - ("))) - (<:tt (<:as-html ">")))) - (<:td - (>")))))))))) diff --git a/src/components/search.lisp b/src/components/search.lisp deleted file mode 100644 index 2d011c1..0000000 --- a/src/components/search.lisp +++ /dev/null @@ -1,139 +0,0 @@ -(in-package :lisp-on-lines) - - -(defmethod simple-word-search (class-name slots search-terms) - (select class-name - :where (simple-word-search-where class-name slots search-terms) - :flatp t)) - -(defmethod simple-word-search-where (class-name slots search-terms) - (sql-or - (mapcar #'(lambda (term) - (apply #'sql-or - (mapcar #'(lambda (slot) - (sql-uplike - (sql-slot-value class-name slot) - (format nil "%~a%" term))) - slots))) - search-terms))) - -(defmethod find-slots-of-type (model &key (type 'string) - (types '((string)) types-supplied-p)) - "returns a list of slots matching TYPE, or matching any of TYPES" - (let (ty) - (if types-supplied-p - (setf ty types) - (setf ty (list type))) - (remove nil (mapcar #'(lambda (st) (when (member (second st) ty) - (first st))) - (list-slot-types model))))) - -;;;; * Simple Search Component - -(defcomponent simple-search () - ((search-term :initarg :search-term :accessor search-term :initform "") - (listing :initarg :listing :accessor listing :initform :listing) - (select-returns-p :initarg :select-returns-p :accessor select-returns-p :initform nil) - (search-tables :initarg :search-tables :accessor search-tables :initform nil))) - -(defmethod render-on ((res response)(self simple-search)) - (sym table)))))) - -(defmacro define-view-for-table (&rest tables) - " expand to a form which initialises TABLES for use with LOL" - `(progn - ,@(loop for tbl in tables collect (generate-define-view-for-table tbl)) - (values))) - -(defmacro define-views-for-database () - "expands to init-i-f-t using the listing of tables provided by meta-model" - `(define-view-for-table ,@(meta-model::list-tables))) - - -(defmethod find-slots-of-type (model &key (type 'string) - (types '((string)) types-supplied-p)) - "returns a list of slots matching TYPE, or matching any of TYPES" - (let (ty) - (if types-supplied-p - (setf ty types) - (setf ty (list type))) - (remove nil (mapcar #'(lambda (st) (when (member (second st) ty) - (first st))) - (lisp-on-lines::list-slot-types model))))) - - - - - - -(defmethod word-search (class-name slots search-terms - &key (limit 10) (where (sql-and t))) - (select class-name - :where (sql-and - where - (word-search-where class-name slots search-terms :format-string "~a%")) - :flatp t - :limit limit)) - - -(defmethod word-search (class-name slots (s string) &rest args) - (apply #'word-search class-name slots (list s) args)) - -(defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%")) - (sql-or - (mapcar #'(lambda (term) - (apply #'sql-or - (mapcar #'(lambda (slot) - (sql-uplike - (sql-slot-value class-name slot) - (format nil format-string term))) - slots))) - search-terms))) - - - \ No newline at end of file diff --git a/src/properties.lisp b/src/properties.lisp deleted file mode 100644 index 9c2c129..0000000 --- a/src/properties.lisp +++ /dev/null @@ -1,57 +0,0 @@ -(in-package :lisp-on-lines) - - - - -;;;; PLIST Utilities. - -(defun plist-nunion (new-props plist) - "Destructive Merge of plists. PLIST is modified and returned. -NEW-PROPS is merged into PLIST such that any properties -in both PLIST and NEW-PROPS get the value in NEW-PROPS. -The other properties in PLIST are left untouched." - (loop for cons on new-props by #'cddr - do (setf (getf plist (first cons)) (second cons)) - finally (return plist)) - plist) - -(defun plist-union (new-props plist) - "Non-destructive version of plist-nunion" - (plist-nunion new-props (copy-list plist))) - - - - - - -(defun slots-as-properties (object) - "Makes a plist by making a keyword from the ...ahh .. read the damn code" - (mapcan - #'(lambda (slot-name) - (when (slot-boundp object slot-name) - - (list (intern (symbol-name slot-name) - (find-package :keyword)) - (slot-value object slot-name)))) - (list-slots object))) - -(defun properties-as-slots (plist) - "takes a plist and turns it into slot-definitions, interning the key names in *package*" - (loop for (key val) on plist by #'cddr - collect (let ((name (intern (symbol-name key)))) - `(,name :accessor ,name :initarg ,key :special t :initform ,val)))) - -(defmacro with-properties ((properties &optional (prefix '||)) &body body) - (with-unique-names (p) - (let ((get (intern (strcat prefix '.get))) - (set (intern (strcat prefix '.set))) - (props (intern (strcat prefix '.properties)))) - `(let ((,p ,properties)) - (flet ((,get (p) - (getf ,p p)) - (,set (p v) - (setf (getf ,p p) v)) - (,props () - ,p)) - (declare (ignorable #',get #',set #',props)) - ,@body))))) \ No newline at end of file diff --git a/src/special-initargs.lisp b/src/special-initargs.lisp deleted file mode 100644 index 5fffa46..0000000 --- a/src/special-initargs.lisp +++ /dev/null @@ -1,38 +0,0 @@ -(in-package :lisp-on-lines) - -(defmethod initargs.slot-names (object) - "Returns ALIST of (initargs) . slot-name." - (nreverse (mapcar #'(lambda (slot) - (cons (closer-mop:slot-definition-initargs slot) - (closer-mop:slot-definition-name slot))) - (closer-mop:class-slots (class-of object))))) - -(defun find-slot-names-from-initargs-plist (object initargs-plist) - "returns (VALUES SLOT-NAMES VALUES), Given a plist of initargs such as one would pass to :DEFAULT-INITARGS. -SLOT-NAMES contains the slot-names specified by the initarg, and VALUES the corresponding VALUE." - (let (slot-names values - (initargs.slot-names-alist (initargs.slot-names object))) - (loop for (initarg value) on initargs-plist - do (let ((slot-name - (cdr (assoc-if #'(lambda (x) (member initarg x)) - initargs.slot-names-alist)))) - (when slot-name ;ignore invalid initargs. (good idea/bad idea?) - (push slot-name slot-names) - (push value values))) - finally (return (values slot-names values))))) - -(defun funcall-with-special-initargs (object initargs function &rest args) - "Call FUNCTION with dynnamic bindings of the slots in OBJECT specified by the INITARGS plist" - (multiple-value-bind (slot-names values) - (find-slot-names-from-initargs-plist object initargs) - (special-symbol-progv - (with-symbol-access - (loop for slot-name in slot-names - collect (slot-value object slot-name))) - values - (apply function args)))) - -(defmacro with-special-initargs ((object &rest initargs) &body body) - `(funcall-with-special-initargs ,object ,initargs - #'(lambda () - ,@body))) \ No newline at end of file diff --git a/src/standard-display.lisp b/src/standard-display.lisp deleted file mode 100644 index b8282c5..0000000 --- a/src/standard-display.lisp +++ /dev/null @@ -1,181 +0,0 @@ -(in-package :lisp-on-lines) - -(deflayer lisp-on-lines ()) - -;;;; The Standard Layers -(deflayer viewer (lisp-on-lines)) -(deflayer editor (lisp-on-lines)) - -;;;; Attributes -(defdisplay - :in-layer editor - ((attribute standard-attribute) object) - (call-next-method)) - -(defdisplay - ((attribute standard-attribute) object component) - (<:as-html (attribute-value object attribute))) - -(define-layered-method display-using-description - ((attribute standard-attribute) object component) - (with-component (component) - ) - (<:as-html (attribute-value object attribute))) - -(define-layered-method label (anything) - nil) - -(defdisplay - :in-layer editor :around (description object) - "It is useful to remove the viewer layer when in the editing layer. -This allows us to dispatch to a subclasses editor. -" - (with-inactive-layers (viewer) - (call-next-method))) - -;;;; These layers affect the layout of the object -(deflayer one-line) -(deflayer as-table) -(deflayer as-string) - -(defdisplay - :in-layer as-string (d o (self t)) - (with-output-to-string (yaclml::*yaclml-stream*) - (do-attributes (a d) - (display-attribute a o) - (<:as-html " ")) - #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels) -))) - - -(defdisplay - :in-layer as-string (d o) - (with-output-to-string (yaclml::*yaclml-stream*) - (do-attributes (a d) - (display-attribute a o) - (<:as-html " ")) - #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels) -))) - -(defmethod list-slots (thing) - (list 'identity)) - -;;;; * Object displays. - - - -;;;; TODO: all lisp types should have occurences and attributes defined for them. - -(defdisplay ((description t) lisp-value) - (<:as-html lisp-value)) - -(defdisplay (description (object string)) - (<:as-html object)) - -(defdisplay (description (object symbol)) - (<:as-html object)) - -(defdisplay (description object (component t)) - "The default display for CLOS objects" - (print (class-name (class-of object))) - (dolist* (slot-name (list-slots object)) - (let ((boundp (slot-boundp object slot-name))) - (format t "~A~A : ~A" (strcat slot-name) - (if boundp - "" - "(unbound)") - (if boundp - (slot-value object slot-name) ""))))) - -(defdisplay ((description t) object) - "The default display for CLOS objects in UCW components" - (dolist* (slot-name (list-slots object)) - - (let ((boundp (slot-boundp object slot-name))) - (<:label :class "lol-label" - (display-attribute 'label (strcat slot-name)) - (if boundp - "" - "(unbound)")) - (<:as-html - (if boundp - (slot-value object slot-name) ""))))) - -;;;; ** The default displays for objects with a MEWA occurence - -(defdisplay (description object) - (<:div - :class "lol-display" - (when (label description) - (<:span - :class "title" - (<:as-html (label description)))) - (do-attributes (attribute description) - (<:div - :class "attribute" - (display-attribute attribute object))))) - -;;;; ** One line -(defdisplay - :in-layer one-line (description object) - "The one line presentation just displays the attributes with a #\Space between them" - (do-attributes (attribute description) - (display-attribute attribute object) - (<:as-html " "))) - -;;;; ** as-table - -(defdisplay :in-layer as-table (description object) - (<:table - (do-attributes (a description) - (<:tr - (<:td :class "lol-label" (<:as-html (label a))) - (<:td (display-attribute a object)))))) - -;;;; List Displays - -#| (deflayer list-display-layer) - -(define-layered-class description - :in-layer list-display-layer () - ((list-item :initarg :list-item - :initarg :table-item - :initform nil - :special t - :accessor list-item))) - -(defdisplay (desc (list list)) - (with-active-layers (list-display-layer) - (<:ul - (dolist* (item list) - (<:li (apply #'display* item (list-item desc))))))) - -(defdisplay :in-layer as-table (description (list list)) - (with-active-layers (list-display-layer) - (let ((item-description (find-occurence (first list)))) - (<:table - (funcall - (apply #'lol::make-display-function self (first list) - (list-item description)) - (lambda (desc item component) - (<:tr - (do-attributes (a desc) - (<:th (<:as-html (label a))))) - - (dolist* (obj list) - (<:tr - (do-attributes (a desc) - (<:td (display-attribute a obj))))))))))) |# - - - - - - - - - - - - - diff --git a/src/standard-occurence-class.lisp b/src/standard-occurence-class.lisp deleted file mode 100644 index 6c46d66..0000000 --- a/src/standard-occurence-class.lisp +++ /dev/null @@ -1,4 +0,0 @@ -(in-package :lisp-on-lines) - -(defclass standard-occurence-class (standard-class) - ) \ No newline at end of file diff --git a/src/standard-occurence.lisp b/src/standard-occurence.lisp deleted file mode 100644 index bb2f686..0000000 --- a/src/standard-occurence.lisp +++ /dev/null @@ -1,24 +0,0 @@ -(in-package :lisp-on-lines) - -;;;; STRINGS - -(find-or-create-occurence 'string) - -(defmethod find-occurence ((string string)) - (find-occurence 'string)) - -(set-attribute 'string 'identity `(string :getter ,#'(lambda (x) - (identity x)))) -(set-default-attributes 'string) - -;;;; LISTS - -(find-or-create-occurence 'list) - -(defmethod find-occurence ((list list)) - (find-occurence 'list)) - -(set-attribute 'list 'identity `(string :getter ,#'(lambda (x) - (identity x)))) -(set-default-attributes 'string) - diff --git a/src/standard-wrappers.lisp b/src/standard-wrappers.lisp deleted file mode 100644 index f54f1e6..0000000 --- a/src/standard-wrappers.lisp +++ /dev/null @@ -1,127 +0,0 @@ -(in-package :lisp-on-lines) - -;;;;; Wrap a display in "back buttons" -(deflayer wrap-back-buttons) - -(defvar *back-buttons-wrapped-p* nil) - -(defdisplay - :in-layer wrap-back-buttons :around - (description object) - (if *back-buttons-wrapped-p* - (call-next-method) - (let ((*back-buttons-wrapped-p* t)) - - (