;;; Copyright (c) 2002 - 2006 ;;; Benjamin Waldron, Ann Copestake, Fabre Lambeau, Stephan Oepen; ;;; see `LICENSE' for conditions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PSQL lexical source ;;; ;;; aac (aug-12-03) ;;; initialisation now sets to *lexicon* regardless (in-package :lkb) (defun postgres-user-temp-dir nil (make-pathname :directory (pathname-directory (lkb-tmp-dir)))) ;; call from script file (defun load-lexdb-from-script nil (close-lex *lexicon*) (cond (*lexdb-params* (unless (initialize-lexdb) (error "~%Load lexicon aborted")) (setf *lexicon* *lexdb*)) (t (error "to use the LexDB you must set *lexdb-params*")))) (defun extract-param (param param-list) (let ((match (assoc param param-list))) (if (> (length match) 2) (format t "~%;;; WARNING: malformed param entry '~S' in '~S'" param param-list) (second match)))) (defun type-2-psql-lex-database-type (type) (and type (case type (:single-user 'su-psql-lex-database) (:multi-user 'mu-psql-lex-database) (t (error "unknown :type ('~a') in LexDB params" type))))) (defun psql-lex-database-type (lex) (cond ((typep lex 'su-psql-lex-database) :single-user) ((typep lex 'mu-psql-lex-database) :multi-user))) (defun initialize-lexdb-default-type () (let ((type :multi-user)) (format t "~%Warning: using LexDB param :type = '~S'" type) (format t "~% (please set this explicitly in *lexdb-params*)") type)) (defun initialize-lexdb-type (x) (or x (extract-param :type *lexdb-params*) (psql-lex-database-type *lexdb*) (initialize-lexdb-default-type))) (defun initialize-lexdb-dbname (x) (or x (extract-param :dbname *lexdb-params*) (and *lexdb* (dbname *lexdb*)) (error "please set :dbname in *lexdb-params*"))) (defun initialize-lexdb-host (x) (or x (extract-param :host *lexdb-params*) (and *lexdb* (host *lexdb*)) "localhost")) ;(defun initialize-lexdb-table (x) ; (or x ; (extract-param :host *lexdb-params*) ; (and *lexdb* (fields-tb *lexdb*)) ; (and *lexdb* (dbname *lexdb*)))) (defun initialize-lexdb-port (x) (or x (extract-param :port *lexdb-params*) (and *lexdb* (port *lexdb*)) (or (getenv "PGPORT") *psql-database-port*))) (defun initialize-lexdb-user (x) (or x (extract-param :user *lexdb-params*) (and *lexdb* (user *lexdb*)) (sys-user-name))) (defun initialize-lexdb-password (x) (or x (extract-param :password *lexdb-params*) (and *lexdb* (password *lexdb*)) (and *lexdb* (user *lexdb*)))) (defun initialize-lexdb (&key type dbname host port user semi password) ;; warn on use of obsolete semi argument (when semi (format t "~%(LexDB) WARNING: :SEMI argument to *lexdb-params* is obsolete") (format t "~%(LexDB) (please call index-for-generator instead)")) ;; warn on use of obsolete table argument (when semi (format t "~%(LexDB) WARNING: :TABLE argument to *lexdb-params* is obsolete")) (let (part-of extra-lexicons) (psql-initialize) ;; username 'lexdb' is illegal in multi-user mode (if (and (string= user "lexdb") (eq type :multi-user)) (error "User 'lexdb' cannot connect as LexDB client. Please pick a different username...")) ;; obtain unlinked *lexdb* (setf type (initialize-lexdb-type type)) (cond ((and *lexdb* (eq type (psql-lex-database-type *lexdb*))) (setf part-of (part-of *lexdb*)) (setf (part-of *lexdb*) nil) ;; to avoid unlinking (setf extra-lexicons (extra-lexicons *lexdb*)) (setf (extra-lexicons *lexdb*) nil) ;; to avoid unlinking ) (t (setf *lexdb* (make-instance (type-2-psql-lex-database-type type))))) ;; set properties of *lexdb* (setf (dbname *lexdb*) (initialize-lexdb-dbname dbname)) (setf (host *lexdb*) (initialize-lexdb-host host)) (setf (user *lexdb*) (initialize-lexdb-user user)) (setf (password *lexdb*) (initialize-lexdb-password password)) (setf (port *lexdb*) (initialize-lexdb-port port)) ; (setf (fields-tb *lexdb*) (initialize-lexdb-table table)) ;; open lexdb and insert into lexicon hierarchy (when (open-lex *lexdb*) (mapcar #'(lambda (x) (link *lexdb* x)) part-of) (mapcar #'(lambda (x) (link x *lexdb*)) extra-lexicons) *lexdb*))) (defun open-psql-lex (&rest rest) "obsolete (keep for script file compatibility)" (apply 'open-lex rest)) #+:bmw20 (defun i (&optional (slot 'record-cache)) (inspect (slot-value *lexicon* slot))) (defvar mrs::*semantic-table*) (defvar mrs::*empty-semantics-lexical-entries*) (defun concat-str (str-list &key (sep-c #\Space)) (unless (listp str-list) (error "list expected")) (let ((sep (string sep-c))) (cond ((null str-list) "") (t (apply 'concatenate (cons 'string (cons (pop str-list) (mapcan #'(lambda (x) (list sep (if x x ""))) str-list)))))))) (defun to-psql-COPY-rec2 (lst &key (delim-char #\tab) (null "\\N")) (cond ((null lst) "") (t (apply #'concatenate 'string (append (list (psql-COPY-val (car lst) :delim-char delim-char :null null)) (loop with delim = (string delim-char) for x in (cdr lst) collect delim collect (psql-COPY-val x :delim-char delim-char :null null)) (list (string (code-char 10))) ;; newline ))))) (defun normalize-orthkeys-aux (recs i) (loop for rec in recs do (setf (nth i rec) (normalize-orthkey! (nth i rec)))) recs) (defun psql-COPY-val (val &key (delim-char #\tab) (null "\\N")) (cond ((null val) null) (t (coerce (loop with str = (2-str val) for char across str for code = (char-code char) when (= code 8) collect #\\ and collect #\b else when (= code 9) collect #\\ and collect #\t else when (= code 10) collect #\\ and collect #\n else when (= code 11) collect #\\ and collect #\v else when (= code 12) collect #\\ and collect #\f else when (= code 13) collect #\\ and collect #\r else when (eq char #\\) collect #\\ and collect #\\ else when (eq char delim-char) collect #\\ and collect delim-char else collect char) 'string)))) #+:null (defun clear-psql-semi (&key (lex *lexdb*)) (unless (typep lex 'psql-lex-database) (error "psql-lex-database expected")) (semi-drop-indices lex) (run-command lex "DELETE FROM semi_pred") (run-command lex "DELETE FROM semi_frame") (run-command lex "DELETE FROM semi_var") (run-command lex "DELETE FROM semi_extra") (run-command lex "DELETE FROM semi_mod")) (defun compat-version (lexdb-version) (when (stringp lexdb-version) (subseq lexdb-version 0 3))) (defmethod fields-str ((lex psql-lex-database) fields) (concat-str (mapcar #'(lambda (x) (quote-ident lex x)) fields) :sep-c #\,)) (defun sql-list (l quote-fn) (format nil "(~a)" (concat-str (mapcar quote-fn l) :sep-c #\,))) ;(defmethod psql-lex-database-type ((lex psql-lex-database)) ; (cond ; ((typep lex 'mu-psql-lex-database) ; 'mu-psql-lex-database) ; ((typep lex 'su-psql-lex-database) ; 'su-psql-lex-database) ; (t ; (error "unexpected psql-lex-database type: ~S" lex)))) (defmacro with-lexdb-user-lexdb ((lexdb-lexdb lexdb) &body body) `(with-slots (dbname host port fields-tb) ,lexdb (let ((,lexdb-lexdb (make-instance (type-2-psql-lex-database-type (psql-lex-database-type ,lexdb)) :dbname dbname ;:fields-tb fields-tb :host host :port port :user (db-owner ,lexdb)))) (open-lex ,lexdb-lexdb) ,@body (close-lex ,lexdb-lexdb)))) #+:null (defmacro with-lexdb-user-x ((user lexdb-lexdb lexdb) &body body) `(with-slots (dbname host port fields-tb) ,lexdb (let ((,lexdb-lexdb (make-instance (type-2-psql-lex-database-type (psql-lex-database-type ,lexdb)) :dbname dbname :fields-tb fields-tb :host host :port port :user ,user))) (open-lex ,lexdb-lexdb) ,@body (close-lex ,lexdb-lexdb)))) (defmacro lexdb-time ((start-msg end-msg) &body body) `(let (time out) (format t "~&(LexDB) ~a ..." ,start-msg) (force-output) (setf time (get-internal-real-time)) (setf out (progn ,@body)) (format t "~&(LexDB) ~a [~F sec]" ,end-msg (/ (- (get-internal-real-time) time) internal-time-units-per-second)) out))