mirror of
https://github.com/dimitri/pgloader.git
synced 2025-08-07 23:07:00 +02:00
213 lines
8.4 KiB
Common Lisp
213 lines
8.4 KiB
Common Lisp
;;;
|
||
;;; Parse the pgloader commands grammar
|
||
;;;
|
||
|
||
(in-package :pgloader.parser)
|
||
|
||
;;;
|
||
;;; INCLUDING ONLY and EXCLUDING clauses for MS SQL
|
||
;;;
|
||
;;; There's no regexp matching on MS SQL, so we're going to just use the
|
||
;;; classic LIKE support here, as documented at:
|
||
;;;
|
||
;;; http://msdn.microsoft.com/en-us/library/ms187489(SQL.90).aspx
|
||
;;;
|
||
(make-option-rule create-schemas (and kw-create (? kw-no) kw-schemas))
|
||
|
||
(defrule mssql-option (or option-on-error-stop
|
||
option-on-error-resume-next
|
||
option-workers
|
||
option-concurrency
|
||
option-batch-rows
|
||
option-batch-size
|
||
option-prefetch-rows
|
||
option-max-parallel-create-index
|
||
option-reindex
|
||
option-truncate
|
||
option-disable-triggers
|
||
option-data-only
|
||
option-schema-only
|
||
option-include-drop
|
||
option-create-tables
|
||
option-create-schemas
|
||
option-create-indexes
|
||
option-index-names
|
||
option-reset-sequences
|
||
option-foreign-keys
|
||
option-encoding
|
||
option-identifiers-case))
|
||
|
||
(defrule mssql-options (and kw-with
|
||
(and mssql-option (* (and comma mssql-option))))
|
||
(:function flatten-option-list))
|
||
|
||
(defrule including-in-schema
|
||
(and kw-including kw-only kw-table kw-names kw-like filter-list-like
|
||
kw-in kw-schema quoted-namestring)
|
||
(:lambda (source)
|
||
(bind (((_ _ _ _ _ filter-list _ _ schema) source))
|
||
(cons schema filter-list))))
|
||
|
||
(defrule including-like-in-schema
|
||
(and including-in-schema (* including-in-schema))
|
||
(:lambda (source)
|
||
(destructuring-bind (inc1 incs) source
|
||
(cons :including (list* inc1 incs)))))
|
||
|
||
(defrule excluding-in-schema
|
||
(and kw-excluding kw-table kw-names kw-like filter-list-like
|
||
kw-in kw-schema quoted-namestring)
|
||
(:lambda (source)
|
||
(bind (((_ _ _ _ filter-list _ _ schema) source))
|
||
(cons schema filter-list))))
|
||
|
||
(defrule excluding-like-in-schema
|
||
(and excluding-in-schema (* excluding-in-schema))
|
||
(:lambda (source)
|
||
(destructuring-bind (excl1 excls) source
|
||
(cons :excluding (list* excl1 excls)))))
|
||
|
||
|
||
;;;
|
||
;;; MSSQL SET parameters, because sometimes we need that
|
||
;;;
|
||
(defrule mssql-gucs (and kw-set kw-mssql kw-parameters generic-option-list)
|
||
(:lambda (mygucs) (cons :mssql-gucs (fourth mygucs))))
|
||
|
||
|
||
;;;
|
||
;;; Allow clauses to appear in any order
|
||
;;;
|
||
(defrule load-mssql-optional-clauses (* (or mssql-options
|
||
mssql-gucs
|
||
gucs
|
||
casts
|
||
alter-schema
|
||
alter-table
|
||
materialize-views
|
||
distribute-commands
|
||
before-load
|
||
after-schema
|
||
after-load
|
||
including-like-in-schema
|
||
excluding-like-in-schema))
|
||
(:lambda (clauses-list)
|
||
(alexandria:alist-plist clauses-list)))
|
||
|
||
(defrule mssql-prefix "mssql://" (:constant (list :type :mssql)))
|
||
|
||
(defrule mssql-uri (and mssql-prefix
|
||
(? dsn-user-password)
|
||
(? dsn-hostname)
|
||
dsn-dbname)
|
||
(:lambda (uri)
|
||
(destructuring-bind (&key type
|
||
user
|
||
password
|
||
host
|
||
port
|
||
dbname)
|
||
(apply #'append uri)
|
||
;; Default to environment variables as described in
|
||
;; http://www.freetds.org/userguide/envvar.htm
|
||
(declare (ignore type))
|
||
(make-instance 'mssql-connection
|
||
:user (or user (getenv-default "USER"))
|
||
:pass password
|
||
:host (or host (getenv-default "TDSHOST" "localhost"))
|
||
:port (or port (parse-integer
|
||
(getenv-default "TDSPORT" "1433")))
|
||
:name dbname))))
|
||
|
||
(defrule mssql-source (and kw-load kw-database kw-from mssql-uri)
|
||
(:lambda (source) (bind (((_ _ _ uri) source)) uri)))
|
||
|
||
(defrule load-mssql-command (and mssql-source target
|
||
load-mssql-optional-clauses)
|
||
(:lambda (command)
|
||
(destructuring-bind (source target clauses) command
|
||
`(,source ,target ,@clauses))))
|
||
|
||
|
||
;;; LOAD DATABASE FROM mssql://
|
||
(defun lisp-code-for-mssql-dry-run (ms-db-conn pg-db-conn)
|
||
`(lambda ()
|
||
;; now is the time to load the CFFI lib we need (freetds)
|
||
(log-message :log "Loading the FreeTDS shared librairy (sybdb)")
|
||
(cffi:load-foreign-library 'mssql::sybdb)
|
||
|
||
(log-message :log "DRY RUN, only checking connections.")
|
||
(check-connection ,ms-db-conn)
|
||
(check-connection ,pg-db-conn)))
|
||
|
||
(defun lisp-code-for-loading-from-mssql (ms-db-conn pg-db-conn
|
||
&key
|
||
gucs mssql-gucs
|
||
casts before after after-schema
|
||
options distribute views
|
||
alter-schema alter-table
|
||
including excluding
|
||
&allow-other-keys)
|
||
`(lambda ()
|
||
;; now is the time to load the CFFI lib we need (freetds)
|
||
(let (#+sbcl(sb-ext:*muffled-warnings* 'style-warning))
|
||
(cffi:load-foreign-library 'mssql::sybdb)
|
||
(mssql:init))
|
||
|
||
(unwind-protect
|
||
(let* ((*default-cast-rules* ',*mssql-default-cast-rules*)
|
||
(*cast-rules* ',casts)
|
||
(*mssql-settings* ',mssql-gucs)
|
||
(on-error-stop (getf ',options :on-error-stop t))
|
||
,@(pgsql-connection-bindings pg-db-conn gucs)
|
||
,@(batch-control-bindings options)
|
||
,@(identifier-case-binding options)
|
||
(source
|
||
(make-instance 'copy-mssql
|
||
:target-db ,pg-db-conn
|
||
:source-db ,ms-db-conn)))
|
||
|
||
,(sql-code-block pg-db-conn :pre before "before load")
|
||
|
||
(copy-database source
|
||
:including ',including
|
||
:excluding ',excluding
|
||
:alter-schema ',alter-schema
|
||
:alter-table ',alter-table
|
||
:after-schema ',after-schema
|
||
:materialize-views ',views
|
||
:distribute ',distribute
|
||
:set-table-oids t
|
||
:on-error-stop on-error-stop
|
||
,@(remove-batch-control-option options))
|
||
|
||
,(sql-code-block pg-db-conn :post after "after load"))
|
||
(mssql:exit))))
|
||
|
||
(defrule load-mssql-database load-mssql-command
|
||
(:lambda (source)
|
||
(bind (((ms-db-uri pg-db-uri
|
||
&key
|
||
gucs mssql-gucs casts views before after-schema after
|
||
alter-schema alter-table distribute
|
||
including excluding options)
|
||
source))
|
||
(cond (*dry-run*
|
||
(lisp-code-for-mssql-dry-run ms-db-uri pg-db-uri))
|
||
(t
|
||
(lisp-code-for-loading-from-mssql ms-db-uri pg-db-uri
|
||
:gucs gucs
|
||
:mssql-gucs mssql-gucs
|
||
:casts casts
|
||
:views views
|
||
:before before
|
||
:after-schema after-schema
|
||
:after after
|
||
:alter-schema alter-schema
|
||
:alter-table alter-table
|
||
:distribute distribute
|
||
:options options
|
||
:including including
|
||
:excluding excluding))))))
|
||
|