Last active
October 27, 2023 08:33
-
-
Save craftsmanship/eb49e6342104dbc3e7bb5fced5412669 to your computer and use it in GitHub Desktop.
RDBMS Client (DML only) for Microsoft SQL Server
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| (in-package :cl-user) | |
| (ql:quickload :mssql) | |
| (ql:quickload :cl-ppcre) | |
| (ql:quickload :uiop) | |
| (ql:quickload :string-case) | |
| (ql:quickload :iterate) | |
| (ql:quickload :anaphora) | |
| (ql:quickload :alexandria) | |
| (ql:quickload :local-time) | |
| (ql:quickload :cl-date-time-parser) | |
| (defpackage :mssql-client | |
| (:use :common-lisp) | |
| (:nicknames msclient) | |
| (:import-from :mssql | |
| :with-connection | |
| :with-transaction | |
| :query | |
| :*database* | |
| ::mssql-error) | |
| (:import-from :sb-ext | |
| :string-to-octets) | |
| (:import-from :ppcre | |
| :register-groups-bind | |
| :scan | |
| :split | |
| :regex-replace-all) | |
| (:import-from :uiop | |
| :file-exists-p | |
| :read-file-string) | |
| (:import-from :iterate | |
| :iter | |
| :for | |
| :collect) | |
| (:import-from :string-case | |
| :string-case) | |
| (:import-from :anaphora | |
| :aif | |
| :it) | |
| (:import-from :alexandria | |
| :make-keyword) | |
| (:import-from :local-time | |
| :universal-to-timestamp | |
| :format-timestring) | |
| (:import-from :cl-date-time-parser | |
| :parse-date-time) | |
| (:export :execute | |
| :pretty-print | |
| :create | |
| :execute-file | |
| :get-metadata | |
| :dump | |
| :columns | |
| :tables | |
| :skeleton-select | |
| :skeleton-insert | |
| :skeleton-update | |
| :skeleton-delete)) | |
| (in-package :mssql-client) | |
| (defparameter *default-database* "master") | |
| (defparameter *default-database-host* "localhost") | |
| (defparameter *default-user* "sa") | |
| (defparameter *default-password* "") | |
| (defparameter *datetime-parser* | |
| #'(lambda (str) | |
| (local-time:universal-to-timestamp (cl-date-time-parser:parse-date-time str)))) | |
| (defparameter *datetime-formatter* | |
| #'(lambda (timestamp) | |
| (format-timestring nil timestamp :format '("'" :year "-" :month "-" (:day 2) " " (:hour 2) ":" (:min 2) ":" (:sec 2) "." (:msec 3) "'")))) | |
| (defparameter *pretty-print-footer-threshold* 30) | |
| (defmacro with-gensyms (syms &body body) | |
| `(let ,(mapcar #'(lambda (s) | |
| `(,s (gensym))) | |
| syms) | |
| ,@body)) | |
| (defmacro handle-error (verbose &body body) | |
| (with-gensyms (c ret v) | |
| `(let (,ret (,v ,verbose)) | |
| (handler-case | |
| (if ,v | |
| (setq ,ret ,@body) | |
| (with-output-to-string (*standard-output*) ; mssql からの直接の標準出力は破棄 | |
| (setq ,ret ,@body))) | |
| (mssql-error (,c) | |
| (format t "SQL Server エラー.~%~a~%" ,c))) | |
| ,ret))) | |
| (defun select (sql &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| "ポートを指定したい場合は :host に <ホスト名 / IP アドレス>:<ポート> で指定すれば ok. | |
| :format に指定できるオプションについては、mssql::*query-formats* を参照. | |
| :connection が指定されている場合は、接続情報 (:db, :user, :password, :host) は無視." | |
| (if (scan "(?si)^\\s*select\\s+" sql) | |
| (let (recs) | |
| (handle-error verbose | |
| (if connection | |
| (setq recs (query sql :connection connection :format format)) | |
| (with-connection (db user password host) | |
| (setq recs (query sql :format format))))) | |
| (if (null recs) | |
| (if verbose | |
| (format stream "1 件もなかたよ")) | |
| (progn | |
| (if verbose | |
| (format stream "~a 件あたよ" (length recs))) | |
| ;; connection が指定されている場合は、DB と HOST の出力は connection を作ったところに任せる | |
| (if connection | |
| recs | |
| `((:db . ,db) (:host . ,host) (:records ,recs)))))) | |
| (format stream "SELECT ステートメントしか実行できないよ"))) | |
| (defun update-internal (sql table where connection format verbose) | |
| (let* ((select-sql (format nil "SELECT * FROM ~a ~a" table where)) | |
| (old-data (select select-sql :format format | |
| :stream nil | |
| :connection connection | |
| :verbose verbose)) | |
| (count (if (stringp old-data) | |
| 0 | |
| (mssql:execute sql :connection connection))) | |
| (new-data (if count | |
| (select select-sql :format format | |
| :stream nil | |
| :connection connection | |
| :verbose verbose)))) | |
| (values count new-data old-data))) | |
| (defun update (sql &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| "ポートを指定したい場合は :host に <ホスト名 / IP アドレス>:<ポート> で指定すれば ok. | |
| :format は更新前後のレコードの形式. 指定できるオプションについては mssql::*query-formats* を参照. | |
| connection が nil の場合、トランザクションを発効." | |
| (let ((pattern "(?si)^\\s*update\\s+([\\w.]+)\\s+.*?(where\\s+.*)?\\s*$")) | |
| (if (scan pattern sql) | |
| (register-groups-bind (table where) | |
| (pattern sql) | |
| (let (count new-data old-data) | |
| (handle-error verbose | |
| (if connection | |
| (update-internal sql table where connection format verbose) | |
| (with-connection (db user password host) | |
| (with-transaction () | |
| (multiple-value-bind (c n o) | |
| (update-internal sql table where *database* format verbose) | |
| (setq count c) | |
| (setq new-data n) | |
| (setq old-data o)))))) | |
| (if (numberp count) | |
| (if (< 0 count) | |
| (progn | |
| (if verbose | |
| (format stream "~a 件更新したぁよ~%" count)) | |
| ;; connection が指定されている場合は、DB と HOST の出力は connection を作ったところに任せる | |
| (if connection | |
| `((:before ,old-data) (:after ,new-data)) | |
| `((:db . ,db) (:host . ,host) (:before ,old-data) (:after ,new-data)))) | |
| (progn | |
| (if verbose | |
| (format stream "更新対象がなかたよ~%")) | |
| `((:db . ,db) (:host . ,host))))))) | |
| (format stream "UPDATE ステートメントしか実行できないよ")))) | |
| (defun insert (sql &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| "ポートを指定したい場合は :host に <ホスト名 / IP アドレス>:<ポート> で指定すれば ok. | |
| connection が nil の場合、トランザクションを発効." | |
| (declare (ignore format)) ; execute-sql から統一的に扱うため、他の関数との互換性 | |
| (if (scan "(?si)^\\s*insert\\s+" sql) | |
| (let (count) | |
| (handle-error verbose | |
| (if connection | |
| (setq count (mssql:execute sql :connection connection)) | |
| (with-connection (db user password host) | |
| (with-transaction () | |
| (setq count (mssql:execute sql)))))) | |
| (if (numberp count) | |
| (if (< 0 count) | |
| (progn | |
| (if verbose | |
| (format stream "~a 件登録したぁよ~%" count)) | |
| (if (not connection) | |
| `((:db . ,db) (:host . ,host)))) | |
| (if verbose | |
| (format stream "登録できなかたよ~%"))))) | |
| (format stream "INTERT ステートメントしか実行できないよ"))) | |
| (defun delete-records-internal (sql table where connection format) | |
| (let ((old-data (select (format nil "SELECT * FROM ~a ~a" table where) | |
| :format format | |
| :stream nil | |
| :connection connection)) | |
| (count (mssql:execute sql))) | |
| (values count old-data))) | |
| (defun delete-records (sql &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| "ポートを指定したい場合は :host に <ホスト名 / IP アドレス>:<ポート> で指定すれば ok. | |
| :format に指定できるオプションについては、mssql::*query-formats* を参照. | |
| connection が nil の場合、トランザクションを発効." | |
| (let ((res (register-groups-bind (table after-from where) | |
| ("(?si)^\\s*delete\\s+from\\s+([\\w.]+)(\\s+.*(where\\s+.*))?\\s*$" sql) | |
| (declare (ignore after-from)) | |
| (let (count old-data) | |
| (handle-error verbose | |
| (if connection | |
| (delete-records-internal sql table where connection format) | |
| (with-connection (db user password host) | |
| (with-transaction () | |
| (multiple-value-bind (c o) | |
| (delete-records-internal sql table where *database* format) | |
| (setq count c) | |
| (setq old-data o)))))) | |
| (if (numberp count) | |
| (if (< 0 count) | |
| (progn | |
| (if verbose | |
| (format stream "~a 件削除したぁよ~%" count)) | |
| ;; connection が指定されている場合は、DB と HOST の出力は connection を作ったところに任せる | |
| (if connection | |
| old-data | |
| `((:db . ,db) (:host . ,host) (:deleted ,old-data)))) | |
| (progn | |
| (if verbose | |
| (format stream "削除対象がなかたよ~%")) | |
| t))))))) | |
| (if res | |
| res | |
| (format stream "DELETE ステートメントしか実行できないよ")))) | |
| (defun execute (sql &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| "単一の sql ステートメントを実行する. | |
| sql の先頭の単語に従って select/update/insert/delete を実行する. | |
| select の場合、select したレコードを返す. | |
| update の場合、update 前/後のレコードを返す. | |
| delete の場合、delete したレコードを返す. | |
| insert の場合、何も返さない. | |
| ポートを指定したい場合は :host に <ホスト名 / IP アドレス>:<ポート> で指定すれば ok. | |
| :format に指定できるオプションについては、mssql::*query-formats* を参照. | |
| :connection が指定されている場合は、接続情報 (:db, :user, :password, :host) は無視. | |
| :verbose が t の場合、SQL Server の標準出力をそのまま出力する." | |
| (register-groups-bind (act) | |
| ("(?si)^\\s*(\\w+)\\s+" sql) | |
| (let ((action (string-downcase act))) | |
| (cond ((string= "select" action) | |
| (select sql | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream stream | |
| :connection connection | |
| :verbose verbose)) | |
| ((string= "update" action) | |
| (update sql | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream stream | |
| :connection connection | |
| :verbose verbose)) | |
| ((string= "insert" action) | |
| (insert sql | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream stream | |
| :connection connection | |
| :verbose verbose)) | |
| ((string= "delete" action) | |
| (delete-records sql | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream stream | |
| :connection connection | |
| :verbose verbose)))) | |
| )) | |
| (defun create (sql &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| "今のところ、テーブルの create のみサポート. | |
| ポートを指定したい場合は :host に <ホスト名 / IP アドレス>:<ポート> で指定すれば ok. | |
| connection が nil の場合、トランザクションを発効." | |
| (declare (ignore format)) ; execute-sql から統一的に扱うため、他の関数との互換性 | |
| (let ((res (register-groups-bind (table) | |
| ("(?si)^\\s*create\\s+table\\s+([\\w.]+)\\s*\\(.*$" sql) | |
| (let (count) | |
| (handle-error verbose | |
| (if connection | |
| (setq count (mssql:execute sql :connection connection)) | |
| (with-connection (db user password host) | |
| (with-transaction () | |
| (setq count (mssql:execute sql)))))) | |
| (if (numberp count) | |
| (if (< 0 count) | |
| (progn | |
| (if verbose | |
| (format stream "テーブル ~a を作成したぁよ~%" table)) | |
| ;; connection が指定されている場合は、DB と HOST の出力は connection を作ったところに任せる | |
| (if (not connection) | |
| `((:db . ,db) (:host . ,host)))) | |
| (progn | |
| (if verbose | |
| (format stream "テーブル ~a を作成できかなたよ~%" table)) | |
| t))))))) | |
| (if res | |
| res | |
| (format stream "CREATE TABLE ステートメントしか実行できないよ")))) | |
| (defun execute-file (file &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) verbose) | |
| "複数の SQL を実行したい場合、文末にセミコロン (;) を付けて区切っておく. | |
| 全ての SQL が同一トランザクション内で実行される. | |
| ポートを指定したい場合は :host に <ホスト名 / IP アドレス>:<ポート> で指定すれば ok. | |
| :format に指定できるオプションについては、mssql::*query-formats* を参照." | |
| (if (file-exists-p file) | |
| (let (results) | |
| (handle-error verbose | |
| (with-connection (db user password host) | |
| (with-transaction () | |
| (setq results (mapcar #'(lambda (sql) | |
| (let ((func (if (< 0 (length sql)) | |
| (string-case ((string-downcase | |
| (first (split "\\s" sql)))) | |
| ("select" #'select) | |
| ("update" #'update) | |
| ("delete" #'delete-records) | |
| ("insert" #'insert) | |
| ("create" #'create) | |
| ("--"))))) | |
| (if func | |
| `((:sql ,sql) | |
| (:results ,(funcall func sql :connection *database* | |
| :format format | |
| :stream stream)))))) | |
| (remove-if #'(lambda (str) | |
| (= 0 (length str))) | |
| (mapcar #'(lambda (str) | |
| (string-trim '(#\Space #\tab #\newline) str)) | |
| (split ";" (read-file-string file))))))))) | |
| `((:db . ,db) (:host . ,host) ,results)) | |
| (format stream "ファイル ~a がないよ" file))) | |
| (defun format-string (sizes format) | |
| (if (eql :table format) | |
| (format nil "|~{ ~~~a,,a |~}~~%" sizes) | |
| (format nil "~{~a~^,~}~~%" (iter (for j from 0 to (1- (length sizes))) | |
| (collect "~a"))))) | |
| (defun wide-char-p (char) | |
| (< 2 (length (sb-ext:string-to-octets (coerce (list char) 'string))))) | |
| (defun wide-char-count (str) | |
| (length (remove-if #'null (mapcar #'wide-char-p (coerce str 'list))))) | |
| (defun str-width (str) | |
| (+ (length str) (wide-char-count str))) | |
| (defun substr-by-width (str len &key (side :left)) | |
| (let ((list (coerce (if (eq :left side) | |
| str | |
| (reverse str)) | |
| 'list))) | |
| (let ((result (coerce (iterate:iter (iterate:for char in list) | |
| (iterate:with acc = 0) | |
| (setq acc (+ acc (if (wide-char-p char) | |
| 2 | |
| 1))) | |
| (if (>= len acc) | |
| (iterate:collect char) | |
| (iterate:finish))) | |
| 'string))) | |
| (coerce (if (eq :left side) | |
| result | |
| (nreverse result)) | |
| 'string)))) | |
| (defun omit (val col-size side) | |
| (if (>= col-size (str-width (if (stringp val) | |
| val | |
| (write-to-string val)))) | |
| val | |
| (let ((val-len (- col-size (length "...")))) | |
| (case side | |
| ((:middle) | |
| (let* ((half (/ val-len 2)) | |
| (last-half (floor half)) | |
| (first-half (if (integerp half) | |
| half | |
| (1+ last-half)))) | |
| (format nil "~a...~a" | |
| (substr-by-width val first-half) | |
| (substr-by-width val last-half :side :right)))) | |
| ((:left) | |
| (format nil "...~a" (substr-by-width val val-len :side :right))) | |
| ((:right) | |
| (format nil "~a..." (substr-by-width val val-len))))))) | |
| (defun pretty-print-records (records &key (format :table) max-col-size omit-side) | |
| (if (null records) | |
| (format t "pretty-print できないやつ.") | |
| (let* ((first-rec (first records)) | |
| (col-sizes (iter (for i from 0 to (1- (length first-rec))) | |
| (collect (apply | |
| #'max | |
| (append (list (str-width (car (nth i first-rec)))) | |
| (mapcar #'(lambda (rec) | |
| (let* ((val (cdr (nth i rec))) | |
| (size (str-width (if (stringp val) | |
| val | |
| (write-to-string val))))) | |
| (if (and max-col-size | |
| (<= (- max-col-size (length "...")) | |
| size)) | |
| max-col-size | |
| size))) | |
| records)))))) | |
| (names (apply #'format (let ((names (mapcar #'car (first records)))) | |
| (append (list nil (format-string | |
| (iter (for val in names) | |
| (for size in col-sizes) | |
| (collect (- size (wide-char-count val)))) | |
| format)) | |
| names)))) | |
| (separator (format nil "|~{~a~^+~}|~%" (mapcar #'(lambda (size) | |
| (make-string (+ 2 size) :initial-element #\-)) | |
| col-sizes)))) | |
| (princ names) | |
| (if (eql :table format) | |
| (princ separator)) | |
| (mapc #'(lambda (rec) | |
| (apply #'format | |
| (let ((vals (mapcar #'(lambda (col) | |
| (let ((val (if (stringp (cdr col)) | |
| (regex-replace-all "(\\r\\n|\\r|\\n)" | |
| (cdr col) | |
| "⏎ ") | |
| (cdr col)))) | |
| (if (and (eql format :table) | |
| max-col-size) | |
| ;; max-col-size で切り詰め. | |
| (omit val max-col-size omit-side) | |
| val))) | |
| rec))) | |
| (append (list t (format-string | |
| (iter (for val in vals) | |
| (for size in col-sizes) | |
| (collect (- size (wide-char-count (if (stringp val) | |
| val | |
| (write-to-string val)))))) | |
| format)) | |
| vals)))) | |
| records) | |
| (if (and (eql :table format) | |
| (<= *pretty-print-footer-threshold* (length records))) | |
| (progn | |
| (princ separator) | |
| (princ names)))))) | |
| (defun pretty-print (data &key (format :table) max-col-size (omit-side :middle)) | |
| "execute の戻り値を整形して標準出力する. | |
| data execute の戻り値. | |
| format :table の場合表形式で出力する. それ以外の場合 CSV 形式で出力する. | |
| max-col-size 最大カラム幅. ただしヘッダの文字列の方が長い場合、その長さに従う. format が :table の場合のみ有効. | |
| omit-side :left or :middle or :right. 値の長さが最大カラム幅を超えた場合に省略する位置. format が :table の場合のみ有効." | |
| (let* ((db (cdr (find-if #'(lambda (rec) | |
| (eql :db (car rec))) | |
| data))) | |
| (host (cdr (find-if #'(lambda (rec) | |
| (eql :host (car rec))) | |
| data)))) | |
| (if (eql :table format) | |
| (format t "DB: ~a, HOST: ~a~%" db host)) | |
| (flet ((extract-records (d key) | |
| (mapcar #'(lambda (record) | |
| (mapcar #'(lambda (col) | |
| (if (cdr col) | |
| col | |
| (cons (car col) "NULL"))) | |
| record)) | |
| (cadr (find-if #'(lambda (rec) | |
| (eql key (car rec))) | |
| d))))) | |
| (iter (for class in '(:records :before :after :deleted)) | |
| (let ((records (extract-records data class))) | |
| (if (not (null records)) | |
| (progn | |
| (if (eql :table format) | |
| (if (not (eql :records class)) | |
| (format t "~a:~%" class))) | |
| (pretty-print-records records :format format :max-col-size max-col-size :omit-side omit-side)))))) | |
| (if (and (eql :table format) | |
| max-col-size) | |
| (format t "(max-col-size=~a)~%" max-col-size)) | |
| nil)) | |
| (defun get-metadata (table &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) connection verbose) | |
| ":DB には、必ず :TABLE があるデータベースを指定する必要がある. | |
| :TABLE に \"<DB 名>.<スキーマ>.<テーブル名>\" のような指定をしても正しい結果は取得できない." | |
| (let ((sql (format nil " | |
| SELECT | |
| col.name 'column_name', | |
| typ.name 'type', | |
| col.max_length, | |
| col.precision, | |
| col.scale, | |
| col.is_nullable | |
| FROM | |
| sys.objects obj | |
| INNER JOIN sys.columns col | |
| ON obj.object_id = col.object_id | |
| INNER JOIN sys.types typ | |
| ON col.user_type_id = typ.user_type_id | |
| WHERE | |
| obj.type = 'U' | |
| AND obj.name = '~a' | |
| ORDER BY | |
| obj.name, | |
| col.column_id" table)) | |
| recs) | |
| (setq recs (select sql | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream nil | |
| :connection connection | |
| :verbose verbose)) | |
| recs)) | |
| (defun dump (table &key where (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| ":DB には、必ず :TABLE があるデータベースを指定する必要がある. | |
| :TABLE に \"<DB 名>.<スキーマ>.<テーブル名>\" のような指定をしても正しい結果は取得できない." | |
| (if (find #\. table) | |
| (format t "他スキーマのテーブルからダンプする場合、:DB でスキーマを指定してください.~%") | |
| (let ((meta (get-metadata table | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :connection connection | |
| :verbose verbose)) | |
| (data (select (format nil "SELECT * FROM ~a ~@[WHERE ~a~]" table where) | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream stream | |
| :connection connection | |
| :verbose verbose))) | |
| (if (null connection) | |
| (setq meta (cadr (assoc :records meta)))) | |
| `((:db . ,(cdr (assoc :db data))) (:host . ,(cdr (assoc :host data))) | |
| (:records | |
| ,(mapcar #'(lambda (rec) | |
| (format nil "INSERT INTO ~a (~{~a~^, ~}) VALUES (~{~a~^, ~})" table | |
| (mapcar #'car rec) | |
| (mapcar | |
| #'(lambda (field) | |
| (let ((type (make-keyword | |
| (string-upcase | |
| (cdr (assoc "type" | |
| (find-if #'(lambda (entry) | |
| (string= (car field) | |
| (cdr (assoc "column_name" entry | |
| :test #'string=)))) | |
| meta) | |
| :test #'string=))))) | |
| (value (cdr field))) | |
| (let ((result (cond ((null value) | |
| "NULL") | |
| ((member type '(:char | |
| :varchar | |
| :text | |
| :nchar | |
| :nvarchar | |
| :ntext)) | |
| (format nil "'~a'" value)) | |
| ((member type '(:date | |
| :datetimeoffset | |
| :datetime2 | |
| :smalldatetime | |
| :datetime | |
| :time)) | |
| (funcall *datetime-formatter* | |
| (funcall *datetime-parser* value))) | |
| (t | |
| value)))) | |
| result))) | |
| rec))) | |
| (cadr (assoc :records data)))))))) | |
| (defun columns (tables &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| (select (format nil "SELECT ~ac.name AS ColumnName,t.name AS ColumnType,c.length AS Length,IsNull(i.p,'') AS 'P-Key',CASE WHEN c.isnullable = 0 THEN 'nope' ELSE 'yep' END AS Nullable FROM syscolumns as c INNER JOIN(SELECT id,xtype,name FROM sysobjects WHERE xtype IN ('U','V') and name IN(~a))AS o ON c.id=o.id INNER JOIN(SELECT xtype,xusertype,type,usertype,name FROM systypes)AS t ON c.xtype=t.xtype AND c.xusertype=t.xusertype LEFT JOIN (SELECT 'yep' AS p, table_name, column_name FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE WHERE OBJECTPROPERTY(OBJECT_ID(constraint_name),'IsPrimaryKey')=1) AS i ON o.name=i.table_name AND c.name=i.column_name ORDER BY o.name,c.colid" | |
| (if (and (listp tables) | |
| (< 1 (length tables))) | |
| "o.name," | |
| "") | |
| (if (stringp tables) | |
| (format nil "'~a'" tables) | |
| (format nil "~{'~a'~^, ~}" tables))) | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream stream | |
| :connection connection | |
| :verbose verbose)) | |
| (defun tables (&key like-list (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (format :str-alists) (stream *standard-output*) connection verbose) | |
| (select (format nil "SELECT name FROM sysobjects WHERE xtype = 'U' ~a ORDER BY name" | |
| (if (null like-list) | |
| "" | |
| (format nil "AND (~{name LIKE '~a'~^ OR ~})" like-list))) | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format format | |
| :stream stream | |
| :connection connection | |
| :verbose verbose)) | |
| (defun columns-for-skeleton (table &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (stream *standard-output*) connection verbose) | |
| (mapcar #'(lambda (col) | |
| (cdr (assoc "ColumnName" col :test 'string=))) | |
| (cadr (assoc :records (columns (list table) | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :format :str-alists | |
| :stream stream | |
| :connection connection | |
| :verbose verbose))))) | |
| (defun columns-with-equal (columns) | |
| (mapcar #'(lambda (col) | |
| (format nil "~a =" col)) | |
| columns)) | |
| (defun skeleton-select (table &key where-exclude (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (stream *standard-output*) connection verbose) | |
| (let ((columns (columns-for-skeleton table | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :stream stream | |
| :connection connection | |
| :verbose verbose))) | |
| (format stream "SELECT ~{~a~^, ~} FROM ~a WHERE ~{~a~^ AND ~};" | |
| columns | |
| table | |
| (columns-with-equal (remove-if #'(lambda (col) | |
| (member col (mapcar #'string-downcase | |
| where-exclude) | |
| :test 'string=)) | |
| columns))))) | |
| (defun skeleton-insert (table &key (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (stream *standard-output*) connection verbose) | |
| (let ((columns (columns-for-skeleton table | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :stream stream | |
| :connection connection | |
| :verbose verbose))) | |
| (format stream "INSERT INTO ~a (~{~a~^, ~}) VALUES (~{~a~^, ~});" | |
| table | |
| columns | |
| (mapcar #'(lambda (col) (declare (ignore col)) "") columns)))) | |
| (defun skeleton-update (table &key where-exclude (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (stream *standard-output*) connection verbose) | |
| (let* ((columns (columns-for-skeleton table | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :stream stream | |
| :connection connection | |
| :verbose verbose))) | |
| (format stream "UPDATE ~a SET ~{~a~^, ~} WHERE ~{~a~^ AND ~};" | |
| table | |
| (columns-with-equal columns) | |
| (columns-with-equal (remove-if #'(lambda (col) | |
| (member col (mapcar #'string-downcase | |
| where-exclude) | |
| :test 'string=)) | |
| columns))))) | |
| (defun skeleton-delete (table &key where-exclude (db *default-database*) (user *default-user*) | |
| (password *default-password*) (host *default-database-host*) | |
| (stream *standard-output*) connection verbose) | |
| (let* ((columns (columns-with-equal (remove-if #'(lambda (col) | |
| (member col (mapcar #'string-downcase | |
| where-exclude) | |
| :test 'string=)) | |
| (columns-for-skeleton table | |
| :db db | |
| :user user | |
| :password password | |
| :host host | |
| :stream stream | |
| :connection connection | |
| :verbose verbose))))) | |
| (format stream "DELETE FROM ~a WHERE ~{~a~^ AND ~};" | |
| table | |
| columns))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment