+17 Sep 2005 Kevin Rosenberg <kevin@rosenberg.net>
+ * 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 <kevin@rosenberg.net>
* Version 3.2.4
* doc/into.xml: Change download from ftp to http protocol
(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)))
(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))
(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))
+cl-sql (3.2.5-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Sat, 17 Sep 2005 16:57:27 -0600
+
cl-sql (3.2.4-1) unstable; urgency=low
* New upstream
provides a number of time manipulation functions to
support objects of type <type>wall-time</type>.
</member>
+ <member>
+ <parameter>date</parameter> - 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.
+ </member>
<member>
<parameter>duration</parameter> - stores a
<type>duration</type> structure. &clsql; provides
;; 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.")
;; 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*
--- /dev/null
+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-<database>/<database>-objects.lisp or
+sql/generic-<database>.lisp.
`(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)
(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)))
(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
(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))
;; 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))))
(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")
(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)
#:current-year
#:day-duration
#:db-timestring
+ #:db-datestring
#:decode-duration
#:decode-time
+ #:decode-date
#:duration
#:duration+
#:duration<
#:extract-roman
#:format-duration
#:format-time
+ #:format-date
#:get-time
+ #:get-date
#:utime->time
#:interval-clear
#:interval-contained
#: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
#: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
(format stream "#<DURATION: ~a>"
(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 "#<DATE: ~a>" (format-date nil date)))
+
);eval-when
(defun duration-timestring (duration)
(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)))
(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)
(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
: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
(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
: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)))
: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."
(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 ":")
(: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))
(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)
projects / clsql.git / commitdiff