Merge pull request #319 from sabracrolleton/master

Minor bug fixes - Drop Role and Execute File

CHANGELOG.md

@@ -1,3 +1,15 @@
+# Changelog 1.33.8
+
+Dollar Quoted tags are allowed in files. Prior to Postmodern version 1.33.8 only
+alphabetic characters were allowed in tags. Postgresql documentation and industry
+practice allow any character to be in a dollar quoted tag. Postmodern version 1.33.8
+relaxes the alphabetic character requirement. The only limitation now is that digit
+characters cannot be in the first position in a tag.
+
+This version also fixes a bug in the postmodern function drop-role. Previously if a role
+owned objects in multiple databases, the drop-role function tried to drop the role before
+all owned objects were reassigned owners.
+
 # Changelog 1.33.7
 Changes in cl-postgres and s-sql to allow use of plain proper lists in parameterized queries. Previously only vectors could be used. The following show examples using both vectors and lists in queries using both raw sql and s-sql.
 ```lisp

README.md

@@ -4,7 +4,7 @@ A Common Lisp PostgreSQL programming interface
 
 ---
 
-Version 1.33.7
+Version 1.33.8
 
 Postmodern is a Common Lisp library for interacting with [PostgreSQL](http://www.postgresql.org) databases. It is under active development. Features are:
 

cl-postgres.asd

@@ -16,7 +16,7 @@
   :author "Marijn Haverbeke <[email protected]>"
   :maintainer "Sabra Crolleton <[email protected]>"
   :license "zlib"
-  :version "1.33.7"
+  :version "1.33.8"
   :depends-on ("md5" "split-sequence" "ironclad" "cl-base64" "uax-15"
                      (:feature (:or :allegro :ccl :clisp :genera
                                 :armedbear :cmucl :lispworks)

doc/postmodern.org

@@ -2327,6 +2327,15 @@ The default setting is to remove sql comments from the file before executing
 the sql code. If that causes problems, the remove-comments parameter can be
 set to nil.
 
+Dollar Quoted tags are allowed in files. Prior to Postmodern version 1.33.8 only
+alphabetic characters were allowed in tags. Postgresql documentation and industry
+practice allow any character to be in a dollar quoted tag. Postmodern version 1.33.8
+relaxes the alphabetic character requirement. The only limitation now is that digit
+characters cannot be in the first position in a tag.
+
+Execute-file does not support copy-in or copy-out in a file. If you have files
+with that requirement, you will need to fall back on another solution.
+
 IMPORTANT NOTE: This utility function assumes that the file containing the sql
 queries can be trusted and bypasses the normal postmodern parameterization of
 queries.

postmodern.asd

@@ -20,7 +20,7 @@
   :maintainer "Sabra Crolleton <[email protected]>"
   :homepage  "https://github.com/marijnh/Postmodern"
   :license "zlib"
-  :version "1.33.7"
+  :version "1.33.8"
   :depends-on ("alexandria"
                "cl-postgres"
                "s-sql"

postmodern/execute-file.lisp

@@ -1,6 +1,11 @@
 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: POSTMODERN; -*-
 (in-package :postmodern)
 
+(defun disallowed-tag-char-p (char)
+  "Returns t if char is a character we are going to disallow in a tag"
+  (if (member char '(#\space #\tab #\newline #\linefeed #\page #\return #\backspace #\rubout))
+      t nil))
+
 (defstruct parser
   filename
   (stream  (make-string-output-stream))
@@ -49,10 +54,13 @@
   (pop (parser-tags p)))
 
 (defmethod reset-state ((p parser) &key tagp)
-  "Depending on the current tags stack, set P state to either :eat or :eqt"
+  "Depending on the current tags stack, set P state to :eat, :ett or :eqt"
   (setf (parser-state p)
         (cond ((null (parser-tags p)) :eat)
-              (tagp :ett)
+              ((or tagp
+                   (> (length (parser-tags p))
+                      0))
+               :ett)
               (t :eqt))))
 
 #|
@@ -137,24 +145,24 @@ should return
                            (:eat    (setf (parser-state state) :tag))
                            (:ett    (setf (parser-state state) :tag))
                            (:tag    (setf (parser-state state) :eot)))
-
                ;; we act depending on the NEW state
                (case (parser-state state)
                  ((:eat :eqt :edq)
                   (write-char char (parser-stream state)))
 
-                 (:tag (push-new-tag state))
+                 (:tag
+                  (push-new-tag state))
 
                  (:eot                 ; check the tag stack
                   (cond ((= 1 (length (parser-tags state)))
                          ;; it's an opening tag, collect the text now
                          (format-current-tag state)
                          (reset-state state :tagp t))
 
-                        (t          ; are we closing the current tag?
+                        (t           ; are we closing the current tag?
                          (if (maybe-close-tags state)
-                             (reset-state state :tagp t)
-
+                             (progn
+                               (reset-state state :tagp t))
                              ;; not the same tags, switch state back
                              ;; don't forget to add the opening tag
                              (progn
@@ -167,7 +175,6 @@ should return
 
               (otherwise (cond ((member (parser-state state) '(:eat :eqt :ett :edq))
                                 (write-char char (parser-stream state)))
-
                                ;; see
                                ;; http://www.postgresql.org/docs/current/sql-syntax-lexical.html#SQL-SYNTAX-STRINGS-ESCAPE
                                ;; we re-inject whatever we read in the \x
@@ -178,25 +185,34 @@ should return
                                 (setf (parser-state state) :eqt))
 
                                ((member (parser-state state) '(:tag))
-                                ;; only letters are allowed in tags
-                                (if (alpha-char-p char)
-                                    (extend-current-tag state char)
-
-                                    (progn
-                                      ;; not a tag actually: remove the
-                                      ;; parser-tags entry and push back its
-                                      ;; contents to the main output stream
-                                      (let ((tag (pop-current-tag state)))
-                                        (format (parser-stream state)
-                                                "$~a~c"
-                                                tag
-                                                char))
-                                      (reset-state state)))))))
+                                ;; any non-numeric characters are allowed in tags
+                                ;; numeric characters immediately following a $ indicates a parameter
+                                ;; not a tag
+                                (if
+                                 (or (not (digit-char-p char))
+                                     (> (length (first (parser-tags state))) 0))
+                                 (extend-current-tag state char)
+
+                                 (progn
+                                   ;; not a tag actually: remove the
+                                   ;; parser-tags entry and push back its
+                                   ;; contents to the main output stream
+
+                                   (let ((tag (pop-current-tag state)))
+                                     (format (parser-stream state)
+                                             "$~a~c"
+                                             tag
+                                             char))
+                                   (reset-state state)))))))
         :finally (return
                    (get-output-stream-string (parser-stream state))))
     (end-of-file (e)
       (unless (eq :eat (parser-state state))
-        (error e)))))
+        (error
+         (format nil "~a~%~%~a" e
+                 "In this context, look particularly for mismatched dollar quoted tags or a dollar quoted tag
+that starts with a digit. Digits in a dollar quoted tag should not be in the first position
+or they will be confused with parameterized variable positions."))))))
 
 (defstruct comment-parser
   buffer
@@ -223,7 +239,7 @@ should return
 (defun parse-comments (str &optional (state (make-comment-parser)))
   (loop for char across str
         do
-;           (format t "~a ~a~%" char (char-code char))
+
            (case char
              (#\' (case (first (comment-parser-state state))
                     (:base (push :sq (comment-parser-state state))
@@ -247,7 +263,7 @@ should return
                     (:slc )
                     (:sq (write-char char (comment-parser-stream state)))
                     (:sb? (setf (first (comment-parser-state state)) :slc))
-                    (:mb?  ; faked multi-line beginning, return to earlier state
+                    (:mb? ; faked multi-line beginning, return to earlier state
                      (pop (comment-parser-state state))
                      (when (eq (first (comment-parser-state state))
                                :base)
@@ -263,10 +279,10 @@ should return
                            (write-char char (comment-parser-stream state)))
                           (:sb? (pop (comment-parser-state state))
                            (write-char char (comment-parser-stream state)))
-                          (:mb?  ; faked multi-line beginning, return to earlier state
+                          (:mb? ; faked multi-line beginning, return to earlier state
                            (pop (comment-parser-state state))
                            (when (eq (first (comment-parser-state state))
-                               :base)
+                                     :base)
                              (write-char #\/ (comment-parser-stream state))
                              (write-char #\/ (comment-parser-stream state))))
                           (:me? (pop (comment-parser-state state))
@@ -284,8 +300,8 @@ should return
                        (write-char #\/ (comment-parser-stream state))))
                     (:mlc  (push :mb? (comment-parser-state state))
                      )
-                    (:me? ; actual ending of a multi-line comment
-                         ; need to pop both the :me? amd tej :mlc
+                    (:me?     ; actual ending of a multi-line comment
+                                        ; need to pop both the :me? amd tej :mlc
                      (pop (comment-parser-state state))
                      (pop (comment-parser-state state)))))
              (#\* (case (first (comment-parser-state state))
@@ -294,7 +310,7 @@ should return
                     (:mlc ; maybe starting the end of a nested multi-line comment
                      (push :me? (comment-parser-state state)))
                     (:sq (write-char char (comment-parser-stream state)))
-                    (:me? ; fake ending of a multi-line comment
+                    (:me?        ; fake ending of a multi-line comment
                      (pop (comment-parser-state state))
                      (when (eq (first (comment-parser-state state)) :mlc)
                        (push :me? (comment-parser-state state))))))
@@ -307,9 +323,9 @@ should return
                                      :base)
                              (write-char #\/ (comment-parser-stream state))
                              (write-char char (comment-parser-stream state))))
-                          (:me? ; fake ending of a multi-line comment
+                          (:me?  ; fake ending of a multi-line comment
                            (pop (comment-parser-state state)))
-                          (:sb? ; fake single line comment
+                          (:sb?         ; fake single line comment
                            (pop (comment-parser-state state))
                            (write-char #\- (comment-parser-stream state))
                            (write-char char (comment-parser-stream state)))

postmodern/roles.lisp

@@ -433,17 +433,24 @@ group roles."
   (when (not (role-exists-p new-owner))
     (setf new-owner (cl-postgres::connection-user *database*)))
   (if (eq database :all)
-      (loop for x in (list-databases :names-only t) do
-        (with-connection (list x (cl-postgres::connection-user *database*)
+      (progn
+        (loop for x in (list-databases :names-only t) do
+          (with-connection (list x (cl-postgres::connection-user *database*)
+                                 (cl-postgres::connection-password *database*)
+                                 (cl-postgres::connection-host *database*)
+                                 :port (cl-postgres::connection-port *database*)
+                                 :use-ssl (cl-postgres::connection-use-ssl *database*))
+            (when (and (not (string= role-name "postgres"))
+                       (role-exists-p role-name))
+              (query (format nil "reassign owned by ~a to ~a" role-name new-owner))
+              (query (format nil "drop owned by ~a" role-name)))))
+        (with-connection (list (cl-postgres::connection-db *database*)
+                               (cl-postgres::connection-user *database*)
                                (cl-postgres::connection-password *database*)
                                (cl-postgres::connection-host *database*)
                                :port (cl-postgres::connection-port *database*)
                                :use-ssl (cl-postgres::connection-use-ssl *database*))
-          (when (and (not (string= role-name "postgres"))
-                     (role-exists-p role-name))
-            (query (format nil "reassign owned by ~a to ~a" role-name new-owner))
-            (query (format nil "drop owned by ~a" role-name))
-            (query (format nil "drop role if exists ~a" role-name)))))
+          (query (format nil "drop role if exists ~a" role-name))))
       (with-connection (list database (cl-postgres::connection-user *database*)
                              (cl-postgres::connection-password *database*)
                              (cl-postgres::connection-host *database*)
@@ -454,7 +461,7 @@ group roles."
           (query (format nil "reassign owned by ~a to ~a" role-name new-owner))
           (query (format nil "drop owned by ~a cascade" role-name))
           (query (format nil "drop role if exists ~a" role-name)))))
-      (not (role-exists-p role-name)))
+  (not (role-exists-p role-name)))
 
 (defun list-role-permissions (&optional role)
   "This returns a list of sublists of the permissions granted  within the