From: Kevin M. Rosenberg Date: Sun, 18 Sep 2005 00:13:11 +0000 (+0000) Subject: r10742: 17 Sep 2005 Kevin Rosenberg X-Git-Tag: v3.8.6~119 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=fc58e4fb7d908985389c86adf57ddee6c1dde5d2 r10742: 17 Sep 2005 Kevin Rosenberg * Version 3.3.0 * sql/time.lisp: Apply patch from Alan Shields adding DATE type. * doc/ref-ooddl.xml: Documentation of new type * notes/add-type-hints.txt: New file from Alan Shields * sql/fddl.lisp: Add owner keyword to drop-table as suggested by Francis Leboutte * db-postgresql-socket/postgresql-socket-sql.lisp: Fix database-probe as noted by Francis Leboutte. Similar fix applied to db-mysql and db-postgresql. * sql/expressions.lisp: Allow string table names for output as contributed by Francis Leboutte. * examples/clsql-tutorial.lisp: Support :postgresql-socket as noted by Francis Leboutte --- diff --git a/ChangeLog b/ChangeLog index 1948aea..3518c6e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +17 Sep 2005 Kevin Rosenberg + * Version 3.3.0 + * sql/time.lisp: Apply patch from Alan Shields adding DATE type. + * doc/ref-ooddl.xml: Documentation of new type + * notes/add-type-hints.txt: New file from Alan Shields + * sql/fddl.lisp: Add owner keyword to drop-table as suggested + by Francis Leboutte + * db-postgresql-socket/postgresql-socket-sql.lisp: Fix database-probe + as noted by Francis Leboutte. Similar fix applied to db-mysql and + db-postgresql. + * sql/expressions.lisp: Allow string table names for output as + contributed by Francis Leboutte. + * examples/clsql-tutorial.lisp: Support :postgresql-socket as noted + by Francis Leboutte + 08 Sep 2005 Kevin Rosenberg * Version 3.2.4 * doc/into.xml: Change download from ftp to http protocol diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index ce81abe..8ead9d7 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -458,7 +458,7 @@ (defmethod database-probe (connection-spec (type (eql :mysql))) (when (find (second connection-spec) (database-list connection-spec type) - :key #'car :test #'string-equal) + :test #'string-equal) t)) (defmethod database-list (connection-spec (type (eql :mysql))) diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 46e82ce..7a56931 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -342,7 +342,7 @@ doesn't depend on UFFI." (defmethod database-probe (connection-spec (type (eql :postgresql-socket))) (when (find (second connection-spec) (database-list connection-spec type) - :key #'car :test #'string-equal) + :test #'string-equal) t)) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 6a8c7c8..9b4e250 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -412,7 +412,7 @@ (defmethod database-probe (connection-spec (type (eql :postgresql))) (when (find (second connection-spec) (database-list connection-spec type) - :key #'car :test #'string-equal) + :test #'string-equal) t)) diff --git a/debian/changelog b/debian/changelog index 073f7a8..7eec7c4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (3.2.5-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Sat, 17 Sep 2005 16:57:27 -0600 + cl-sql (3.2.4-1) unstable; urgency=low * New upstream diff --git a/doc/html.tar.gz b/doc/html.tar.gz index 7e4ee52..219d527 100644 Binary files a/doc/html.tar.gz and b/doc/html.tar.gz differ diff --git a/doc/ref-ooddl.xml b/doc/ref-ooddl.xml index 5c51f4b..b6873c8 100644 --- a/doc/ref-ooddl.xml +++ b/doc/ref-ooddl.xml @@ -469,6 +469,12 @@ provides a number of time manipulation functions to support objects of type wall-time. + + date - a slot which stores the + date (without any time of day resolution) in a + column. &clsql; provides a number of time + manipulation functions that operate on date values. + duration - stores a duration structure. &clsql; provides diff --git a/examples/clsql-tutorial.lisp b/examples/clsql-tutorial.lisp index 118ea20..265ae6d 100644 --- a/examples/clsql-tutorial.lisp +++ b/examples/clsql-tutorial.lisp @@ -4,7 +4,7 @@ ;; You must set these variables to appropriate values. (defvar *tutorial-database-type* nil - "Possible values are :postgresql,:postgresql-socket :mysql, + "Possible values are :postgresql :postgresql-socket, :mysql, :oracle, :odbc, :aodbc or :sqlite") (defvar *tutorial-database-name* "clsqltut" "The name of the database we will work in.") @@ -86,7 +86,7 @@ ;; Connect to the database (see the CLSQL documentation for vendor ;; specific connection specs). (case *tutorial-database-type* - ((:mysql :postgresql) + ((:mysql :postgresql :postgresql-socket) (clsql:connect `(,*tutorial-database-server* ,*tutorial-database-name* ,*tutorial-database-user* diff --git a/notes/add-type-hints.txt b/notes/add-type-hints.txt new file mode 100644 index 0000000..1f129b5 --- /dev/null +++ b/notes/add-type-hints.txt @@ -0,0 +1,32 @@ +How to Add a Type to CL-SQL (Alan Shields - Alan-Shields@omrf.ouhsc.edu) + +I made this small guide to eliminate some of the work I went through. +I hope it is useful and/or correct. + +To add a type to CL-SQL, the following methods need to be +declared. + + +"sql/expressions.lisp" +(defmethod database-output-sql (self database)) + +SELF is specialized for the lisp type, such as (self integer). + +"sql/oodml.lisp" +(defmethod database-get-type-specifier (type args database db-type)) + +TYPE is a symbol for the clsql type, such as (type (eql 'integer)). +Note that DB-TYPE is the database type, not DATABASE. + +"sql/oodml.lisp" +(defmethod read-sql-value (val type database db-type)) + +TYPE is a symbol for the clsql type, as above. +Same warnings as above. + + +If your type is stored in different ways in different sql servers, you'll need +to specialize these methods. + +These specializations usually go in either db-/-objects.lisp or +sql/generic-.lisp. diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 2098cf3..e62d593 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -198,14 +198,20 @@ `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) (defmethod output-sql ((expr sql-ident-table) database) - (with-slots (name alias) - expr - (if (null alias) - (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*) - (progn - (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*) - (write-char #\Space *sql-stream*) - (format *sql-stream* "~s" alias)))) + (with-slots (name alias) expr + (let ((namestr (if (symbolp name) + (symbol-name name) + name))) + (if (null alias) + (write-string + (sql-escape (convert-to-db-default-case namestr database)) + *sql-stream*) + (progn + (write-string + (sql-escape (convert-to-db-default-case namestr database)) + *sql-stream*) + (write-char #\Space *sql-stream*) + (format *sql-stream* "~s" alias))))) t) (defmethod output-sql-hash-key ((expr sql-ident-table) database) @@ -903,6 +909,10 @@ uninclusive, and the args from that keyword to the end." (declare (ignore database)) (db-timestring self)) +(defmethod database-output-sql ((self date) database) + (declare (ignore database)) + (db-datestring self)) + (defmethod database-output-sql ((self duration) database) (declare (ignore database)) (format nil "'~a'" (duration-timestring self))) diff --git a/sql/fddl.lisp b/sql/fddl.lisp index c8d4d1f..51f8f05 100644 --- a/sql/fddl.lisp +++ b/sql/fddl.lisp @@ -79,7 +79,8 @@ supports transactions." (execute-command stmt :database database))) (defun drop-table (name &key (if-does-not-exist :error) - (database *default-database*)) + (database *default-database*) + (owner nil)) "Drops the table called NAME from DATABASE which defaults to *DEFAULT-DATABASE*. If the table does not exist and IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas @@ -87,7 +88,8 @@ an error is signalled if IF-DOES-NOT-EXIST is :error." (let ((table-name (database-identifier name database))) (ecase if-does-not-exist (:ignore - (unless (table-exists-p table-name :database database) + (unless (table-exists-p table-name :database database + :owner owner) (return-from drop-table nil))) (:error t)) diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 3ec173a..09d879a 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -129,20 +129,24 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." ;; Drop the tables which store the given view class ;; -(defun drop-view-from-class (view-class-name &key (database *default-database*)) +(defun drop-view-from-class (view-class-name &key (database *default-database*) + (owner nil)) "Removes a table defined by the View Class VIEW-CLASS-NAME from DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%uninstall-class tclass)) + (%uninstall-class tclass :owner owner)) (error "Class ~s not found." view-class-name))) (values)) -(defun %uninstall-class (self &key (database *default-database*)) +(defun %uninstall-class (self &key + (database *default-database*) + (owner nil)) (drop-table (sql-expression :table (view-table self)) :if-does-not-exist :ignore - :database database) + :database database + :owner owner) (setf (database-view-classes database) (remove self (database-view-classes database)))) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 85730dc..187694d 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -381,6 +381,10 @@ (declare (ignore args database db-type)) "TIMESTAMP") +(defmethod database-get-type-specifier ((type (eql 'date)) args database db-type) + (declare (ignore args database db-type)) + "DATE") + (defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type) (declare (ignore database args db-type)) "VARCHAR") @@ -584,6 +588,11 @@ (unless (eq 'NULL val) (parse-timestring val))) +(defmethod read-sql-value (val (type (eql 'date)) database db-type) + (declare (ignore database db-type)) + (unless (eq 'NULL val) + (parse-datestring val))) + (defmethod read-sql-value (val (type (eql 'duration)) database db-type) (declare (ignore database db-type)) (unless (or (eq 'NULL val) diff --git a/sql/package.lisp b/sql/package.lisp index 242a044..ad785ec 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -451,8 +451,10 @@ #:current-year #:day-duration #:db-timestring + #:db-datestring #:decode-duration #:decode-time + #:decode-date #:duration #:duration+ #:duration< @@ -471,7 +473,9 @@ #:extract-roman #:format-duration #:format-time + #:format-date #:get-time + #:get-date #:utime->time #:interval-clear #:interval-contained @@ -486,11 +490,13 @@ #:make-duration #:make-interval #:make-time + #:make-date #:merged-time #:midnight #:month-name #:parse-date-time #:parse-timestring + #:parse-datestring #:parse-yearstring #:print-date #:roll @@ -516,6 +522,23 @@ #:time= #:time> #:time>= + #:date + #:date+ + #:date- + #:date-difference + #:date-compare + #:date-dow + #:date-element + #:date-max + #:date-min + #:date-mjd + #:date-p + #:date-ymd + #:date< + #:date<= + #:date= + #:date> + #:date>= #:timezone #:universal-time #:wall-time diff --git a/sql/time.lisp b/sql/time.lisp index c767018..0f8d5e2 100644 --- a/sql/time.lisp +++ b/sql/time.lisp @@ -84,6 +84,14 @@ (format stream "#" (format-duration nil duration :precision :second))) +(defstruct (date (:constructor %make-date) + (:print-function %print-date)) + (mjd 0 :type fixnum)) + +(defun %print-date (date stream depth) + (declare (ignore depth)) + (format stream "#" (format-date nil date))) + );eval-when (defun duration-timestring (duration) @@ -107,6 +115,11 @@ (floor sec (* 60 60 24)) (%make-wall-time :mjd (+ mjd day-add) :second raw-sec :usec usec)))) +(defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0) + (second 0) (usec 0) (offset 0)) + (time->date (make-time :year year :month month :day day :hour hour + :minute minute :second second :usec usec :offset offset))) + (defun copy-time (time) (%make-wall-time :mjd (time-mjd time) :second (time-second time))) @@ -118,10 +131,22 @@ (make-time :year year :month mon :day day :hour hour :minute minute :second second))) +(defun date->time (date) + "Returns a walltime for the given date" + (%make-wall-time :mjd (date-mjd date))) + +(defun time->date (time) + "Returns a date for the given wall time (obvious loss in resolution)" + (%make-date :mjd (time-mjd time))) + (defun get-time () "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)" (utime->time (get-universal-time))) +(defun get-date () + "Returns a date for today" + (time->date (get-time))) + (defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0) (second 0) (usec 0)) (multiple-value-bind (second-add usec-1000000) @@ -167,6 +192,18 @@ (time-hms time) (values (time-usec time) second minute hour day month year (mod (+ (time-mjd time) 3) 7))))) +(defun date-ymd (date) + (time-ymd (date->time date))) + +(defun date-dow (date) + (time-dow (date->time date))) + +(defun decode-date (date) + "returns the decoded date as multiple values: day month year integer day-of-week" + (multiple-value-bind (year month day) + (time-ymd (date->time date)) + (values day month year (date-dow date)))) + ;; duration specific (defun duration-reduce (duration precision &optional round) (ecase precision @@ -342,6 +379,43 @@ :less-than :greater-than)))) +; now the same for dates +(eval-when (:compile-toplevel :load-toplevel) +(defun replace-string (string1 search-string replace-string &key (test #'string=)) + "Search within string1 for search-string, replace with replace-string, non-destructively." + (let ((replace-string-length (length replace-string)) + (search-string-length (length search-string))) + (labels ((sub-replace-string (current-string position) + (let ((found-position (search search-string current-string :test test :start2 position))) + (if (null found-position) + current-string + (sub-replace-string (concatenate 'string + (subseq current-string 0 found-position) + replace-string + (subseq current-string (+ found-position search-string-length))) + (+ position replace-string-length)))))) + (sub-replace-string string1 0)))) +);eval-when + +(defmacro wrap-time-for-date (time-func &key (result-func)) + (let ((date-func (intern (replace-string (symbol-name time-func) "TIME" "DATE")))) + `(defun ,date-func (number &rest more-numbers) + (let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers))))) + ,(if result-func + `(funcall #',result-func result) + 'result))))) + +(wrap-time-for-date time=) +(wrap-time-for-date time/=) +(wrap-time-for-date time<) +(wrap-time-for-date time>) +(wrap-time-for-date time<=) +(wrap-time-for-date time>=) +(wrap-time-for-date time-max :result-func time->date) +(wrap-time-for-date time-min :result-func time->date) + +(defun date-compare (date-a date-b) + (time-compare (date->time date-a) (date->time date-b))) ;; ------------------------------------------------------------ ;; Formatting and output @@ -398,6 +472,11 @@ (inscribe-base-10 output 17 2 second) (format nil "~a,~d" output usec))))) +(defun db-datestring (date) + (db-timestring (date->time date))) +(defun iso-datestring (date) + (iso-timestring (date->time date))) + ;; ------------------------------------------------------------ ;; Intervals @@ -674,6 +753,12 @@ begins at time. If no changes are made, returns nil." :destructive t)) new-time)) +(defun date+ (date &rest durations) + "Add each DURATION to DATE, returning a new date value. +Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing +it as separate calculations will not, as the time is chopped to a date before being returned." + (time->date (apply #'time+ (cons (date->time date) durations)))) + (defun time- (time &rest durations) "Subtract each DURATION from TIME, returning a new wall-time value." (let ((new-time (copy-time time))) @@ -689,6 +774,12 @@ begins at time. If no changes are made, returns nil." :destructive t)) new-time)) +(defun date- (date &rest durations) + "Subtract each DURATION to DATE, returning a new date value. +Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing +it as separate calculations will not, as the time is chopped to a date before being returned." + (time->date (apply #'time- (cons (date->time date) durations)))) + (defun time-difference (time1 time2) "Returns a DURATION representing the difference between TIME1 and TIME2." @@ -710,6 +801,21 @@ TIME2." (do-diff time1 time2) (do-diff time2 time1)))) +(defun date-difference (date1 date2) + "Returns a DURATION representing the difference between TIME1 and +TIME2." + (time-difference (date->time date1) (date->time date2))) + +(defun format-date (stream date &key format + (date-separator "-") + (internal-separator " ")) + "produces on stream the datestring corresponding to the date +with the given options" + (format-time stream (date->time date) + :format format + :date-separator date-separator + :internal-separator internal-separator)) + (defun format-time (stream time &key format (date-separator "-") (time-separator ":") @@ -881,6 +987,9 @@ with the given options" (:year year)))) +(defun date-element (date element) + (time-element (date->time date) element)) + (defun format-duration (stream duration &key (precision :minute)) (let ((second (duration-second duration)) (minute (duration-minute duration)) @@ -1072,6 +1181,14 @@ formatted date string." (parse-iso-8601-duration string) (parse-iso-8601-time string)))) +(defun parse-datestring (datestring &key (start 0) end junk-allowed) + "parse a ISO 8601 timestring and return the corresponding date. +Will throw a hissy fit if the date string is a duration. Will ignore any precision beyond day (hour/min/sec/usec)." + (let ((parsed-value (parse-timestring datestring :start start :end end :junk-allowed junk-allowed))) + (ecase (type-of parsed-value) + (wall-time (%make-date :mjd (time-mjd parsed-value)))))) + + (defvar *iso-8601-duration-delimiters* '((#\D . :days) (#\H . :hours)