/ test /
/test/build-testbed.lisp
  1 ;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
  2 ;;;
  3 ;;; Copyright (c) 2006 by the authors.
  4 ;;;
  5 ;;; See LICENCE for details.
  6 
  7 (in-package :cl-user)
  8 
  9 (load (merge-pathnames "workspace/environment/environment.lisp" (user-homedir-pathname)))
 10 
 11 (push (merge-pathnames "workspace/_slime-cvs" (user-homedir-pathname)) asdf:*central-registry*)
 12 (asdf:oos 'asdf:load-op :swank)
 13 (asdf:oos 'asdf:load-op :cl-rdbms)
 14 
 15 (defvar *file-name* "perec-testbed")
 16 
 17 (defun create-swank-server ()
 18   (with-simple-restart (continue "Ok, go on without a Swank server")
 19     (swank:create-server :style nil :dont-close t :coding-system "utf-8-unix")))
 20 
 21 (defun build-image ()
 22   (load (merge-pathnames "workspace/environment/swank-sprof.lisp" (user-homedir-pathname)))
 23 
 24   (when (ignore-errors
 25           (fdefinition (read-from-string "(setf swank:swank-print-right-margin)")))
 26     (eval (read-from-string "(setf (swank:swank-print-right-margin) 150
 27                                    swank:*globally-redirect-io* t)")))
 28 
 29   (asdf:oos 'asdf:load-op :cl-perec-test.postgresql)
 30 
 31   (if (probe-file *file-name*)
 32       (delete-file *file-name*))
 33 
 34   (sb-ext::save-lisp-and-die
 35    *file-name*
 36    :executable t
 37    :toplevel (lambda ()
 38                (with-simple-restart (quit "Ok, give up, it failed this time...")
 39                  (let ((arguments (subseq sb-ext:*posix-argv*
 40                                           ;; checking for "--end-toplevel-options" shouldn't be necessary; SBCL bug.
 41                                           (1+ (or (position "--end-toplevel-options" sb-ext:*posix-argv*
 42                                                             :test #'string=)
 43                                                   0)))))
 44                    (flet ((get-argument (name &optional has-value?)
 45                             "Removes and returns the argument value when found or the position if this argument has no value."
 46                             (let ((position (position name arguments :test #'string=)))
 47                               (if position
 48                                   (if has-value?
 49                                       (progn
 50                                         (unless (> (length arguments)
 51                                                    (1+ position))
 52                                           (error "~S requires an argument" name))
 53                                         (prog1 (elt arguments (1+ position))
 54                                           (setf (elt arguments position) nil)
 55                                           (setf (elt arguments (1+ position)) nil)))
 56                                       (progn
 57                                         (setf (elt arguments position) nil)
 58                                         t)))))
 59                           (fail (&optional message &rest args)
 60                             (when message
 61                               (apply #'format *error-output* message args))
 62                             (sb-ext:quit :unix-status 1)))
 63                      (let* ((connection-specification (rdbms::connection-specification-of rdbms::*database*))
 64                             (host (or (get-argument "--host" t)
 65                                       (getf connection-specification :host)))
 66                             (port (or (let ((port (get-argument "--port" t)))
 67                                         (when port
 68                                           (parse-integer port)))
 69                                       (getf connection-specification :port)
 70                                       5432))
 71                             (database (or (get-argument "--database" t)
 72                                           (getf connection-specification :database)))
 73                             (user-name (or (get-argument "--user-name" t)
 74                                            (getf connection-specification :user-name)))
 75                             (password (or (get-argument "--password" t)
 76                                           (getf connection-specification :password))))
 77                        (setf (rdbms::connection-specification-of rdbms::*database*)
 78                              `(:host ,host :port ,port :database ,database :user-name ,user-name :password ,password)))))
 79                  (format *debug-io*
 80 "Testbed Usage:
 81    perec-testbed [--host <host>] [--port <port>] [--database <database>] [--user-name <user-name>] [--password <password>]
 82 
 83 Testbed default parameters (port is set to PostgreSQL default port):
 84    host: localhost
 85    port: 5432
 86    database: perec-test
 87    user-name: perec-test
 88    password: test123
 89 
 90 To install postgresql:
 91    sudo apt-get install postgresql
 92 
 93 To setup the test database:
 94    sudo su - postgres
 95    createdb perec-test
 96    createuser -d -r -l -P perec-test
 97    ;; type in 'test123' for password
 98 
 99 In emacs do: 
100    ;; the swank server uses utf-8, so
101    M-S-: (setq slime-net-coding-system 'utf-8-unix)
102    M-x slime-connect
103    ;; 'localhost' and default port 4005 should be ok
104 
105 To test cl-perec:
106    (in-package :cl-perec-test) ; this is the default when you connect
107    (retest) ; should print a lot of dots and stuff and takes a while
108 
109 To play around:
110    ;; to turn on logging of SQL statements in SLIME
111    (start-sql-recording)
112    ;; to create a persistent class
113    (defpclass* test ()
114      ((name :type (text 20))
115       (age :type integer-32)
116       (flag :type boolean)))
117    ;; to make an instance 
118    ;; this should automatically create/update the tables needed for the class
119    ;; note: if you have run the test suite, this might execute several queries
120    ;;       to check all persistent classes present in your lisp image
121    (defvar p
122      (with-transaction
123         (make-instance 'test :name \"Hello\" :age 42 :flag t)))
124    ;; to reuse the instance in another transaction
125    (with-transaction
126      (with-revived-instance p
127        (describe p)))
128    ;; to query instances of the class just defined
129    (with-transaction
130      (select (instance)
131        (from (instance test))
132        (where (and (equal (name-of instance) \"Hello\")
133                    (< (age-of instance) 100)))
134        (order-by :descending (age-of instance))))
135    ;; queries are polimorph by default (this should actually return all persistent instances)
136    ;; use macroexpand to see how it compiles down to straight SQL
137    (with-transaction
138      (select (:compile-at-macroexpand t) (instance)
139        (from (instance persistent-object))))
140    ;; see the tests in the repository at http://common-lisp.net/cgi-bin/darcsweb/darcsweb.cgi?r=cl-perec-cl-perec;a=tree;f=/test
141    ;; see a somewhat more complicated example at: http://common-lisp.net/project/cl-perec/shop.html
142    ;; and also check the showcase on the website at http://common-lisp.net/project/cl-perec/showcase.html
143 
144 To read more about the project:
145    http://common-lisp.net/project/cl-perec
146 
147 There is some form of documentation at:)
148    http://common-lisp.net/project/cl-perec/documentation/index.html
149 
150 Suggestions, bug reports are welcomed at:
151    cl-perec-devel@common-lisp.net
152 
153 The current PostgreSQL connection specification is:
154    ~S
155 
156 To exit press Control-C.
157 " (rdbms::connection-specification-of rdbms::*database*))
158                  (labels ((signal-handler (signal code scp)
159                             (declare (ignore signal code scp))
160                             (format *debug-io* "SIGTERM/SIGINT was received, exiting~&")
161                             (force-output *debug-io*)
162                             (sb-ext:quit :recklessly-p t :unix-status -1)))
163                    (sb-sys:enable-interrupt sb-unix:sigterm #'signal-handler)
164                    (sb-sys:enable-interrupt sb-unix:sigint #'signal-handler)
165                    (create-swank-server)))
166                0)))
167 
168 (build-image)