Permalink
Browse files

initial commit of clsql-helper lib as shaped from our internal mudball

  • Loading branch information...
bobbysmith007 committed Jun 1, 2011
1 parent 1cd0ef5 commit d907752377f2e2155e8f52941f9e8b89340b82df
Showing with 967 additions and 0 deletions.
  1. +20 −0 LICENSE
  2. +16 −0 README.mediawiki
  3. +37 −0 clsql-helper-slot-coercer.asd
  4. +72 −0 clsql-helper.asd
  5. +223 −0 clsql.lisp
  6. +305 −0 date.lisp
  7. +121 −0 mssql-db-object.lisp
  8. +78 −0 postgres.lisp
  9. +43 −0 set-slot-value-using-class.lisp
  10. +52 −0 tests/clsql.lisp
View
20 LICENSE
@@ -0,0 +1,20 @@
+;; Copyright (c) 2011 Russ Tyndall , Acceleration.net http://www.acceleration.net
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
View
@@ -0,0 +1,16 @@
+= CLSQL-Helper =
+
+A library providing a clutch of utilities to make working with clsql easier
+particularly in the department of dates
+
+* single interface functions that make a best effort to read/write a date in (m)any formats
+* simplified sql-expression interface
+** clsql-or(s), clsql-and(s) and clsql-exp which make building where expressions simpler
+* simplified query
+* clsql-mop help, find the primary keys of an object and query / test equality with these
+* A basic sql pretty printer, so that the code printed from
+* log-database-query , which uses the clsql printer and allows easily recording queries
+executing on a given connection
+* coersion to/from clsql data types an value
+
+
@@ -0,0 +1,37 @@
+;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package :clsql-helper.system)
+ (defpackage :clsql-helper.system
+ (:use :common-lisp :asdf))))
+
+(in-package clsql-helper.system)
+
+(defsystem :clsql-helper-slot-coercer
+ :description "A library providing a single overwritde of (setf slot-value-using-class)
+ so that obvious type coercions occur when setting slots on clsql:standard-db-objects"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:file "set-slot-value-using-class"))
+ :depends-on (:clsql-helper :closer-mop))
+
+;; Copyright (c) 2011 Russ Tyndall , Acceleration.net http://www.acceleration.net
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
View
@@ -0,0 +1,72 @@
+;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package :clsql-helper.system)
+ (defpackage :clsql-helper.system
+ (:use :common-lisp :asdf))))
+
+(in-package clsql-helper.system)
+
+(defsystem :clsql-helper
+ :description "A library providing a clutch of utilities to make working with clsql easier"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:file "date")
+ (:file "clsql"))
+ :depends-on (:iterate :clsql :closer-mop :cl-ppcre
+ :cl-interpol :symbol-munger :alexandria))
+
+#+ASDF-SYSTEM-CONNECTIONS
+(asdf:defsystem-connection adwcodebase-clsql-postgres-connection
+ :description "the part of adwcode base dedicated to postgresql"
+ :requires (:adwcodebase :clsql-postgresql-socket :cl-ppcre)
+ :components ((:module :src
+ :components ((:file "postgres")))))
+
+#+ASDF-SYSTEM-CONNECTIONS
+(asdf:defsystem-connection adwcodebase-clsql-postgres3-connection
+ :description "the part of adwcode base dedicated to postgresql"
+ :requires (:adwcodebase :clsql-postgresql-socket3 :cl-ppcre)
+ :components ((:module :src
+ :components ((:file "postgres")))))
+
+#+ASDF-SYSTEM-CONNECTIONS
+(asdf:defsystem-connection adwcodebase-clsql-odbc-connection
+ :description "the part of adwcode base dedicated to postgresql"
+ :requires (:adwcodebase :clsql-odbc )
+ :components ((:module :src
+ :components ((:file "mssql-db-object")))))
+
+(defsystem :clsql-helper-test
+ :description "Tests for a library providing a clutch of utilities to make
+ working with clsql easier"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:module :tests
+ :serial t
+ :components ((:file "clsql"))))
+ :depends-on (:clsql-helper :lisp-unit))
+
+(defmethod asdf:perform ((o asdf:test-op) (c (eql (find-system :clsql-helper))))
+ (asdf:oos 'asdf:load-op :clsql-helper-test))
+
+;; Copyright (c) 2011 Russ Tyndall , Acceleration.net http://www.acceleration.net
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
View
@@ -0,0 +1,223 @@
+(in-package :clsql-helper)
+(cl-interpol:enable-interpol-syntax)
+(clsql:file-enable-sql-reader-syntax)
+
+(defun clsql-exp (s)
+ (clsql-sys:sql-expression :string s))
+
+(defun db-string (s)
+ "escapes and wraps in single quotes so that the string is ready
+ to be spliced into a query (eg: with cl-interpol)"
+ (let ((it (trim-and-nullify (typecase s
+ (string s)
+ (t (princ-to-string s))))))
+ (when it
+ #?"'${(clsql-sys:sql-escape-quotes it)}'")))
+
+(defun %clsql-subclauses (clauses)
+ (iter (for c in clauses)
+ (when c
+ (collect
+ (typecase c
+ (string (clsql-exp c))
+ (T c))))))
+
+(defun clsql-ands (clauses)
+ (let ((ex (%clsql-subclauses clauses)))
+ (when ex
+ (case (length ex)
+ (1 ex)
+ (t (apply #'clsql-sys:sql-and ex))))))
+
+(defun clsql-and (&rest clauses)
+ "returns a CLSQL:SQL-AND for all non-nil clauses, no nil if there are no non-nil clauses"
+ (clsql-ands clauses))
+
+(defun clsql-ors (clauses)
+ "returns a CLSQL:SQL-AND for all non-nil clauses, no nil if there are no non-nil clauses"
+ (let ((ex (%clsql-subclauses clauses)))
+ (when ex
+ (case (length ex)
+ (1 ex)
+ (t (apply #'clsql-sys:sql-or ex))))))
+
+(defun clsql-or (&rest clauses)
+ "returns a CLSQL:SQL-AND for all non-nil clauses, no nil if there are no non-nil clauses"
+ (clsql-ors clauses))
+
+(defmethod by-col (class column colvalue)
+ "fetchs the first row for the given class by id"
+ (setf column (typecase column
+ (symbol (make-instance 'clsql-sys:sql-ident
+ :name (symbol-munger:lisp->underscores
+ column)))
+ (string (make-instance 'clsql-sys:sql-ident :name column ))
+ (t column)))
+ (first (clsql:select class
+ :where [= column colvalue]
+ :flatp T)))
+
+(defgeneric by-id (class id &optional colname)
+ (:documentation "Fetchs the first row for the given class by id")
+ (:method (class id &optional (colname [id]))
+ "direct implementation of by-id, (select class). fetchs the first row for the given class by id"
+ (by-col class colname id)))
+
+(defun primary-key-slot-names (obj)
+ (mapcar #'c2mop:slot-definition-name
+ (clsql-sys::key-slots
+ (typecase obj
+ (symbol (find-class obj))
+ (clsql-sys::standard-db-class obj)
+ (clsql-sys:standard-db-object (class-of obj))))))
+
+(defun primary-key-where-clauses ( obj )
+ "Generates a where clause based on all of the primary keys of the object
+ ex: pk1 = val1 and pk2 = val2 ...
+ "
+ (let ((keys (primary-key-slot-names obj)))
+ (values (clsql-ands
+ (iter (for key in keys)
+ (for kfn = (handler-case (fdefinition key)
+ (undefined-function ())))
+ (for kfn-v = (and (compute-applicable-methods kfn (list obj))
+ (funcall kfn obj)))
+ (for v = (or kfn-v (slot-value obj key)))
+ (collecting [= key v])))
+ keys)))
+
+(defmethod new-object-p (obj)
+ "Checks that primary keys have values and that the object
+ with those primary key values exists in the database"
+ (let* ((class (class-of obj))
+ (keys (mapcar #'c2mop:slot-definition-name
+ (clsql-sys::key-slots class))))
+ (not (and (every (lambda (k) (slot-boundp obj k)) keys)
+ (every (lambda (k) (slot-value obj k)) keys)
+ (clsql:select (class-name class)
+ :flatp T
+ :where (primary-key-where-clauses obj))))))
+
+(defmethod db-eql (x y &key (test #'equalp))
+ "Tries to determine if the objects are of the same type and have the same primary key values
+ Many times objects which pass new-objectp are db-eql ,but once saved are no longer db-eql (due to using serial pkey)"
+ (or (and (null x) (null y))
+ (and
+ (eql (class-of x) (class-of y))
+ ;; make sure all the keys have the same values
+ (iter (for key-def in (clsql-sys::key-slots (class-of x)))
+ (for key = (c2mop:slot-definition-name key-def))
+ (for s1 = (slot-boundp x key))
+ (for s2 = (slot-boundp y key))
+ ;;true when either both slots are unbound or both slots have the same value
+ (always (or (not (or s1 s2))
+ (and s1 s2
+ (funcall test (slot-value x key)
+ (slot-value y key)))))))))
+
+(defun pretty-print-sql (sql-command)
+ (when (and sql-command (stringp sql-command))
+ (let ((paren-cnt 0)
+ wrote-a-newline
+ ;; A scanner for top level keywords, secondary keywords
+ ;; and sub expressions (as by parens)
+ (scanner (load-time-value
+ (cl-ppcre:create-scanner
+ #?r"(?:\s+(?:(select|insert|update|delete|exec)|(from|where|order|group|left join|full join|outer join|join|values|on|limit))\s+)|(\()|(\))|(\n)"
+ :case-insensitive-mode T))))
+ (flet ((spaces (&optional (extra-n 1))
+ "Creates a string with the correct indent in it"
+ (make-string (+ extra-n (* 2 paren-cnt))
+ :initial-element #\space )))
+ (cl-ppcre:regex-replace-all
+ scanner sql-command
+ (lambda (m g1 g2 g3 g4 g5)
+ (declare (ignore m))
+ (let ((wnl wrote-a-newline))
+ (setf wrote-a-newline nil)
+ (cond
+ ((or g1 g2) ;; we got a sql keyword, or subkeyword
+ ;; if we already wrote a new line, we dont need another
+ (let ((newline (if wnl "" #\newline)))
+ #?"${newline}${ (spaces (if g1 1 3)) }${ (or g1 g2) } "))
+ (g3 (incf paren-cnt) g3) ;; got an open paren
+ (g4 ;; close paren
+ (when (> paren-cnt 0) (decf paren-cnt))
+ ;; if this paren is alone on a line indent it
+ #?"${ (if wnl (spaces) "") }${g4}" )
+ ;; we wrote a newline so we may not need to write another
+ (g5 (setf wrote-a-newline T) g5)
+ (T
+ "" ))))
+ :simple-calls T)))))
+
+(defmacro log-database-command ((log-fn-name &optional (database 'clsql:*default-database*)) &body body)
+ "MUST BE Inside a database connection, creates a lexical scope in which all sql commands
+ executed on this connection are logged to a specific logger
+
+ tries to format such that it will be readable in the log
+
+ log-fn-name is a function/macro name that will be called with a string/array as
+ (log-fn-name stuff)
+ "
+ (alexandria:with-unique-names (str record results)
+ `(let* (,results
+ (,record (make-array 60 :fill-pointer 0 :adjustable T :element-type 'base-char)))
+ (with-output-to-string (,str ,record)
+ (setf (clsql-sys:command-recording-stream ,database)
+ (make-broadcast-stream ,str)
+ ,results
+ (unwind-protect
+ (progn ,@body)
+ (setf (clsql-sys:command-recording-stream ,database) nil)
+ (setf ,record (pretty-print-sql ,record))
+ (,log-fn-name ,record))))
+ ,results)))
+
+(defun coerce-to-clsql-table-name (table)
+ "based on what is passed in, tries to figure out what the table name is"
+ (let ((cls (ignore-errors (find-class table))))
+ (typecase table
+ (symbol (if cls
+ (clsql-sys::view-table cls)
+ (symbol-munger:lisp->underscores table :capitalize nil)))
+ (clsql-sys::standard-db-class (clsql-sys::view-table table))
+ (clsql-sys::standard-db-object
+ (class-of (clsql-sys::view-table table)) )
+ (string table))))
+
+(defun coerce-value-to-db-type (val db-type)
+ (cond
+ ((subtypep db-type 'clsql-sys:varchar)
+ (trim-and-nullify (princ-to-string val)))
+ ((subtypep db-type 'integer)
+ (etypecase val
+ (string (parse-integer val))
+ (integer val)))
+ ((subtypep db-type 'double-float)
+ (etypecase val
+ (string (relaxed-parse-float val))
+ (number val)))
+ ((subtypep db-type 'number)
+ (etypecase val
+ (string (relaxed-parse-float val))
+ (number val)))
+ ((subtypep db-type 'clsql:date) (convert-to-clsql-date val))
+ ((subtypep db-type 'clsql:wall-time ) (convert-to-clsql-datetime val))
+ ((subtypep db-type 'boolean)
+ (typecase val
+ (string (not (null (member val (list "T" "true" "1" "y" "yes") :test #'string-equal))))
+ (T val)))
+ ((subtypep db-type 'clsql-sys:duration )
+ (error "NO COERCION IMPLEMENTED"))
+ (T (error "NO COERCION IMPLEMENTED"))))
+
+(defun format-value-for-database (d &optional stream)
+ "prints a correctly sql escaped value for postgres"
+ (etypecase d
+ (null (format stream "null"))
+ (string (format stream "'~a'" (clsql-sys:sql-escape-quotes d)))
+ (integer (format stream "~D" d))
+ (float (format stream "~F" d))
+ (clsql-sys:date (format stream "'~a'" (iso8601-datestamp d)))
+ (clsql-sys:wall-time (format stream "'~a'" (clsql-sys:iso-timestring d)))))
Oops, something went wrong.

0 comments on commit d907752

Please sign in to comment.