diff --git a/CHANGELOG.md b/CHANGELOG.md index 2f583e7..e9bc4b5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,30 @@ +# Changelog v. 1.32.9 +Adds new utility functions + +- table-description-menu which allows you to pick and choose +what table characteristics you want returned. See giant docstring for details. + +- get-schema-comment which takes a schema name and returns the schema comment +as a string + +- list-check-constraints which takes a fully qualified table name and returns +a list of lists of check constraints where each sublist has the form +of (check-constraint-name check). + +Example: (list-check-constraints "s2.employees") +(("employees_birth_date_check" "CHECK (birth_date > '1900-01-01'::date)") + ("employees_check" "CHECK (start_date > birth_date)") + ("employees_salary_check" "CHECK (salary > 0::numeric)")) + +Now exports +get-column-comments (the parameter string has changed if you were using the internal version) +get-all-table-comments + +Bug Fixes: + +Fixes a bug when trying to connect to a database using ssl. If the keyword :try was used, +the connection would not fall back to non-ssl connections. + # Changelog v. 1.32.8 S-SQL Enhancements diff --git a/ROADMAP.md b/ROADMAP.md index 1103e18..1d5cb3c 100644 --- a/ROADMAP.md +++ b/ROADMAP.md @@ -49,10 +49,6 @@ No guarantee is given with respect to resolution or timing on any item. - [ ] Named Prepared Statement explicit arglist - [ ] SQL Read Table Review (comments requested on any work that should be done here) - [ ] Row Reader Review (comments requested on any work that should be done here) -- [ ] Prepared Query Review (comments requested on any work that should be done here) -- [ ] Reading large bytea column over ssl connection errors have been reported. Postgresql does not - have a chunk API so the network is handling the content as a whole. -- [ ] Alter system (postgresql 9.4) - [ ] Allow parameters to be passed as binary to postgresql ## Connections/Reconnections and Transactions diff --git a/cl-postgres/protocol.lisp b/cl-postgres/protocol.lisp index b2baf36..19b090b 100644 --- a/cl-postgres/protocol.lisp +++ b/cl-postgres/protocol.lisp @@ -184,7 +184,7 @@ be matched against it." (setf socket (funcall make-ssl-stream socket :key *ssl-key-file* :certificate *ssl-certificate-file* - :verify (if verify + :verify (if verify :required nil) :hostname hostname))) @@ -208,9 +208,14 @@ a condition." (client-initial-response nil) (expected-server-signature nil)) (unless (eq use-ssl :no) - (setf socket (initiate-ssl socket (member use-ssl '(:require :yes :full)) - (member use-ssl '(:yes :full)) - (if (eq use-ssl :full) hostname)))) + (if (eq use-ssl :try) + (let ((old-socket socket) + (new-socket (initiate-ssl socket nil nil nil))) + (if new-socket (setf socket new-socket) + (setf socket old-socket))) + (setf socket (initiate-ssl socket (member use-ssl '(:require :yes :full)) + (member use-ssl '(:yes :full)) + (if (eq use-ssl :full) hostname))))) (startup-message socket user database) (force-output socket) (labels ((init-gss-msg (in-buffer) @@ -271,34 +276,27 @@ CL-GSS package is loaded.")) (ecase type (0 (return)) (2 (error 'database-error - :message "Unsupported Kerberos -authentication requested.")) + :message "Unsupported Kerberos authentication requested.")) (3 (unless password - (error "Server requested plain-password -authentication, but no password was given.")) + (error "Server requested plain-password authentication, but no password was given.")) (plain-password-message socket password) (force-output socket)) (4 (error 'database-error - :message "Unsupported crypt -authentication requested.")) + :message "Unsupported crypt authentication requested.")) (5 (unless password - (error "Server requested md5-password -authentication, but no password was given.")) + (error "Server requested md5-password authentication, but no password was given.")) (md5-password-message socket password user (read-bytes socket 4)) (force-output socket)) (6 (error 'database-error - :message "Unsupported SCM -authentication requested.")) + :message "Unsupported SCM authentication requested.")) (7 (when gss-context (error 'database-error - :message "Got GSS init message when -a context was already established")) + :message "Got GSS init message when a context was already established")) (init-gss-msg nil)) (8 (unless gss-context (error 'database-error - :message "Got GSS continuation -message without a context")) + :message "Got GSS continuation message without a context")) (init-gss-msg (read-bytes socket (- size 4)))) (9 ) ; auth_required_sspi or auth_req_sspi sspi ;negotiate without wrap() see postgresql diff --git a/doc/postmodern.html b/doc/postmodern.html index 24925fc..21d3ce8 100644 --- a/doc/postmodern.html +++ b/doc/postmodern.html @@ -1,7 +1,7 @@ - + Postmodern Reference Manual @@ -285,7 +285,7 @@

Table of Contents

  • macro with-transaction ((&optional name isolation-level) &body body)
  • function commit-transaction (transaction)
  • function abort-transaction (transaction)
    • -
  • function rollback-transaction (transaction)
    • +
  • function rollback-transaction (transaction)
  • macro with-savepoint (name &body body)
  • function release-savepoint (savepoint)
  • function rollback-savepoint (savepoint)
    • @@ -328,11 +328,11 @@

    Table of Contents

  • Out of Sync Dao Objects
  • method dao-keys (class)
  • method dao-keys (dao)
    • -
  • method find-primary-key-column
    • +
  • method find-primary-key-column
  • method dao-exists-p (dao)
  • method make-dao (type &rest args &key &allow-other-keys)
    • -
  • method fetch-defaults (dao)
    • -
  • method find-primary-key-column (class)
    • +
  • method fetch-defaults (dao)
    • +
  • method find-primary-key-column (class)
  • macro define-dao-finalization (((dao-name class) &rest keyword-args) &body body)
  • method get-dao (type &rest keys)
  • macro select-dao (type &optional (test t) &rest sort)
    • @@ -388,6 +388,7 @@

    Table of Contents

  • Database Information
  • Sequences @@ -468,13 +470,16 @@

    Table of Contents

  • function table-size (table-name)
  • function table-description (name &optional schema-name)
  • function table-description-plus (table-name)
    • +
  • function table-description-menu (table-name &key char-max-length data-type-length
    • +
  • function list-check-constraints (table-name)
  • function list-columns (table-name)
  • function list-columns-with-types (table-name)
  • function column-exists-p (table-name column-name &optional schema-name)
  • function get-table-oid (table-name &optional schema-name)
  • function get-table-comment (table-name &optional schema-name)
    • -
  • function rename-table (old-name new-name)
    • -
  • function rename-column (table-name old-name new-name)
    • +
  • function get-column-comments (database schema table)
    • +
  • function rename-table (old-name new-name)
    • +
  • function rename-column (table-name old-name new-name)
  • Tablespaces @@ -560,12 +565,12 @@

    Table of Contents

    operation that encountered to the error.

    -
    -

    Connecting

    +
    +

    Connecting

    -
    -

    class database-connection

    +
    +

    class database-connection

    Representation of a database connection. Contains login information in order to @@ -574,8 +579,8 @@

    -

    function connect (database user-name password host &key (port 5432) pooled-p use-ssl)

    +
    +

    function connect (database user-name password host &key (port 5432) pooled-p use-ssl)

    → database-connection @@ -602,8 +607,8 @@

    -

    variable default-use-ssl

    +
    +

    variable default-use-ssl

    The default for connect's use-ssl argument. @@ -617,8 +622,8 @@

    -

    method disconnect (database-connection)

    +
    +

    method disconnect (database-connection)

    Disconnects a normal database connection, or moves a pooled connection into the @@ -627,8 +632,8 @@

    -

    function connected-p (database-connection)

    +
    +

    function connected-p (database-connection)

    → boolean @@ -641,8 +646,8 @@

    -

    method reconnect (database-connection)

    +
    +

    method reconnect (database-connection)

    Reconnect a disconnected database connection. This is not allowed for pooled @@ -652,8 +657,8 @@

    -

    variable database

    +
    +

    variable database

    Special variable holding the current database connection information. Most @@ -663,8 +668,8 @@

    -

    macro with-connection (spec &body body)

    +
    +

    macro with-connection (spec &body body)

    Evaluates the body with database bound to a connection as specified by spec, @@ -673,8 +678,8 @@

    -

    macro call-with-connection (spec thunk)

    +
    +

    macro call-with-connection (spec thunk)

    The functional backend to with-connection. Binds database to a new connection @@ -685,8 +690,8 @@

    -

    function connect-toplevel (database user-name password host &key (port 5432))

    +
    +

    function connect-toplevel (database user-name password host &key (port 5432))

    Bind the database to a new connection. Use this if you only need one @@ -695,8 +700,8 @@

    -

    function disconnect-toplevel ()

    +
    +

    function disconnect-toplevel ()

    Disconnect the database. @@ -704,8 +709,8 @@

    -

    function clear-connection-pool ()

    +
    +

    function clear-connection-pool ()

    Disconnect and remove all connections from the connection pools. @@ -713,8 +718,8 @@

    -

    variable max-pool-size

    +
    +

    variable max-pool-size

    Set the maximum amount of connections kept in a single connection pool, where a @@ -724,8 +729,8 @@

    -

    function list-connections ()

    +
    +

    function list-connections ()

    → list @@ -738,12 +743,12 @@

    -

    Querying

    +
    +

    Querying

    -
    -

    macro query (query &rest args/format)

    +
    +

    macro query (query &rest args/format)

    → result @@ -863,9 +868,9 @@

    -

    Default

    -
    +
    +

    Default

    +

    The default is :lists

    @@ -876,9 +881,9 @@

    Default

    -
    -

    Single

    -
    +
    +

    Single

    +

    Returns a single field. Will throw an error if the queries returns more than one field or more than one row

    @@ -889,9 +894,9 @@

    Single

    -
    -

    List

    -
    +
    +

    List

    +

    Returns a list containing the selected fields. Will throw an error if the query returns more than one row

    @@ -902,9 +907,9 @@

    List

    -
    -

    Lists

    -
    +
    +

    Lists

    +

    This is the default

    @@ -915,9 +920,9 @@

    Lists

    -
    -

    Alist

    -
    +
    +

    Alist

    +

    Returns an alist containing the field name as a keyword and the selected fields. Will throw an error if the query returns more than one row.

    @@ -928,9 +933,9 @@

    Alist

    -
    -

    Str-alist

    -
    +
    +

    Str-alist

    +

    Returns an alist containing the field name as a lower case string and the selected fields. Will throw an error if the query returns more than one row.

    @@ -942,9 +947,9 @@

    Str-alist

    -
    -

    Alists

    -
    +
    +

    Alists

    +

    Returns a list of alists containing the field name as a keyword and the selected fields.

    @@ -956,9 +961,9 @@

    Alists

    -
    -

    Str-alists

    -
    +
    +

    Str-alists

    +

    Returns a list of alists containing the field name as a lower case string and the selected fields.

    @@ -970,9 +975,9 @@

    Str-alists

    -
    -

    Plist

    -
    +
    +

    Plist

    +

    Returns a plist containing the field name as a keyword and the selected fields. Will throw an error if the query returns more than one row.

    @@ -983,9 +988,9 @@

    Plist

    -
    -

    Plists

    -
    +
    +

    Plists

    +

    Returns a list of plists containing the field name as a keyword and the selected fields.

    @@ -996,9 +1001,9 @@

    Plists

    -
    -

    Array-hash

    -
    +
    +

    Array-hash

    +

    Returns a vector of hashtables where each hash table is a returned row from the query with field name as the key expressed as a lower case string.

    @@ -1016,9 +1021,9 @@

    Array-hash

    -
    -

    Dao

    -
    +
    +

    Dao

    +

    Returns a list of daos of the type specified

    @@ -1032,9 +1037,9 @@

    Dao

    -
    -

    Column

    -
    +
    +

    Column

    +

    Returns a list of field values of a single field. Will throw an error if more than one field is selected

    @@ -1048,9 +1053,9 @@

    Column

    -
    -

    Json-strs

    -
    +
    +

    Json-strs

    +

    Return a list of strings where the row returned is a json object expressed as a string

    @@ -1088,9 +1093,9 @@

    Json-strs

    -
    -

    Json-str

    -
    +
    +

    Json-str

    +

    Return a single string where the row returned is a json object expressed as a string

    @@ -1105,9 +1110,9 @@

    Json-str

    -
    -

    Json-array-str

    -
    +
    +

    Json-array-str

    +

    Return a string containing a json array, each element in the array is a selected row expressed as a json object

    @@ -1121,9 +1126,9 @@

    Json-array-str

    -
    -

    Second value returned

    -
    +
    +

    Second value returned

    +

    If the database returns information about the amount rows that were affected, such as with updating or deleting queries, this is returned as a second value. @@ -1132,8 +1137,8 @@

    Second value returned

    -
    -

    macro execute (query &rest args)

    +
    +

    macro execute (query &rest args)

    Execute a query, ignore the results. So, in effect, Like a query called with @@ -1144,8 +1149,8 @@

    -

    macro doquery (query (&rest names) &body body)

    +
    +

    macro doquery (query (&rest names) &body body)

    Execute the given query (a string or a list starting with a keyword), iterating @@ -1165,8 +1170,8 @@

    -

    macro prepare (query &optional (format :rows))

    +
    +

    macro prepare (query &optional (format :rows))

    → function @@ -1203,8 +1208,8 @@

    -

    macro defprepared (name query &optional (format :rows))

    +
    +

    macro defprepared (name query &optional (format :rows))

    → function @@ -1218,8 +1223,8 @@

    -

    macro defprepared-with-names (name (&rest args) (query &rest query-args) &optional (format :rows))

    +
    +

    macro defprepared-with-names (name (&rest args) (query &rest query-args) &optional (format :rows))

    Like defprepared, but allows to specify names of the function arguments in a @@ -1237,8 +1242,8 @@

    -

    macro with-transaction ((&optional name isolation-level) &body body)

    +
    +

    macro with-transaction ((&optional name isolation-level) &body body)

    Execute the given body within a database transaction, committing it when the @@ -1292,8 +1297,8 @@

    -

    function commit-transaction (transaction)

    +
    +

    function commit-transaction (transaction)

    Immediately commit an open transaction. @@ -1301,8 +1306,8 @@

    -

    function abort-transaction (transaction)

    +
    +

    function abort-transaction (transaction)

    Roll back the given transaction, but the transaction @@ -1316,9 +1321,9 @@

    -

    function rollback-transaction (transaction)

    -
    +
    +

    function rollback-transaction (transaction)

    +

    Roll back the given transaction, but the transaction block is still active. Thus calling abort-transaction in the middle of a @@ -1329,8 +1334,8 @@

    function rollback-transaction (transaction)

    -
    -

    macro with-savepoint (name &body body)

    +
    +

    macro with-savepoint (name &body body)

    Can only be used within a transaction. Establishes a savepoint with the given @@ -1389,8 +1394,8 @@

    -

    function release-savepoint (savepoint)

    +
    +

    function release-savepoint (savepoint)

    Immediately release a savepoint, commiting its results. @@ -1398,8 +1403,8 @@

    -

    function rollback-savepoint (savepoint)

    +
    +

    function rollback-savepoint (savepoint)

    Immediately roll back a savepoint, aborting the results. @@ -1407,8 +1412,8 @@

    -

    method commit-hooks (transaction-or-savepoint), setf (commit-hooks transaction-or-savepoint)

    +
    +

    method commit-hooks (transaction-or-savepoint), setf (commit-hooks transaction-or-savepoint)

    An accessor for the transaction or savepoint's list of commit hooks, each of @@ -1418,8 +1423,8 @@

    -

    function abort-hooks (transaction-or-savepoint), setf (abort-hooks transaction-or-savepoint)

    +
    +

    function abort-hooks (transaction-or-savepoint), setf (abort-hooks transaction-or-savepoint)

    An accessor for the transaction or savepoint's list of abort hooks, each of @@ -1431,8 +1436,8 @@

    -

    variable isolation-level

    +
    +

    variable isolation-level

    The transaction isolation level currently in use. Defaults to :read-committed-rw @@ -1453,8 +1458,8 @@

    -

    macro with-logical-transaction ((&optional name isolation-level) &body body)

    +
    +

    macro with-logical-transaction ((&optional name isolation-level) &body body)

    Executes body within a with-transaction form if no transaction is currently @@ -1507,8 +1512,8 @@

    -

    function abort-logical-transaction (transaction-or-savepoint)

    +
    +

    function abort-logical-transaction (transaction-or-savepoint)

    Roll back the given logical transaction, regardless of whether it is an actual @@ -1517,8 +1522,8 @@

    -

    function commit-logical-transaction (transaction-or-savepoint)

    +
    +

    function commit-logical-transaction (transaction-or-savepoint)

    Commit the given logical transaction, regardless of whether it is an actual @@ -1527,8 +1532,8 @@

    -

    variable current-logical-transaction

    +
    +

    variable current-logical-transaction

    This is bound to the current transaction-handle or savepoint-handle instance @@ -1537,8 +1542,8 @@

    -

    macro ensure-transaction (&body body)

    +
    +

    macro ensure-transaction (&body body)

    Ensures that body is executed within a transaction, but does not begin a new @@ -1547,8 +1552,8 @@

    -

    macro ensure-transaction-with-isolation-level (isolation-level &body body)

    +
    +

    macro ensure-transaction-with-isolation-level (isolation-level &body body)

    Executes body within a with-transaction form if and only if no transaction is @@ -1559,13 +1564,13 @@

    -

    Helper functions for Prepared Statements

    +
    +

    Helper functions for Prepared Statements

    -
    -

    defparameter allow-overwriting-prepared-statements

    +
    +

    defparameter allow-overwriting-prepared-statements

    When set to t, ensured-prepared will overwrite prepared statements having the @@ -1575,8 +1580,8 @@

    -

    function prepared-statement-exists-p (name)

    +
    +

    function prepared-statement-exists-p (name)

    → boolean @@ -1586,8 +1591,8 @@

    -

    function list-prepared-statements (&optional (names-only nil))

    +
    +

    function list-prepared-statements (&optional (names-only nil))

    → list @@ -1601,8 +1606,8 @@

    -

    function drop-prepared-statement (statement-name &key (location :both) (database database))

    +
    +

    function drop-prepared-statement (statement-name &key (location :both) (database database))

    The statement name can be a string or quoted symbol. @@ -1634,8 +1639,8 @@

    -

    function list-postmodern-prepared-statements (&optional (names-only nil))

    +
    +

    function list-postmodern-prepared-statements (&optional (names-only nil))

    → list @@ -1657,8 +1662,8 @@

    -

    function find-postgresql-prepared-statement (name)

    +
    +

    function find-postgresql-prepared-statement (name)

    → string @@ -1671,8 +1676,8 @@

    -

    function find-postmodern-prepared-statement (name)

    +
    +

    function find-postmodern-prepared-statement (name)

    → string @@ -1686,8 +1691,8 @@

    -

    function reset-prepared-statement (condition)

    +
    +

    function reset-prepared-statement (condition)

    → restart @@ -1702,8 +1707,8 @@

    -

    function get-pid ()

    +
    +

    function get-pid ()

    → integer @@ -1715,8 +1720,8 @@

    -

    function get-pid-from-postmodern ()

    +
    +

    function get-pid-from-postmodern ()

    → integer @@ -1729,8 +1734,8 @@

    -

    function cancel-backend (pid)

    +
    +

    function cancel-backend (pid)

    Polite way of terminating a query at the database (as opposed to calling @@ -1740,8 +1745,8 @@

    -

    function terminate-backend (pid)

    +
    +

    function terminate-backend (pid)

    Less polite way of terminating at the database (as opposed to calling @@ -1750,13 +1755,13 @@

    -

    Database Management

    +
    +

    Database Management

    -
    -

    function create-database (database-name &key (encoding "UTF8") (connection-limit -1) owner limit-public-access comment collation template)

    +
    +

    function create-database (database-name &key (encoding "UTF8") (connection-limit -1) owner limit-public-access comment collation template)

    Creates a basic database. Besides the obvious database-name parameter, you @@ -1778,8 +1783,8 @@

    function cr

    -
    -

    function drop-database (database)

    +
    +

    function drop-database (database)

    Drop the specified database. The database parameter can be a string or a @@ -1790,8 +1795,8 @@

    function drop-database (data

    -
    -

    Database access objects

    +
    +

    Database access objects

    Postmodern contains a simple system for defining CLOS classes that represent @@ -1802,8 +1807,8 @@

    -

    metaclass dao-class

    +
    +

    metaclass dao-class

    You can work directly with the database or you can use a simple @@ -1987,8 +1992,8 @@

    -

    Out of Sync Dao Objects

    +
    +

    Out of Sync Dao Objects

    What Happens when dao classes are out of sync with the database table? @@ -2231,8 +2236,8 @@

    Out of Sync

    -
    -

    method dao-keys (class)

    +
    +

    method dao-keys (class)

    → list @@ -2256,8 +2261,8 @@

    -

    method dao-keys (dao)

    +
    +

    method dao-keys (dao)

    → list @@ -2278,9 +2283,9 @@

    -

    method find-primary-key-column

    -
    +
    +

    method find-primary-key-column

    +

    → symbol

    @@ -2292,8 +2297,8 @@

    method find-primary-key-column

    -
    -

    method dao-exists-p (dao)

    +
    +

    method dao-exists-p (dao)

    → boolean @@ -2307,8 +2312,8 @@

    -

    method make-dao (type &rest args &key &allow-other-keys)

    +
    +

    method make-dao (type &rest args &key &allow-other-keys)

    → dao @@ -2321,9 +2326,9 @@

    -

    method fetch-defaults (dao)

    -
    +
    +

    method fetch-defaults (dao)

    +

    → dao if there were unbound slots with default values, otherwise nil

    @@ -2341,9 +2346,9 @@

    method fetch-defaults (dao)

    -
    -

    method find-primary-key-column (class)

    -
    +
    +

    method find-primary-key-column (class)

    +

    → symbol

    @@ -2356,8 +2361,8 @@

    method find-primary-key-column (class)

    -
    -

    macro define-dao-finalization (((dao-name class) &rest keyword-args) &body body)

    +
    +

    macro define-dao-finalization (((dao-name class) &rest keyword-args) &body body)

    Create an :around-method for make-dao. The body is executed in a lexical @@ -2369,8 +2374,8 @@

    -

    method get-dao (type &rest keys)

    +
    +

    method get-dao (type &rest keys)

    → dao @@ -2408,8 +2413,8 @@

    -

    macro select-dao (type &optional (test t) &rest sort)

    +
    +

    macro select-dao (type &optional (test t) &rest sort)

    → list @@ -2461,8 +2466,8 @@

    -

    macro do-select-dao (((type type-var) &optional (test t) &rest sort) &body body)

    +
    +

    macro do-select-dao (((type type-var) &optional (test t) &rest sort) &body body)

    Like select-dao, but iterates over the results rather than returning them. @@ -2481,8 +2486,8 @@

    -

    macro query-dao (type query &rest args)

    +
    +

    macro query-dao (type query &rest args)

    → list @@ -2498,8 +2503,8 @@

    -

    function do-query-dao (((type type-var) query &rest args) &body body)

    +
    +

    function do-query-dao (((type type-var) query &rest args) &body body)

    → list @@ -2521,8 +2526,8 @@

    -

    variable ignore-unknown-columns

    +
    +

    variable ignore-unknown-columns

    Normally, when get-dao, select-dao, or query-dao finds a column in the database @@ -2532,8 +2537,8 @@

    -

    method insert-dao (dao)

    +
    +

    method insert-dao (dao)

    → dao @@ -2548,8 +2553,8 @@

    -

    method update-dao (dao)

    +
    +

    method update-dao (dao)

    → dao @@ -2563,8 +2568,8 @@

    -

    function save-dao (dao)

    +
    +

    function save-dao (dao)

    → boolean @@ -2596,8 +2601,8 @@

    -

    function save-dao/transaction (dao)

    +
    +

    function save-dao/transaction (dao)

    → boolean @@ -2628,8 +2633,8 @@

    -

    method upsert-dao (dao)

    +
    +

    method upsert-dao (dao)

    → dao @@ -2685,8 +2690,8 @@

    -

    method delete-dao (dao)

    +
    +

    method delete-dao (dao)

    Delete the given dao from the database. @@ -2694,8 +2699,8 @@

    -

    function dao-table-name (class)

    +
    +

    function dao-table-name (class)

    → string @@ -2708,8 +2713,8 @@

    -

    function dao-table-definition (class)

    +
    +

    function dao-table-definition (class)

    → string @@ -2724,8 +2729,8 @@

    -

    macro with-column-writers ((&rest writers) &body body)

    +
    +

    macro with-column-writers ((&rest writers) &body body)

    Provides control over the way get-dao, select-dao, and query-dao read values @@ -2749,8 +2754,8 @@

    -

    Table definition and creation

    +
    +

    Table definition and creation

    It can be useful to have the SQL statements needed to build an application's @@ -2761,8 +2766,8 @@

    -

    macro deftable (name &body definition)

    +
    +

    macro deftable (name &body definition)

    Define a table. name can be either a symbol or a (symbol string) list. In the @@ -2776,8 +2781,8 @@

    -

    variable table-name

    +
    +

    variable table-name

    Used inside deftable to find the name of the table being defined. @@ -2785,8 +2790,8 @@

    -

    variable table-symbol

    +
    +

    variable table-symbol

    Used inside deftable to find the symbol naming the table being defined. @@ -2794,8 +2799,8 @@

    -

    function !dao-def ()

    +
    +

    function !dao-def ()

    Should only be used inside a deftable form. Define this table using the @@ -2805,8 +2810,8 @@

    -

    function !index (&rest columns), !unique-index (&rest columns)

    +
    +

    function !index (&rest columns), !unique-index (&rest columns)

    Used inside a deftable form. Define an index on the table being defined. The @@ -2815,8 +2820,8 @@

    -

    function !foreign (target fields &rest target-fields/on-delete/on-update/deferrable/initially-deferred)

    +
    +

    function !foreign (target fields &rest target-fields/on-delete/on-update/deferrable/initially-deferred)

    Used insde a deftable form. Add a foreign key to the table being defined. @@ -2839,8 +2844,8 @@

    -

    function !unique (target-fields &key deferrable initially-deferred)

    +
    +

    function !unique (target-fields &key deferrable initially-deferred)

    Constrains one or more columns to only contain unique (combinations of) values, @@ -2849,8 +2854,8 @@

    -

    function create-table (symbol)

    +
    +

    function create-table (symbol)

    Takes the name of a dao-class and creates the table identified by symbol by @@ -2859,8 +2864,8 @@

    -

    function create-all-tables ()

    +
    +

    function create-all-tables ()

    Creates all defined tables. @@ -2868,8 +2873,8 @@

    -

    function create-package-tables (package)

    +
    +

    function create-package-tables (package)

    Creates all tables identified by symbols interned in the given package. @@ -2877,8 +2882,8 @@

    -

    variables table-name, table-symbol

    +
    +

    variables table-name, table-symbol

    Used inside deftable to find the name of the table being defined. @@ -2890,8 +2895,8 @@

    -

    function drop-table (table-name &key if-exists cascade)

    +
    +

    function drop-table (table-name &key if-exists cascade)

    If a table exists, drop a table. Available additional key parameters @@ -2900,8 +2905,8 @@

    -

    Introduction to Multi-table dao class objects

    +
    +

    Introduction to Multi-table dao class objects

    Postmodern's dao-class objects are not required to be tied down to a specific @@ -2980,8 +2985,8 @@

    -

    Simple Version

    +
    +

    Simple Version

    Lets start by declaring our classes and we will use the deftable make to create @@ -3066,8 +3071,8 @@

    -

    Less Simple Version

    +
    +

    Less Simple Version

    In the -n version, we are going to use the id columns as the primary key. @@ -3437,8 +3442,8 @@

    -

    Roles

    +
    +

    Roles

    Every connection is specific to a particular database. However, creating roles @@ -3484,8 +3489,8 @@

    Roles

    -
    -

    function role-exists-p (role-name)

    +
    +

    function role-exists-p (role-name)

    → boolean @@ -3496,8 +3501,8 @@

    function ro

    -
    -

    function create-role

    +
    +

    function create-role

    (name password &key (base-role :readonly) (schema :public) @@ -3558,8 +3563,8 @@

    function cr

    -
    -

    function drop-role (role-name &optional (new-owner "postgres") (database :all))

    +
    +

    function drop-role (role-name &optional (new-owner "postgres") (database :all))

    → boolean @@ -3587,8 +3592,8 @@

    function dr

    -
    -

    function alter-role-search-path (role search-path)

    +
    +

    function alter-role-search-path (role search-path)

    Changes the priority of where a role looks for tables (which schema first, @@ -3597,8 +3602,8 @@

    function al

    -
    -

    function change-password (role password &optional expiration-date)

    +
    +

    function change-password (role password &optional expiration-date)

    Alters a role's password. If the optional expiration-date parameter is provided, @@ -3610,8 +3615,8 @@

    function ch

    -
    -

    function grant-role-permissions (role-type name &key (schema :public) (tables :all) (databases :all))

    +
    +

    function grant-role-permissions (role-type name &key (schema :public) (tables :all) (databases :all))

    Grant-role-permissions assumes that a role has already been created, but @@ -3640,8 +3645,8 @@

    function gr

    -
    -

    function grant-readonly-permissions (schema-name role-name &optional (table-name nil))

    +
    +

    function grant-readonly-permissions (schema-name role-name &optional (table-name nil))

    Grants select privileges to a role for the named schema. If the optional @@ -3653,8 +3658,8 @@

    function gr

    -
    -

    function grant-editor-permissions (schema-name role-name &optional (table-name nil))

    +
    +

    function grant-editor-permissions (schema-name role-name &optional (table-name nil))

    Grants select, insert, update and delete privileges to a role for the named @@ -3666,8 +3671,8 @@

    function gr

    -
    -

    function grant-admin-permissions (schema-name role-name &optional (table-name nil))

    +
    +

    function grant-admin-permissions (schema-name role-name &optional (table-name nil))

    Grants all privileges to a role for the named schema. If the optional table-name @@ -3675,8 +3680,8 @@

    function gr

    -
    -

    function revoke-all-on-table (table-name role-name)

    +
    +

    function revoke-all-on-table (table-name role-name)

    Takes a table-name which could be a string, symbol or list of strings or @@ -3687,8 +3692,8 @@

    function re

    -
    -

    function list-role-accessible-databases (role-name)

    +
    +

    function list-role-accessible-databases (role-name)

    → list @@ -3699,8 +3704,8 @@

    function li

    -
    -

    function list-roles (&optional (lt nil))

    +
    +

    function list-roles (&optional (lt nil))

    → list @@ -3715,8 +3720,8 @@

    -

    function list-role-permissions (&optional role)

    +
    +

    function list-role-permissions (&optional role)

    → list @@ -3732,12 +3737,12 @@

    function li

    -
    -

    Database Information

    +
    +

    Database Information

    -
    -

    function add-comment (type name comment &optional (second-name ""))

    +
    +

    function add-comment (type name comment &optional (second-name ""))

    Attempts to add a comment to a particular database object. The first parameter is a keyword for the type of database object. The second parameter is the name of the object. The third parameter is the comment itself. Some objects require an additional identifier. The names can be strings or symbols. @@ -3766,20 +3771,36 @@

    function ad

    -
    -

    function get-database-comment (database-name)

    +
    +

    find-comments (type identifier)

    +
    +

    +Returns the comments attached to a particular database object. The allowed +types are :database :schema :table :columns (all the columns in a table) +:column (for a single column). +

    + +

    +An example would be (find-comments :table 's2.employees) where the table employees +is in the s2 schema. +

    +
    +
    +
    +

    function get-database-comment (database-name)

    → string

    -Returns the comment, if any, attached to a database. +Returns the comment, if any, attached to a database. See also get-schema-comment, +get-column-comments and get-database-comment.

    -
    -

    function postgresql-version ()

    +
    +

    function postgresql-version ()

    → string @@ -3794,8 +3815,8 @@

    -

    function database-version ()

    +
    +

    function database-version ()

    → string @@ -3816,8 +3837,8 @@

    -

    function current-database ()

    +
    +

    function current-database ()

    → string @@ -3829,8 +3850,8 @@

    -

    function database-exists-p (database-name)

    +
    +

    function database-exists-p (database-name)

    → boolean @@ -3842,8 +3863,8 @@

    -

    function database-size (&optional database-name)

    +
    +

    function database-size (&optional database-name)

    → list @@ -3857,8 +3878,8 @@

    -

    function num-records-in-database ()

    +
    +

    function num-records-in-database ()

    → list @@ -3871,8 +3892,8 @@

    -

    function list-databases (&key (order-by-size nil) (size t))

    +
    +

    function list-databases (&key (order-by-size nil) (size t))

    → list @@ -3888,8 +3909,8 @@

    -

    function list-database-functions ()

    +
    +

    function list-database-functions ()

    → list @@ -3906,8 +3927,8 @@

    -

    function list-database-users ()

    +
    +

    function list-database-users ()

    → list @@ -3918,8 +3939,8 @@

    -

    function list-database-access-rights (&optional database-name)

    +
    +

    function list-database-access-rights (&optional database-name)

    → list @@ -3935,8 +3956,8 @@

    function li

    -
    -

    function list-available-types ()

    +
    +

    function list-available-types ()

    → list @@ -3950,8 +3971,8 @@

    -

    function list-available-collations ()

    +
    +

    function list-available-collations ()

    → list @@ -3965,8 +3986,8 @@

    function li

    -
    -

    function list-available-extensions ()

    +
    +

    function list-available-extensions ()

    → list @@ -3978,8 +3999,8 @@

    -

    function list-installed-extensions ()

    +
    +

    function list-installed-extensions ()

    → list @@ -3991,8 +4012,8 @@

    -

    function list-templates ()

    +
    +

    function list-templates ()

    → list @@ -4003,8 +4024,8 @@

    function li

    -
    -

    function change-toplevel-database (new-database user password host)

    +
    +

    function change-toplevel-database (new-database user password host)

    → string @@ -4018,8 +4039,8 @@

    -

    function cache-hit-ratio ()

    +
    +

    function cache-hit-ratio ()

    → list @@ -4034,8 +4055,8 @@

    -

    function bloat-measurement ()

    +
    +

    function bloat-measurement ()

    → list @@ -4049,8 +4070,8 @@

    -

    function unused-indexes ()

    +
    +

    function unused-indexes ()

    → list @@ -4063,8 +4084,8 @@

    -

    function check-query-performance (&optional (ob nil) (num-calls 100) (limit 20))

    +
    +

    function check-query-performance (&optional (ob nil) (num-calls 100) (limit 20))

    → list @@ -4091,12 +4112,12 @@

    -

    Constraints

    +
    +

    Constraints

    -
    -

    function list-unique-or-primary-constraints (table-name)

    +
    +

    function list-unique-or-primary-constraints (table-name)

    → list @@ -4109,8 +4130,8 @@

    -

    function list-all-constraints (table-name)

    +
    +

    function list-all-constraints (table-name)

    → list @@ -4124,8 +4145,8 @@

    -

    function describe-constraint (table-name constraint-name)

    +
    +

    function describe-constraint (table-name constraint-name)

    → list @@ -4138,8 +4159,8 @@

    -

    function describe-foreign-key-constraints ()

    +
    +

    function describe-foreign-key-constraints ()

    → list @@ -4151,12 +4172,12 @@

    -

    Indexes/Indices

    +
    +

    Indexes/Indices

    -
    -

    function create-index (name &key unique if-not-exists concurrently on using fields)

    +
    +

    function create-index (name &key unique if-not-exists concurrently on using fields)

    Create an index. Slightly less sophisticated than the query version because it @@ -4165,8 +4186,8 @@

    -

    function drop-index (name &key concurrently if-exists cascade)

    +
    +

    function drop-index (name &key concurrently if-exists cascade)

    Drop an index. Available keys are :concurrently, :if-exists, and :cascade. @@ -4174,8 +4195,8 @@

    -

    function list-indices (&optional strings-p)

    +
    +

    function list-indices (&optional strings-p)

    → list @@ -4188,8 +4209,8 @@

    -

    function list-table-indices (table-name &optional strings-p)

    +
    +

    function list-table-indices (table-name &optional strings-p)

    → list @@ -4202,8 +4223,8 @@

    -

    function index-exists-p (name)

    +
    +

    function index-exists-p (name)

    → boolean @@ -4216,8 +4237,8 @@

    -

    function list-indexed-column-and-attributes (table-name)

    +
    +

    function list-indexed-column-and-attributes (table-name)

    → list @@ -4230,8 +4251,8 @@

    -

    function list-index-definitions (table-name)

    +
    +

    function list-index-definitions (table-name)

    → list @@ -4245,12 +4266,12 @@

    -

    Keys

    +
    +

    Keys

    -
    -

    function find-primary-key-info (table-name &optional (just-key nil))

    +
    +

    function find-primary-key-info (table-name &optional (just-key nil))

    → list @@ -4271,8 +4292,8 @@

    -

    function list-foreign-keys (table-name)

    +
    +

    function list-foreign-keys (table-name)

    → list @@ -4287,8 +4308,8 @@

    -

    Schema/Schemata

    +
    +

    Schema/Schemata

    Schema allow you to separate tables into differnet name spaces. In different @@ -4300,8 +4321,8 @@

    -

    macro with-schema ((namespace &key :strict t :if-not-exist :create :drop-after) &body body)

    +
    +

    macro with-schema ((namespace &key :strict t :if-not-exist :create :drop-after) &body body)

    A macro to set the schema search path (namespace) of the postgresql database to @@ -4346,8 +4367,8 @@

    -

    function list-schemata ()

    +
    +

    function list-schemata ()

    → list @@ -4371,8 +4392,8 @@

    -

    function list-schemas ()

    +
    +

    function list-schemas ()

    → list @@ -4384,8 +4405,8 @@

    -

    function schema-exists-p (schema)

    +
    +

    function schema-exists-p (schema)

    → boolean @@ -4398,8 +4419,8 @@

    -

    function create-schema (schema)

    +
    +

    function create-schema (schema)

    Creates a new schema. Raises an error if the schema is already exists. @@ -4407,8 +4428,8 @@

    -

    function drop-schema (schema &key (if-exists nil) (cascade nil))

    +
    +

    function drop-schema (schema &key (if-exists nil) (cascade nil))

    Drops an existing database schema. Accepts :if-exists and/or :cascade arguments @@ -4418,8 +4439,8 @@

    -

    function get-search-path ()

    +
    +

    function get-search-path ()

    Returns the default schema search path for the current session. @@ -4427,8 +4448,8 @@

    -

    function set-search-path (path)

    +
    +

    function set-search-path (path)

    This changes the postgresql runtime parameter controlling what order schemas are @@ -4438,8 +4459,8 @@

    -

    function split-fully-qualified-tablename (name)

    +
    +

    function split-fully-qualified-tablename (name)

    → list @@ -4450,14 +4471,27 @@

    -

    Sequences

    +
    +

    function get-schema-comment (schema-name)

    +
    +

    +→ string +

    + +

    +Retrieves the comment, if any attached to the schema. See also get-schema-comment, +get-column-comments and get-database-comment. +

    +
    +
    +

    +
    +

    Sequences

    -
    -

    function create-sequence (name &key temp if-not-exists increment min-value max-value start cache)

    +
    +

    function create-sequence (name &key temp if-not-exists increment min-value max-value start cache)

    Create a sequence. Available additional key parameters @@ -4468,8 +4502,8 @@

    -

    function sequence-next (sequence)

    +
    +

    function sequence-next (sequence)

    → integer @@ -4483,8 +4517,8 @@

    -

    function drop-sequence (name &key if-exists cascade)

    +
    +

    function drop-sequence (name &key if-exists cascade)

    → list @@ -4497,8 +4531,8 @@

    -

    function list-sequences (&optional strings-p)

    +
    +

    function list-sequences (&optional strings-p)

    → list @@ -4511,8 +4545,8 @@

    -

    function sequence-exists-p (name)

    +
    +

    function sequence-exists-p (name)

    → boolean @@ -4526,12 +4560,12 @@

    -

    Tables

    +
    +

    Tables

    -
    -

    function list-tables (&optional strings-p)

    +
    +

    function list-tables (&optional strings-p)

    → list @@ -4545,8 +4579,8 @@

    -

    function list-all-tables (&optional (fully-qualified-names-only nil))

    +
    +

    function list-all-tables (&optional (fully-qualified-names-only nil))

    :ID: bd228cd6-3651-48ca-a9c5-a27737fbaacc @@ -4571,8 +4605,8 @@

    function li

    -
    -

    function list-tables-in-schema (&optional (schema-name "public") (strings-p nil))

    +
    +

    function list-tables-in-schema (&optional (schema-name "public") (strings-p nil))

    → list @@ -4587,8 +4621,8 @@

    -

    function list-table-sizes (&key (schema "public") (order-by-size nil) (size t))

    +
    +

    function list-table-sizes (&key (schema "public") (order-by-size nil) (size t))

    → list @@ -4607,8 +4641,8 @@

    -

    function table-exists-p (name)

    +
    +

    function table-exists-p (name)

    → boolean @@ -4626,8 +4660,8 @@

    -

    function table-size (table-name)

    +
    +

    function table-size (table-name)

    → list @@ -4640,8 +4674,8 @@

    -

    function table-description (name &optional schema-name)

    +
    +

    function table-description (name &optional schema-name)

    → list @@ -4661,8 +4695,8 @@

    -

    function table-description-plus (table-name)

    +
    +

    function table-description-plus (table-name)

    → list @@ -4682,8 +4716,115 @@

    -

    function list-columns (table-name)

    +
    +

    function table-description-menu (table-name &key char-max-length data-type-length

    +
    +

    + has-default default-value not-null + numeric-precision numeric-scale + storage primary primary-key-name + unique unique-key-name fkey fkey-name + fkey-col-id fkey-table fkey-local-col-id + identity generated collation + col-comments locally-defined inheritance-count + stat-collection) +→ list string list +

    + +

    +Takes a fully qualified table name which can be either a string or a symbol. +

    + +

    +Returns three values. +

    + +
      +
    1. A list of plists of each row's parameters. This will always
      2. +
    +

    +include :column-name and :data-type-name but all other parameters can be set or unset +and are set by default (set to t). +

    + +
      +
    1. The comment string attached to the table itself (if any).
      2. + +
    2. A list of the check constraints applied to the rows in the table. See documentation for
      3. +
    +

    +list-check-constraints for an example. +

    + +

    +The available keyword parameters are: +

    + +
      +
    • data-type-length (For a fixed-size type, typlen is the number of bytes in the internal representation of the type. But for a variable-length type, typlen is negative. -1 indicates a “varlena” type (one that has a length word), -2 indicates a null-terminated C string.)
      • +
    • char-max-length (Typically used for something like a varchar and shows the maximum length)
      • +
    • has-default (value T if this column has a default value and :NULL if not)
      • +
    • default-value (value is the default value as string. A default of 9.99 will still be a string)
      • +
    • not-null (value is T if the column must have a value or :NULL otherwise)
      • +
    • numeric-precision (value is the total number of digits for a numeric type if that precision was specified)
      • +
    • numeric-scale (value is the number of digits in the fraction part of a numeric type if that scale was specified)
      • +
    • storage (value is the storage setting for a column. Result can be plain, extended, main or external)
      • +
    • primary (value is T if the column is the primary key for the table, :NULL otherwise)
      • +
    • primary-key-name (value is the name of the primary-key itself, not the column, if the column is the primary key for the table, :NULL otherwise)
      • +
    • unique (value is T if the column is subject to a unique key, :NULL otherwise)
      • +
    • unique-key-name (value is the name of the unique-key itself, not the column, applied to the column, :NULL otherwise)
      • +
    • fkey (value is T if the column is a foreign key, :NULL otherwise)
      • +
    • fkey-name (value is the name of the foreign key, :NULL otherwise)
      • +
    • fkey-col-id (value is the column id of the foreign table used as the foreign key. Probably easier to use the Postmodern function list-foreign-keys if you are looking for the name of the columns)
      • +
    • fkey-table (value is the name of the foreign table, :NULL otherwise)
      • +
    • fkey-local-col-id (value is the column id of this column. Probably easier to use the Postmodern function list-foreign-keys if you are looking for the name of the columns involved in the foreign key)
      • +
    • identity (if the column is an identity column, the values can be 'generated always' or 'generated by default'. Otherwise :NULL)
      • +
    • generated (columns can be generated, if this column is generated and stored on disk, the value will be 'stored', otherwise :NULL)
      • +
    • collation (columns with collations which are not the default collation for the database will show that collation here, otherwise :NULL)
      • +
    • col-comments (value is any comment that has been applied to the column, :NULL otherwise)
      • +
    • locally-defined (value is T if locally defined. It might be both locally defined and inherited)
      • +
    • inheritance-count (the number of direct ancestors this column has inherited)
      • +
    • stat-collection (stat-collection returns the value of attstattarget which controls the level of detail of statistics accumulated for this column by ANALYZE. A zero value indicates that no statistics should be collected. A negative value says to use the system default statistics target. The exact meaning of positive values is data type-dependent. For scalar data types, attstattarget is both the target number of most common values to collect, and the target number of histogram bins to create. Attstorage is normally a copy of pg_type.typstorage of this column's type. For TOAST-able data types, this can be altered after column creation to control storage policy.)
      • +
    +
    +
    +
    +

    function list-check-constraints (table-name)

    +
    +

    +→ list +

    + +

    +Takes a fully qualified table name and returns a list of lists of check constraints +where each sublist has the form of (check-constraint-name check) +

    + +

    +Example: +

    + +
    +
    (query (:create-table 'employees2
+                      ((did :type (or integer db-null)
+                            :primary-key "generated by default as identity")
+                       (name :type (varchar 40) :check (:<> 'name ""))
+                       (birth-date :type date :check (:> 'birth-date "1900-01-01"))
+                       (start-date :type date :check (:> 'start-date 'birth-date))
+                       (salary :type numeric :check (:> 'salary 0)))))
+
+(list-check-constraints 'employees2)
+
+(("employees2_birth_date_check" "CHECK (birth_date > '1900-01-01'::date)")
+ ("employees2_check" "CHECK (start_date > birth_date)")
+ ("employees2_name_check" "CHECK (name::text <> ''::text)")
+ ("employees2_salary_check" "CHECK (salary > 0::numeric)"))
+
    +
    +
    +
    +
    +

    function list-columns (table-name)

    → list @@ -4698,8 +4839,8 @@

    -

    function list-columns-with-types (table-name)

    +
    +

    function list-columns-with-types (table-name)

    → list @@ -4715,8 +4856,8 @@

    -

    function column-exists-p (table-name column-name &optional schema-name)

    +
    +

    function column-exists-p (table-name column-name &optional schema-name)

    → boolean @@ -4731,8 +4872,8 @@

    -

    function get-table-oid (table-name &optional schema-name)

    +
    +

    function get-table-oid (table-name &optional schema-name)

    → integer @@ -4744,21 +4885,35 @@

    function ge

    -
    -

    function get-table-comment (table-name &optional schema-name)

    +
    +

    function get-table-comment (table-name &optional schema-name)

    +
    +

    +→ string +

    + +

    +Retrieves the comment, if any attached to the table. See also get-schema-comment, +get-column-comments and get-database-comment +

    +
    +
    +
    +

    function get-column-comments (database schema table)

    → string

    -Retrieves the comment, if any attached to the table. +Retrieves a list of lists of column names and the comments, if any, attached +to the columns of a table.

    -
    -

    function rename-table (old-name new-name)

    -
    +
    +

    function rename-table (old-name new-name)

    +

    → boolean

    @@ -4772,9 +4927,9 @@

    function rename-table (old-name new-name)

    -
    -

    function rename-column (table-name old-name new-name)

    -
    +
    +

    function rename-column (table-name old-name new-name)

    +

    → boolean

    @@ -4787,12 +4942,12 @@

    function rename-column (table-name old-name new-name)

    -
    -

    Tablespaces

    +
    +

    Tablespaces

    -
    -

    function list-tablespaces ()

    +
    +

    function list-tablespaces ()

    → list @@ -4828,12 +4983,12 @@

    -

    Triggers

    +
    +

    Triggers

    -
    -

    function describe-triggers ()

    +
    +

    function describe-triggers ()

    → list @@ -4844,8 +4999,8 @@

    -

    function list-triggers (&optional table-name)

    +
    +

    function list-triggers (&optional table-name)

    → list @@ -4862,8 +5017,8 @@

    -

    function list-detailed-triggers ()

    +
    +

    function list-detailed-triggers ()

    → list @@ -4872,12 +5027,12 @@

    -

    Views

    +
    +

    Views

    -
    -

    function list-views (&optional strings-p)

    +
    +

    function list-views (&optional strings-p)

    → list @@ -4890,8 +5045,8 @@

    -

    function view-exists-p (name)

    +
    +

    function view-exists-p (name)

    → boolean @@ -4904,8 +5059,8 @@

    -

    function describe-views (&optional (schema "public")

    +
    +

    function describe-views (&optional (schema "public")

    → list @@ -4920,12 +5075,12 @@

    -

    Miscellaneous Utility Functions

    +
    +

    Miscellaneous Utility Functions

    -
    -

    function coalesce (&rest arguments)

    +
    +

    function coalesce (&rest arguments)

    → value @@ -4939,8 +5094,8 @@

    -

    function execute-file (filename &optional (print nil))

    +
    +

    function execute-file (filename &optional (print nil))

    This function will execute sql queries stored in a file. Each sql statement in @@ -4968,8 +5123,8 @@

    -

    function num-records-in-database ()

    +
    +

    function num-records-in-database ()

    → list @@ -4981,8 +5136,8 @@

    function nu

    -
    -

    function postgres-array-string-to-list (str)

    +
    +

    function postgres-array-string-to-list (str)

    → array @@ -4995,8 +5150,8 @@

    function po

    -
    -

    function postgres-array-string-to-array (str)

    +
    +

    function postgres-array-string-to-array (str)

    "Takes a postgresql array in the form of a string like @@ -5006,12 +5161,12 @@

    function po

    -
    -

    Imported From s-sql

    +
    +

    Imported From s-sql

    -
    -

    macro sql (form)

    +
    +

    macro sql (form)

    → string @@ -5041,8 +5196,8 @@

    -

    function sql-compile (form)

    +
    +

    function sql-compile (form)

    → string @@ -5073,24 +5228,24 @@

    -

    deftype smallint ()

    +
    +

    deftype smallint ()

    '(signed-byte 16)

    -
    -

    deftype bigint ()

    +
    +

    deftype bigint ()

    '(signed-byte 64)

    -
    -

    deftype numeric (&optional precision/scale scale)

    +
    +

    deftype numeric (&optional precision/scale scale)

    (declare (ignore precision/scale scale)) @@ -5098,32 +5253,32 @@

    -

    deftype double-precision ()

    +
    +

    deftype double-precision ()

    'double-float

    -
    -

    deftype bytea ()

    +
    +

    deftype bytea ()

    '(array (unsigned-byte 8))

    -
    -

    deftype text ()

    +
    +

    deftype text ()

    'string

    -
    -

    deftype varchar (length)

    +
    +

    deftype varchar (length)

    (declare (ignore length)) @@ -5131,16 +5286,16 @@

    -

    deftype serial ()

    +
    +

    deftype serial ()

    'integer

    -
    -

    deftype serial8 ()

    +
    +

    deftype serial8 ()

    'integer @@ -5148,8 +5303,8 @@

    -

    deftype db-null ()

    +
    +

    deftype db-null ()

    Type for representing NULL values. Use like (or integer db-null) for declaring a @@ -5159,16 +5314,16 @@

    -

    function from-sql-name (str)

    +
    +

    function from-sql-name (str)

    Convert a string to a symbol, upcasing and replacing underscores with hyphens.

    -
    -

    function parse-queries (file-content)

    +
    +

    function parse-queries (file-content)

    → list @@ -5179,16 +5334,16 @@

    -

    function read-queries (filename)

    +
    +

    function read-queries (filename)

    Read SQL queries in a given file and split them, returns a list.

    -
    -

    function sql-escape-string (string)

    +
    +

    function sql-escape-string (string)

    → string @@ -5208,8 +5363,8 @@

    -

    method sql-escape (arg)

    +
    +

    method sql-escape (arg)

    A generalisation of sql-escape-string looks at the type of the value passed, and @@ -5232,8 +5387,8 @@

    -

    macro register-sql-operators (arity &rest names)

    +
    +

    macro register-sql-operators (arity &rest names)

    Define simple operators. Arity is one of :unary (like @@ -5248,8 +5403,8 @@

    macro regis

    -
    -

    variable escape-sql-names-p

    +
    +

    variable escape-sql-names-p

    Determines whether double quotes are added around column, table, and ** function @@ -5279,8 +5434,8 @@

    -

    function to-sql-name (name &optional (escape-p escape-sql-names-p) (ignore-reserved-words nil))

    +
    +

    function to-sql-name (name &optional (escape-p escape-sql-names-p) (ignore-reserved-words nil))

    Convert a symbol or string into a name that can be a sql table, column, or @@ -5299,8 +5454,8 @@

    -

    condition sql-error

    +
    +

    condition sql-error

    No documentation provided. @@ -5310,12 +5465,12 @@

    -

    Conditions Imported From cl-postgres

    +
    +

    Conditions Imported From cl-postgres

    -
    -

    condition database-connection-error

    +
    +

    condition database-connection-error

    Conditions of this type are signalled when an error occurs that breaks the @@ -5324,8 +5479,8 @@

    -

    condition database-error

    +
    +

    condition database-error

    This is the condition type that will be used to signal virtually all @@ -5333,8 +5488,8 @@

    -

    reader database-error-code

    +
    +

    reader database-error-code

    Code: the Postgresql SQLSTATE code for the error @@ -5344,8 +5499,8 @@

    reader data

    -
    -

    accessor database-error-message

    +
    +

    accessor database-error-message

    Message: the primary human-readable error message. This should be accurate @@ -5354,8 +5509,8 @@

    accessor da

    -
    -

    reader database-error-detail

    +
    +

    reader database-error-detail

    Detail: an optional secondary error message carrying @@ -5365,8 +5520,8 @@

    reader data

    -
    -

    reader database-error-query

    +
    +

    reader database-error-query

    Query that led to the error, or NIL if no query was involved. @@ -5374,8 +5529,8 @@

    reader data

    -
    -

    reader database-error-cause

    +
    +

    reader database-error-cause

    The condition that caused this error, or NIL when it was not caused by another condition. @@ -5384,8 +5539,8 @@

    reader data

    -
    -

    function database-error-constraint-name (err)

    +
    +

    function database-error-constraint-name (err)

    Given a database-error for an integrity violation, will attempt to @@ -5394,8 +5549,8 @@

    -

    function database-error-extract-name (err)

    +
    +

    function database-error-extract-name (err)

    Given a database-error, will extract the critical name from the error message. diff --git a/doc/postmodern.org b/doc/postmodern.org index e2ccb6f..fef7210 100644 --- a/doc/postmodern.org +++ b/doc/postmodern.org @@ -2429,13 +2429,22 @@ Example usage where two identifiers are required would be constraints: 'country-locations) #+END_SRC +** find-comments (type identifier) + +Returns the comments attached to a particular database object. The allowed +types are :database :schema :table :columns (all the columns in a table) +:column (for a single column). + +An example would be (find-comments :table 's2.employees) where the table employees +is in the s2 schema. ** function get-database-comment (database-name) :PROPERTIES: :CUSTOM_ID: d993f27b-95d6-4a5b-bdf3-3e06beed0213 :END: → string -Returns the comment, if any, attached to a database. +Returns the comment, if any, attached to a database. See also get-schema-comment, +get-column-comments and get-database-comment. ** function postgresql-version () :PROPERTIES: :ID: 9243f0ff-2001-4427-8cf9-33f9a9b6fd5c @@ -2936,6 +2945,11 @@ return the tablename and the schema name. The name can be a symbol or a string. Returns a list of form '(table schema database. If the tablename is not fully qualified, it will assume that the schema should be \"public\". +** function get-schema-comment (schema-name) +→ string + +Retrieves the comment, if any attached to the schema. See also get-schema-comment, +get-column-comments and get-database-comment. * Sequences :PROPERTIES: :ID: 62e4d0bd-e12f-47c6-8373-a174a7d8d7b1 @@ -3110,6 +3124,80 @@ Table can be either a string or quoted. Table-names can be fully qualified with the schema or not. If the table-name is not fully qualified and a schema name is not provided, the table will be assumed to be in the public schema. +** function table-description-menu (table-name &key char-max-length data-type-length + has-default default-value not-null + numeric-precision numeric-scale + storage primary primary-key-name + unique unique-key-name fkey fkey-name + fkey-col-id fkey-table fkey-local-col-id + identity generated collation + col-comments locally-defined inheritance-count + stat-collection) +→ list string list + +Takes a fully qualified table name which can be either a string or a symbol. + +Returns three values. + +1. A list of plists of each row's parameters. This will always +include :column-name and :data-type-name but all other parameters can be set or unset +and are set by default (set to t). + +2. The comment string attached to the table itself (if any). + +3. A list of the check constraints applied to the rows in the table. See documentation for +list-check-constraints for an example. + +The available keyword parameters are: + +- data-type-length (For a fixed-size type, typlen is the number of bytes in the internal representation of the type. But for a variable-length type, typlen is negative. -1 indicates a “varlena” type (one that has a length word), -2 indicates a null-terminated C string.) +- char-max-length (Typically used for something like a varchar and shows the maximum length) +- has-default (value T if this column has a default value and :NULL if not) +- default-value (value is the default value as string. A default of 9.99 will still be a string) +- not-null (value is T if the column must have a value or :NULL otherwise) +- numeric-precision (value is the total number of digits for a numeric type if that precision was specified) +- numeric-scale (value is the number of digits in the fraction part of a numeric type if that scale was specified) +- storage (value is the storage setting for a column. Result can be plain, extended, main or external) +- primary (value is T if the column is the primary key for the table, :NULL otherwise) +- primary-key-name (value is the name of the primary-key itself, not the column, if the column is the primary key for the table, :NULL otherwise) +- unique (value is T if the column is subject to a unique key, :NULL otherwise) +- unique-key-name (value is the name of the unique-key itself, not the column, applied to the column, :NULL otherwise) +- fkey (value is T if the column is a foreign key, :NULL otherwise) +- fkey-name (value is the name of the foreign key, :NULL otherwise) +- fkey-col-id (value is the column id of the foreign table used as the foreign key. Probably easier to use the Postmodern function list-foreign-keys if you are looking for the name of the columns) +- fkey-table (value is the name of the foreign table, :NULL otherwise) +- fkey-local-col-id (value is the column id of this column. Probably easier to use the Postmodern function list-foreign-keys if you are looking for the name of the columns involved in the foreign key) +- identity (if the column is an identity column, the values can be 'generated always' or 'generated by default'. Otherwise :NULL) +- generated (columns can be generated, if this column is generated and stored on disk, the value will be 'stored', otherwise :NULL) +- collation (columns with collations which are not the default collation for the database will show that collation here, otherwise :NULL) +- col-comments (value is any comment that has been applied to the column, :NULL otherwise) +- locally-defined (value is T if locally defined. It might be both locally defined and inherited) +- inheritance-count (the number of direct ancestors this column has inherited) +- stat-collection (stat-collection returns the value of attstattarget which controls the level of detail of statistics accumulated for this column by ANALYZE. A zero value indicates that no statistics should be collected. A negative value says to use the system default statistics target. The exact meaning of positive values is data type-dependent. For scalar data types, attstattarget is both the target number of most common values to collect, and the target number of histogram bins to create. Attstorage is normally a copy of pg_type.typstorage of this column's type. For TOAST-able data types, this can be altered after column creation to control storage policy.) +** function list-check-constraints (table-name) +→ list + +Takes a fully qualified table name and returns a list of lists of check constraints +where each sublist has the form of (check-constraint-name check) + +Example: + +#+BEGIN_SRC lisp +(query (:create-table 'employees2 + ((did :type (or integer db-null) + :primary-key "generated by default as identity") + (name :type (varchar 40) :check (:<> 'name "")) + (birth-date :type date :check (:> 'birth-date "1900-01-01")) + (start-date :type date :check (:> 'start-date 'birth-date)) + (salary :type numeric :check (:> 'salary 0))))) + +(list-check-constraints 'employees2) + +(("employees2_birth_date_check" "CHECK (birth_date > '1900-01-01'::date)") + ("employees2_check" "CHECK (start_date > birth_date)") + ("employees2_name_check" "CHECK (name::text <> ''::text)") + ("employees2_salary_check" "CHECK (salary > 0::numeric)")) +#+END_SRC ** function list-columns (table-name) :PROPERTIES: :ID: c867f758-86e5-4242-a825-a273c86acfd0 @@ -3161,7 +3249,16 @@ for tables in all schemas. :END: → string -Retrieves the comment, if any attached to the table. +Retrieves the comment, if any attached to the table. See also get-schema-comment, +get-column-comments and get-database-comment +** function get-column-comments (database schema table) + :PROPERTIES: + :CUSTOM_ID: e8d6e402-5c76-4533-9b5c-a823b9582c26 + :END: +→ string + +Retrieves a list of lists of column names and the comments, if any, attached +to the columns of a table. ** function rename-table (old-name new-name) → boolean diff --git a/postmodern.asd b/postmodern.asd index 49fddbb..99fc328 100644 --- a/postmodern.asd +++ b/postmodern.asd @@ -59,6 +59,7 @@ (:file "test-dao" :depends-on ("test-package") :if-feature :postmodern-use-mop) (:file "test-return-types" :depends-on ("test-package")) + (:file "test-table-info" :depends-on ("test-package")) (:file "test-return-types-timestamps" :depends-on ("test-package")) (:file "test-transactions" :depends-on ("test-package")) (:file "test-roles" :depends-on ("test-package")) diff --git a/postmodern/package.lisp b/postmodern/package.lisp index f0e8ebe..84a6ac3 100644 --- a/postmodern/package.lisp +++ b/postmodern/package.lisp @@ -135,6 +135,7 @@ #:list-templates #:list-available-collations #:list-database-access-rights + #:find-comments ;; extensions #:list-available-extensions @@ -178,6 +179,7 @@ #:drop-schema #:with-schema #:schema-exists-p + #:get-schema-comment ;; sequences #:sequence-next #:list-sequences @@ -190,13 +192,18 @@ #:table-exists-p #:table-description #:table-description-plus + #:table-description-menu #:list-table-sizes #:table-size #:list-tables-in-schema #:drop-table #:get-table-oid #:get-table-comment + #:get-column-comments + #:get-column-comment + #:get-all-table-comments #:rename-table + #:list-check-constraints ;; tablespaces #:list-tablespaces ;; triggers @@ -205,6 +212,7 @@ #:list-detailed-triggers ;; util #:add-comment + #:find-comments #:list-available-types #:cache-hit-ratio #:bloat-measurement diff --git a/postmodern/roles.lisp b/postmodern/roles.lisp index 68faee7..c22d53a 100644 --- a/postmodern/roles.lisp +++ b/postmodern/roles.lisp @@ -223,7 +223,7 @@ a single string name or :current, :all or \"all\"." (list (current-database))) ((or (eq databases :all) (equalp databases "all")) - (list-databases :names-only t)) + (mapcar #'to-sql-name (list-databases :names-only t))) ((listp databases) (intersection (mapcar #'to-sql-name databases) (list-databases :names-only t) diff --git a/postmodern/tests/test-dao.lisp b/postmodern/tests/test-dao.lisp index 69d91b5..451cfbb 100644 --- a/postmodern/tests/test-dao.lisp +++ b/postmodern/tests/test-dao.lisp @@ -502,7 +502,8 @@ so there is a single source of type truth." :id 1 :username "turkey" :department-id 43))) ;; still no turkey to update (is (equal (query "select * from users1") - '((1 "goose" 17) (1 "duck" 3) (1 "chicken" 3) (1 "penguin" 43)))))))) + '((1 "goose" 17) (1 "duck" 3) (1 "chicken" 3) (1 "penguin" 43)))))) + (query (:drop-table :if-exists 'users1 :cascade)))) (test dao-create-table-with-references (is (equal (dao-table-definition 'test-data-col-identity-with-references) diff --git a/postmodern/tests/test-roles.lisp b/postmodern/tests/test-roles.lisp index f7ba146..80d933a 100644 --- a/postmodern/tests/test-roles.lisp +++ b/postmodern/tests/test-roles.lisp @@ -139,7 +139,6 @@ (with-connection (list x superuser-name superuser-password host) (test-db-creation-helper) ;; YES CREATE THE ROLES ONLY ONCE, BUT WHAT ABOUT THE PERMISSIONS? - (when (= y 1) (test-create-roles)) ;; Create table in same database, but subsequent to creation of the roles (query (:create-table 't3 diff --git a/postmodern/tests/test-table-info.lisp b/postmodern/tests/test-table-info.lisp new file mode 100644 index 0000000..4a6916c --- /dev/null +++ b/postmodern/tests/test-table-info.lisp @@ -0,0 +1,398 @@ +;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: POSTMODERN-TESTS; -*- +(in-package :postmodern-tests) + +;; Adjust the above to some db/user/pass/host combination that refers +;; to a valid postgresql database in which no table named test_data +;; currently exists. Then after loading the file, run the tests with +;; (fiveam:run! :postmodern) + +(fiveam:def-suite :postmodern + :description "Test suite for postmodern subdirectory files") + +(fiveam:in-suite :postmodern) + +(fiveam:def-suite :postmodern-table-info + :description "Test suite for postmodern table information functions" + :in :postmodern) + +(fiveam:in-suite :postmodern-table-info) + +(defun create-products () + (drop-table "products" :if-exists t :cascade t) + (query "CREATE TABLE products ( + id SERIAL PRIMARY KEY, + name VARCHAR(100) NOT NULL, + price NUMERIC(5,2) default 9.9);")) + +(defun create-customers-and-contacts () + (drop-table "s1.customers" :if-exists t :cascade t) + (drop-table "s1.contacts" :if-exists t :cascade t) + (drop-schema "s1" :if-exists t :cascade t) + (create-schema "s1") + (query "CREATE TABLE s1.customers( + customer_id INT GENERATED ALWAYS AS IDENTITY, + customer_name VARCHAR(255) NOT NULL, + PRIMARY KEY(customer_id))") + + (query "CREATE TABLE s1.contacts ( + contact_id INT GENERATED ALWAYS AS IDENTITY, + customer_id INT, + contact_name VARCHAR(255) NOT NULL, + phone VARCHAR(25), + email VARCHAR(100) UNIQUE, + PRIMARY KEY(contact_id), + CONSTRAINT fk_customer + FOREIGN KEY(customer_id) + REFERENCES s1.customers(customer_id))") + (pomo:add-comment :database "Test" "This is a test database for reporting purposes") + (pomo:add-comment :schema "s1" "This is a comment about the s1 schema which is external looking") + (pomo:add-comment :table "s1.customers" "This is a test comment for the s1.customers table for reporting purposes")) + +(defun create-employees () + (drop-table "s2.employees" :if-exists t :cascade t) + (drop-schema "s2" :if-exists t :cascade t) + (create-schema "s2") + (query "CREATE TABLE s2.employees ( + id SERIAL PRIMARY KEY, + first_name VARCHAR (50), + last_name VARCHAR (50), + birth_date DATE CHECK (birth_date > '1900-01-01'), + start_date DATE CHECK (start_date > birth_date), + salary numeric CHECK(salary > 0));") + + (query "CREATE UNIQUE INDEX CONCURRENTLY employee_idx + ON s2.employees (id)") + + (query "ALTER TABLE s2.employees + ADD CONSTRAINT unique_employee_id + UNIQUE USING INDEX employee_idx") + (pomo:add-comment :schema "s2" "This is a comment about the s2 schema which is internal looking") + (pomo:add-comment :table "s2.employees" "This is a test comment for the s2.employees table for reporting purposes") + (pomo:add-comment :column "s2.employees.birth_date" "This is a test comment for the s2.employees.birth_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + (pomo:add-comment :column "s2.employees.start_date" "This is a test comment for the s2.employees.start_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + (pomo:add-comment :column "s2.employees.salary" "This is a test comment for the s2.employees.salary column for reporting purposes. There is a check that the salary needs to be greater than 0.")) + +(test using-employees + (with-test-connection + (create-employees) + (multiple-value-bind (rows overview check-constraints) + (table-description-menu "s2.employees" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments t :locally-defined nil :inheritance-count nil + :stat-collection nil) + (is (equal (get-schema-comment "s2") + "This is a comment about the s2 schema which is internal looking")) + (is (equal overview "This is a test comment for the s2.employees table for reporting purposes")) + (is (equal check-constraints + '(("employees_birth_date_check" "CHECK (birth_date > '1900-01-01'::date)") + ("employees_check" "CHECK (start_date > birth_date)") + ("employees_salary_check" "CHECK (salary > 0::numeric)")))) + (is (equal rows + '((:COLUMN-NAME "id" :DATA-TYPE-NAME "int4" :COL-COMMENTS :NULL) + (:COLUMN-NAME "id" :DATA-TYPE-NAME "int4" :COL-COMMENTS :NULL) + (:COLUMN-NAME "first_name" :DATA-TYPE-NAME "varchar" :COL-COMMENTS :NULL) + (:COLUMN-NAME "last_name" :DATA-TYPE-NAME "varchar" :COL-COMMENTS :NULL) + (:COLUMN-NAME "birth_date" :DATA-TYPE-NAME "date" :COL-COMMENTS + "This is a test comment for the s2.employees.birth_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + (:COLUMN-NAME "birth_date" :DATA-TYPE-NAME "date" :COL-COMMENTS + "This is a test comment for the s2.employees.birth_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + (:COLUMN-NAME "start_date" :DATA-TYPE-NAME "date" :COL-COMMENTS + "This is a test comment for the s2.employees.start_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + (:COLUMN-NAME "salary" :DATA-TYPE-NAME "numeric" :COL-COMMENTS + "This is a test comment for the s2.employees.salary column for reporting purposes. There is a check that the salary needs to be greater than 0."))))) + (is (equal (list-check-constraints "s2.employees") + '(("employees_birth_date_check" "CHECK (birth_date > '1900-01-01'::date)") + ("employees_check" "CHECK (start_date > birth_date)") + ("employees_salary_check" "CHECK (salary > 0::numeric)")))) + (is (equal (list-columns "s2.employees") + '("id" "first_name" "last_name" "birth_date" "start_date" "salary"))) + (is (equal (list-columns-with-types "s2.employees") + '(("id" "int4") ("first_name" "varchar") ("last_name" "varchar") + ("birth_date" "date") ("start_date" "date") ("salary" "numeric")))) + (is (equal (column-exists-p "s2.employees" "id") + t)) + (is (equal (get-column-comments 's2.employees) + '(("birth_date" + "This is a test comment for the s2.employees.birth_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + ("start_date" + "This is a test comment for the s2.employees.start_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + ("salary" + "This is a test comment for the s2.employees.salary column for reporting purposes. There is a check that the salary needs to be greater than 0.")))) + (is (equal (find-comments :schema 's2) + "This is a comment about the s2 schema which is internal looking")) + (is (equal (find-comments :table 's2.employees) + "This is a test comment for the s2.employees table for reporting purposes")) + (is (equal (find-comments :columns 's2.employees) + '(("birth_date" + "This is a test comment for the s2.employees.birth_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + ("start_date" + "This is a test comment for the s2.employees.start_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.") + ("salary" + "This is a test comment for the s2.employees.salary column for reporting purposes. There is a check that the salary needs to be greater than 0.")))) + (is (equal (get-column-comment 's2.employees.birth-date) + "This is a test comment for the s2.employees.birth_date column for reporting purposes. There is a check that the start_date needs to occur after the birth_date.")) + (is (not (get-column-comment 's2.employees.id))) + (is (not (get-column-comment 's2.employees))) + (drop-table 's2.employees) + (drop-schema 's2))) + +(test table-schema-names + (multiple-value-bind (tn sn) + (pomo::table-schema-names "t1" nil) + (is (equal tn "t1")) + (is (equal sn "public"))) + (multiple-value-bind (tn sn) + (pomo::table-schema-names "t1" "s2") + (is (equal tn "t1")) + (is (equal sn "s2"))) + (multiple-value-bind (tn sn) + (pomo::table-schema-names "s1.t1" nil) + (is (equal tn "t1")) + (is (equal sn "s1"))) + (signals error (pomo::table-schema-names "s1.t1" "s2"))) + +(test table-inheritance + (with-test-connection + (drop-table "cities" :if-exists t :cascade t) + (query "CREATE TABLE cities ( + name text, + population float, + altitude int );") + (query "CREATE TABLE capitals ( + state char(2)) + INHERITS (cities);") + (is (equalp (table-description-menu + "capitals" :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil + :stat-collection nil :inheritance-count t + :locally-defined t) + '((:COLUMN-NAME "name" :DATA-TYPE-NAME "text" :LOCALLY-DEFINED :NULL + :INHERITANCE-COUNT 1) + (:COLUMN-NAME "population" :DATA-TYPE-NAME "float8" :LOCALLY-DEFINED :NULL + :INHERITANCE-COUNT 1) + (:COLUMN-NAME "altitude" :DATA-TYPE-NAME "int4" :LOCALLY-DEFINED :NULL + :INHERITANCE-COUNT 1) + (:COLUMN-NAME "state" :DATA-TYPE-NAME "bpchar" :LOCALLY-DEFINED T + :INHERITANCE-COUNT 0)))) + (drop-table 'cities :cascade t) + (drop-table 'capitals :cascade t))) + +(test using-products + (with-test-connection + (create-products) + (multiple-value-bind (rows overview) + (table-description-menu "products" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage t :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + (declare (ignore overview)) + (is (equalp rows + '((:COLUMN-NAME "id" :DATA-TYPE-NAME "int4" :STORAGE "plain") + (:COLUMN-NAME "name" :DATA-TYPE-NAME "varchar" :STORAGE "extended") + (:COLUMN-NAME "price" :DATA-TYPE-NAME "numeric" :STORAGE "main"))))) + (multiple-value-bind (rows overview) + (table-description-menu "products" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary t :primary-key-name t + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + (declare (ignore overview)) + (is (equalp rows + '((:COLUMN-NAME "id" :DATA-TYPE-NAME "int4" :PRIMARY "Primary" :PRIMARY-KEY-NAME + "products_pkey") + (:COLUMN-NAME "name" :DATA-TYPE-NAME "varchar" :PRIMARY "" :PRIMARY-KEY-NAME + :NULL) + (:COLUMN-NAME "price" :DATA-TYPE-NAME "numeric" :PRIMARY "" :PRIMARY-KEY-NAME + :NULL))))) + (multiple-value-bind (rows overview) + (table-description-menu "products" + :char-max-length t :data-type-length t + :has-default t :default-value t :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + (declare (ignore overview)) + (is (equalp rows + '((:COLUMN-NAME "id" :DATA-TYPE-NAME "int4" :CHARACTER-MAXIMUM-LENGTH :NULL + :DATA-TYPE-LENGTH 4 :HAS-DEFAULT T :DEFAULT-VALUE + "nextval('products_id_seq'::regclass)") + (:COLUMN-NAME "name" :DATA-TYPE-NAME "varchar" :CHARACTER-MAXIMUM-LENGTH 100 + :DATA-TYPE-LENGTH -1 :HAS-DEFAULT :NULL :DEFAULT-VALUE :NULL) + (:COLUMN-NAME "price" :DATA-TYPE-NAME "numeric" :CHARACTER-MAXIMUM-LENGTH + :NULL :DATA-TYPE-LENGTH -1 :HAS-DEFAULT T :DEFAULT-VALUE "9.9"))))) + (multiple-value-bind (rows overview) + (table-description-menu "products" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null t + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + (declare (ignore overview)) + (is (equalp + rows + '((:COLUMN-NAME "id" :DATA-TYPE-NAME "int4" :NOT-NULL T) + (:COLUMN-NAME "name" :DATA-TYPE-NAME "varchar" :NOT-NULL T) + (:COLUMN-NAME "price" :DATA-TYPE-NAME "numeric" :NOT-NULL :NULL))))) + (multiple-value-bind (rows overview) + (table-description-menu "products" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision t :numeric-scale t + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + (declare (ignore overview)) + (is (equalp rows + '((:COLUMN-NAME "id" :DATA-TYPE-NAME "int4" :NUMERIC-PRECISION :NULL + :NUMERIC-SCALE :NULL) + (:COLUMN-NAME "name" :DATA-TYPE-NAME "varchar" :NUMERIC-PRECISION :NULL + :NUMERIC-SCALE :NULL) + (:COLUMN-NAME "price" :DATA-TYPE-NAME "numeric" :NUMERIC-PRECISION 5 + :NUMERIC-SCALE 2))))) + (drop-table 'products :cascade t))) + +(test using-customer-contacts + (with-test-connection + (create-customers-and-contacts) + (is (equalp (table-description-menu "s1.contacts" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique t :unique-key-name t :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + '((:COLUMN-NAME "contact_id" :DATA-TYPE-NAME "int4" :UNIQUE :NULL + :UNIQUE-KEY-NAME :NULL) + (:COLUMN-NAME "customer_id" :DATA-TYPE-NAME "int4" :UNIQUE :NULL + :UNIQUE-KEY-NAME :NULL) + (:COLUMN-NAME "contact_name" :DATA-TYPE-NAME "varchar" :UNIQUE :NULL + :UNIQUE-KEY-NAME :NULL) + (:COLUMN-NAME "phone" :DATA-TYPE-NAME "varchar" :UNIQUE :NULL :UNIQUE-KEY-NAME + :NULL) + (:COLUMN-NAME "email" :DATA-TYPE-NAME "varchar" :UNIQUE T :UNIQUE-KEY-NAME + "contacts_email_key")))) + (is (equalp (table-description-menu + "s1.contacts" :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey t :fkey-name t + :fkey-col-id t :fkey-table t :fkey-local-col-id t + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + '((:COLUMN-NAME "contact_id" :DATA-TYPE-NAME "int4" :FKEY :NULL :FKEY-NAME :NULL + :FKEY-COL-ID :NULL :FKEY-TABLE :NULL :FKEY-LOCAL-COL-ID :NULL) + (:COLUMN-NAME "customer_id" :DATA-TYPE-NAME "int4" :FKEY T :FKEY-NAME + "fk_customer" :FKEY-COL-ID #(1) :FKEY-TABLE "customers" :FKEY-LOCAL-COL-ID + #(2)) + (:COLUMN-NAME "contact_name" :DATA-TYPE-NAME "varchar" + :FKEY :NULL :FKEY-NAME + :NULL :FKEY-COL-ID :NULL :FKEY-TABLE :NULL :FKEY-LOCAL-COL-ID :NULL) + (:COLUMN-NAME "phone" :DATA-TYPE-NAME "varchar" :FKEY :NULL :FKEY-NAME :NULL + :FKEY-COL-ID :NULL :FKEY-TABLE :NULL :FKEY-LOCAL-COL-ID :NULL) + (:COLUMN-NAME "email" :DATA-TYPE-NAME "varchar" :FKEY :NULL :FKEY-NAME :NULL + :FKEY-COL-ID :NULL :FKEY-TABLE :NULL :FKEY-LOCAL-COL-ID :NULL)))) + (is (equalp (table-description-menu + "s1.contacts" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection t) + '((:COLUMN-NAME "contact_id" :DATA-TYPE-NAME "int4" :STAT-COLLECTION :NULL) + (:COLUMN-NAME "customer_id" :DATA-TYPE-NAME "int4" :STAT-COLLECTION :NULL) + (:COLUMN-NAME "contact_name" :DATA-TYPE-NAME "varchar" :STAT-COLLECTION :NULL) + (:COLUMN-NAME "phone" :DATA-TYPE-NAME "varchar" :STAT-COLLECTION :NULL) + (:COLUMN-NAME "email" :DATA-TYPE-NAME "varchar" :STAT-COLLECTION :NULL)))) + (is (equal (get-schema-comment "s1") + "This is a comment about the s1 schema which is external looking")) + (drop-table 's1.customers :cascade t) + (drop-table 's1.contacts :cascade t) + (drop-schema 's1 :cascade t))) + +(test identity-and-generated + (with-test-connection + (drop-table "people" :if-exists t :cascade t) + (query "CREATE TABLE people ( + height_cm numeric, + height_in numeric GENERATED ALWAYS AS (height_cm / 2.54) STORED);") + (is (equalp + (table-description-menu "people" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity t :generated t :collation nil + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + '((:COLUMN-NAME "height_cm" :DATA-TYPE-NAME "numeric" + :IDENTITY :NULL :GENERATED :NULL) + (:COLUMN-NAME "height_in" :DATA-TYPE-NAME "numeric" + :IDENTITY :NULL :GENERATED "stored")))) + (drop-table 'people :cascade t))) + +(test table-collation + (with-test-connection + (drop-table "test_collations" :if-exists t :cascade t) + (query "CREATE TABLE test_collations ( + a text COLLATE \"C\", + b text COLLATE \"POSIX\");") + + (is (equalp + (table-description-menu "test_collations" + :char-max-length nil :data-type-length nil + :has-default nil :default-value nil :not-null nil + :numeric-precision nil :numeric-scale nil + :storage nil :primary nil :primary-key-name nil + :unique nil :unique-key-name nil :fkey nil :fkey-name nil + :fkey-col-id nil :fkey-table nil :fkey-local-col-id nil + :identity nil :generated nil :collation t + :col-comments nil :locally-defined nil :inheritance-count nil + :stat-collection nil) + '((:COLUMN-NAME "a" :DATA-TYPE-NAME "text" :COLLATION "C") + (:COLUMN-NAME "b" :DATA-TYPE-NAME "text" :COLLATION "POSIX")))) + (drop-table 'test-collations :cascade t))) diff --git a/postmodern/tests/test-transactions.lisp b/postmodern/tests/test-transactions.lisp index c0c85ec..da98880 100644 --- a/postmodern/tests/test-transactions.lisp +++ b/postmodern/tests/test-transactions.lisp @@ -224,7 +224,8 @@ (is (equal (query "select * from test_data") '((0) (1) (2)))))) (is (equal (query "select * from test_data") - '((0) (1) (2))))))) + '((0) (1) (2)))) + (execute (:drop-table 'test-data))))) (test savepoint-rollback-from-inside (let ((x 1) @@ -261,4 +262,5 @@ (is (equal (query "select * from test_data") '((0) (1)))))) (is (equal (query "select * from test_data") - '((0) (1))))))) + '((0) (1)))) + (execute (:drop-table 'test-data))))) diff --git a/postmodern/tests/tests.lisp b/postmodern/tests/tests.lisp index 258674c..088ef6e 100644 --- a/postmodern/tests/tests.lisp +++ b/postmodern/tests/tests.lisp @@ -33,12 +33,6 @@ (defmacro protect (&body body) `(unwind-protect (progn ,@(butlast body)) ,(car (last body)))) -(fiveam:def-suite :postmodern-base - :description "Base test suite for postmodern" - :in :postmodern) - -(fiveam:in-suite :postmodern-base) - (test connect-sanely (with-test-connection (is (not (null *database*))))) @@ -533,12 +527,12 @@ (execute (:drop-table 'test-uniq))) (query (:create-table 'uniq.gracie ((id :type integer)))) (is (equal (list-tables-in-schema "uniq") - '(("gracie")))) + '("gracie"))) (is (equal (list-tables-in-schema 'uniq) - '(("gracie")))) + '("gracie"))) (query (:create-table "uniq.george" ((id :type integer)))) (is (equal (list-tables-in-schema "uniq") - '(("george") ("gracie")))) + '("george" "gracie"))) (is (table-exists-p "test.uniq.george")) (is (table-exists-p "uniq.george")) (is (table-exists-p "george" "uniq")) @@ -549,15 +543,12 @@ (drop-schema 'uniq :cascade 't) (is (not (schema-exists-p 'uniq))) (create-schema 'uniq) - (is (not (set-difference (list-schemas) - '("public" "information_schema" "uniq") - :test #'equal))) + (format t "List-schemas ~a~%" (list-schemas)) + (is (equal "uniq" (find "uniq" (list-schemas) :test #'equal))) (drop-schema "uniq" :cascade 't) (is (not (schema-exists-p "uniq"))) (create-schema "uniq") - (is (not (set-difference (list-schemas) - '("public" "information_schema" "uniq") - :test #'equal))) + (is (equal "uniq" (find "uniq" (list-schemas) :test #'equal))) (drop-schema 'uniq :cascade 't) (is (equal (get-search-path) "\"$user\", public")) @@ -660,7 +651,8 @@ and second the string name for the datatype." (is (equal (sql (:drop-index :concurrently 'george-idx)) "DROP INDEX CONCURRENTLY george_idx")) (is (equal (sql (:drop-index 'george-idx)) - "DROP INDEX george_idx")))) + "DROP INDEX george_idx")) + (query (:drop-table :if-exists 'george :cascade)))) (test sequence "Sequence testing" diff --git a/postmodern/util.lisp b/postmodern/util.lisp index f3df42d..15d21e4 100644 --- a/postmodern/util.lisp +++ b/postmodern/util.lisp @@ -1,6 +1,9 @@ ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: POSTMODERN; -*- (in-package :postmodern) +(defun make-keyword (name) + (values (intern (string-upcase name) "KEYWORD"))) + (defun valid-sql-character-p (chr) "Returns t if chr is letter, underscore, digits or dollar sign" (or (cl-unicode:has-property chr "Letter") @@ -196,6 +199,20 @@ is '~a'" name comment))) (:type (query (format nil "comment on TYPE ~a is '~a'" name comment))) (:view (query (format nil "comment on VIEW ~a is '~a'" name comment))))) +(defun find-comments (type identifier) + "Returns the comments attached to a particular database object. The allowed +types are :database :schema :table :columns (all the columns in a table) +:column (for a single column). + +An example would be (find-comments :table 's2.employees) where the table employees +is in the s2 schema." + (ecase type + (:database (get-database-comment identifier)) + (:schema (get-schema-comment identifier)) + (:table (get-table-comment identifier)) + (:columns (get-column-comments identifier)) + (:column (get-column-comment identifier)))) + ;;; Databases (define-condition invalid-database-name (error) ((text :initarg :text :reader text)) @@ -327,14 +344,14 @@ provided, it will return the result for the currently connected database." :where (:= 'datname '$1)) (to-sql-name name)))) -(defun get-database-comment (database-name) +(defun get-database-comment (&optional database-name) "Returns the comment, if any, attached to a database" - (setf database-name (to-sql-name database-name)) - (when (database-exists-p database-name) - (query "SELECT pg_catalog.shobj_description(d.oid, 'pg_database') + (if database-name (setf database-name (to-sql-name database-name)) + (setf database-name (current-database))) + (query "SELECT pg_catalog.shobj_description(d.oid, 'pg_database') FROM pg_catalog.pg_database d WHERE datname = $1" database-name - :single))) + :single)) (defun list-databases (&key (order-by-size nil) (size t) (names-only nil)) "Returns a list of lists where each sub-list contains the name of the @@ -416,6 +433,12 @@ a database name, a role name and whether they have access rights (T or NIL)." role-name)))) ;;;; Schemas +(defun get-schema-comment (schema-name) + "If the schema has been commented, returns that string, else nil. Must be a +schema in the currently connected database." + (query "select obj_description($1::regnamespace)" + (to-sql-name schema-name) + :single)) ;;;; See namespace.lisp ;;; Sequences @@ -513,15 +536,26 @@ the name of the data types. E.g. (21 \"smallint\")" :where (:= 'typtype "b")))) ;;; Tables +(define-condition inconsistent-schema-name (error) + ((text :initarg :text :reader text))) + (defun table-schema-names (table-name schema-name) "Helper function to allow for fully qualified table names and non-qualified tables names that just exist in public schema or in a separately stated -schema in the second parameter." +schema in the second parameter. Will thrown an error if the table-name is +fully qualified and has a schema name different than the specified schema name." (let ((split-name (split-fully-qualified-tablename table-name))) (setf table-name (first split-name)) - (if schema-name (setf schema-name (to-sql-name schema-name)) - (setf schema-name (second split-name)))) - (values table-name schema-name)) + (cond ((and schema-name + (not (string= (second split-name) "public")) + (not (string= (second split-name) + (to-sql-name schema-name)))) + (error 'inconsistent-schema-name + :text (format nil "You have specified a schema name ~a and an inconsistent schema name in a fully qualified table name ~a" schema-name (second split-name)))) + ((not schema-name) + (setf schema-name (second split-name))) + (t (setf schema-name (to-sql-name schema-name)))) + (values table-name schema-name))) ;;; create table can only be done either using a deftable approach or s-sql @@ -530,15 +564,9 @@ schema in the second parameter." "Retrieves the comment, if any attached to the table." (multiple-value-bind (tn sn) (table-schema-names table-name schema-name) - (query (:select 'description - :from 'pg-description - :inner-join 'pg-class - :on (:= 'objoid 'oid) - :inner-join 'pg-namespace - :on (:= 'pg-namespace.oid 'pg-class.relnamespace) - :where (:and (:= 'pg-class.relname '$1) - (:= 'pg-namespace.nspname '$2))) - tn sn :single))) + (query (format nil "select obj_description($1::regclass)") + (concatenate 'string sn "." tn) + :single))) (defun get-all-table-comments () "Returns a list of lists, each list showing the schema, table and comment @@ -594,7 +622,7 @@ is not provided, the table will be assumed to be in the public schema." tn sn)))) (defun table-description-plus (table-name &optional schema-name) - "Returns more table info than table-description. Specifically returns + "Returns more table info than table-description. It defaults to returning column-name, data-type, character-maximum-length, modifier, whether it is not-null and the default value. @@ -604,28 +632,228 @@ is not provided, the table will be assumed to be in the public schema." (multiple-value-bind (tn sn) (table-schema-names table-name schema-name) (mapcar #'butlast - (query (:order-by - (:select - (:as 'a.attname 'column-name) - (:as 'tn.typname 'data-type) - (:as 'a.attlen 'character-maximum-length) - (:as 'a.atttypmod 'modifier) - (:as 'a.attnotnull 'notnull) - (:as 'a.atthasdef 'hasdefault) - (:as 'a.attnum 'ordinal-position) - :distinct - :from (:as 'pg-attribute 'a) - :inner-join (:as 'pg-type 'tn) - :on (:= 'tn.oid 'a.atttypid) - :inner-join 'pg-class - :on (:and (:= 'pg-class.oid 'attrelid) - (:= 'pg-class.relname '$1)) - :inner-join 'pg-namespace - :on (:= 'pg-namespace.oid 'pg-class.relnamespace) - :where (:and (:> 'attnum 0) - (:= 'pg-namespace.nspname '$2))) - 'ordinal-position) - tn sn)))) + (query (:order-by + (:select + (:as 'a.attname 'column-name) + (:as 'tn.typname 'data-type) + (:as 'a.attlen 'character-maximum-length) + (:as 'a.atttypmod 'modifier) + (:as 'a.attnotnull 'notnull) + (:as 'a.atthasdef 'hasdefault) + (:as 'a.attnum 'ordinal-position) + :distinct + :from (:as 'pg-attribute 'a) + :inner-join (:as 'pg-type 'tn) + :on (:= 'tn.oid 'a.atttypid) + :inner-join 'pg-class + :on (:and (:= 'pg-class.oid 'attrelid) + (:= 'pg-class.relname '$1)) + :inner-join 'pg-namespace + :on (:= 'pg-namespace.oid 'pg-class.relnamespace) + :where (:and (:> 'attnum 0) + (:= 'pg-namespace.nspname '$2))) + 'ordinal-position) + tn sn)))) + +(defun table-parameter-helper (version>11 version>10 char-max-length data-type-length + has-default default-value not-null + numeric-precision numeric-scale + storage primary primary-key-name + unique unique-key-name fkey fkey-name + fkey-col-id fkey-table fkey-local-col-id + identity generated collation + col-comments locally-defined inheritance-count + stat-collection) + (let ((param-list (list "t.typname AS data_type_name" "f.attname as column_name"))) + (when char-max-length + (push " CASE + WHEN f.atttypmod >= 0 AND t.typname <> 'numeric' + THEN (f.atttypmod - 4) --first 4 bytes are for storing actual length of data + END AS character_maximum_length" param-list)) + (when data-type-length + (push " f.attlen as data_type_length " param-list)) + (when has-default + (push " case when f.atthasdef then f.atthasdef else null end as has_default" param-list)) + (when default-value + (push " CASE + WHEN f.atthasdef = 't' THEN pg_get_expr(d.adbin, d.adrelid) + END AS default_value " param-list)) + (when not-null + (push "case when f.attnotnull then f.attnotnull else null end as not_null " param-list)) + (when numeric-precision + (push " CASE + WHEN t.typname = 'numeric' THEN (((f.atttypmod - 4) >> 16) & 65535) + END AS numeric_precision " param-list)) + (when numeric-scale + (push " CASE + WHEN t.typname = 'numeric' THEN ((f.atttypmod - 4)& 65535 ) + END AS numeric_scale " param-list)) + (when storage + (push " CASE + WHEN f.attstorage ='p' THEN 'plain' + WHEN f.attstorage ='m' THEN 'main' + WHEN f.attstorage ='e' THEN 'external' + WHEN f.attstorage ='x' THEN 'extended' + END + as storage " param-list)) + (when primary + (push " CASE + WHEN p.contype = 'p' THEN 'Primary' + ELSE '' + END AS primary " param-list)) + (when primary-key-name + (push " CASE + WHEN p.contype = 'p' THEN p.conname + END AS primary_key_name " param-list)) + (when unique + (push " CASE + WHEN p.contype = 'u' THEN True + ELSE null + END AS unique " param-list)) + (when unique-key-name + (push " CASE + WHEN p.contype = 'u' THEN p.conname + END AS unique_key_name " param-list)) + (when fkey + (push " CASE + WHEN p.contype = 'f' THEN True + ELSE NULL + END AS fkey " param-list)) + (when fkey-name + (push " CASE + WHEN p.contype = 'f' THEN p.conname + END AS fkey_name " param-list)) + (when fkey-col-id + (push " CASE + WHEN p.contype = 'f' THEN p.confkey + END AS fkey_col_id " param-list)) + (when fkey-table + (push " CASE + WHEN p.contype = 'f' THEN g.relname + END AS fkey_table " param-list)) + (when fkey-local-col-id + (push " CASE + WHEN p.contype = 'f' THEN p.conkey + END AS fkey_local_col_id " param-list)) + (when (and identity version>10) + (push " case when f.attidentity ='a' then 'generated always' + when f.attidentity = 'd' then 'generated by default' + else null + end as identity " param-list)) + (when (and generated version>11) + (push " case when f.attgenerated ='s' then 'stored' else null end as generated " param-list)) + (when collation + (push " (select c.collname from pg_catalog.pg_collation as c, pg_catalog.pg_type t + where c.oid = f.attcollation + and t.oid = f.atttypid + and f.attcollation <> t.typcollation) AS collation " + param-list)) + (when col-comments + (push " pg_catalog.col_description(f.attrelid, f.attnum) as col_comments " param-list)) + (when locally-defined + (push " case when f.attislocal then true else null end as locally_defined " param-list)) + (when inheritance-count + (push " f.attinhcount inheritance_count " param-list)) + (when stat-collection + (push " CASE WHEN f.attstattarget=-1 THEN NULL ELSE f.attstattarget END AS stat_collection " + param-list)) + (format nil "~{~a~^, ~}" (nreverse param-list)))) + +(defun table-description-menu (table-name + &key (char-max-length t) (data-type-length t) + (has-default t) (default-value t) (not-null t) + (numeric-precision t) (numeric-scale t) + (storage t) (primary t) (primary-key-name t) + (unique t) (unique-key-name t) (fkey t) (fkey-name t) + (fkey-col-id t) (fkey-table t) (fkey-local-col-id t) + (identity t) (generated t) (collation t) + (col-comments t) (locally-defined t) (inheritance-count t) + (stat-collection t)) + "Takes a fully qualified table name which can be either a string or a symbol. +Returns three values. + +1. A list of plists of each row's parameters. This will always +include :column-name and :data-type-name but all other parameters can be set or unset +and are set by default (set to t). + +2. The comment string attached to the table itself (if any). + +3. A list of the check constraints applied to the rows in the table. See documentation for +list-check-constraints for an example. + +The available keyword parameters are: + +- char-max-length (Typically used for something like a varchar and shows the maximum length) +- data-type-length (For a fixed-size type, typlen is the number of bytes in the internal representation of the type. But for a variable-length type, typlen is negative. -1 indicates a “varlena” type (one that has a length word), -2 indicates a null-terminated C string.) +- has-default (value T if this column has a default value and :NULL if not) +- default-value (value is the default value as string. A default of 9.99 will still be a string) +- not-null (value is T if the column must have a value or :NULL otherwise) +- numeric-precision (value is the total number of digits for a numeric type if that precision was specified) +- numeric-scale (value is the number of digits in the fraction part of a numeric type if that scale was specified) +- storage (value is the storage setting for a column. Result can be plain, extended, main or external) +- primary (value is T if the column is the primary key for the table, :NULL otherwise) +- primary-key-name (value is the name of the primary-key itself, not the column, if the column is the primary key for the table, :NULL otherwise) +- unique (value is T if the column is subject to a unique key, :NULL otherwise) +- unique-key-name (value is the name of the unique-key itself, not the column, applied to the column, :NULL otherwise) +- fkey (value is T if the column is a foreign key, :NULL otherwise) +- fkey-name (value is the name of the foreign key, :NULL otherwise) +- fkey-col-id (value is the column id of the foreign table used as the foreign key. Probably easier to use the Postmodern function list-foreign-keys if you are looking for the name of the columns) +- fkey-table (value is the name of the foreign table, :NULL otherwise) +- fkey-local-col-id (value is the column id of this column. Probably easier to use the Postmodern function list-foreign-keys if you are looking for the name of the columns involved in the foreign key) +- identity (if the column is an identity column, the values can be 'generated always' or 'generated by default'. Otherwise :NULL) +- generated (columns can be generated, if this column is generated and stored on disk, the value will be 'stored', otherwise :NULL) +- collation (columns with collations which are not the default collation for the database will show that collation here, otherwise :NULL) +- col-comments (value is any comment that has been applied to the column, :NULL otherwise) +- locally-defined (value is T if locally defined. It might be both locally defined and inherited) +- inheritance-count (the number of direct ancestors this column has inherited) +- stat-collection (stat-collection returns the value of attstattarget which controls the level of detail of statistics accumulated for this column by ANALYZE. A zero value indicates that no statistics should be collected. A negative value says to use the system default statistics target. The exact meaning of positive values is data type-dependent. For scalar data types, attstattarget is both the target number of most common values to collect, and the target number of histogram bins to create. Attstorage is normally a copy of pg_type.typstorage of this column's type. For TOAST-able data types, this can be altered after column creation to control storage policy.)" + (let* ((version>11 (cl-postgres:postgresql-version-at-least "12.0" pomo:*database*)) + (version>10 (cl-postgres:postgresql-version-at-least "11.0" pomo:*database*))) + (destructuring-bind (table schema database) + (pomo:split-fully-qualified-tablename table-name) + (declare (ignore database)) + (setf schema (to-sql-name schema)) + (setf table (to-sql-name table)) + (when (and (pomo:schema-exists-p schema) + (pomo:table-exists-p (concatenate 'string schema "." table))) + (let ((overall-description + (get-table-comment table schema)) + (constraint-checks (list-check-constraints table-name)) + (col-descriptions + (query + (format nil + "SELECT + ~a + FROM pg_attribute f + JOIN pg_class c ON c.oid = f.attrelid + JOIN pg_type t ON t.oid = f.atttypid + LEFT JOIN pg_attrdef d + ON d.adrelid = c.oid + AND d.adnum = f.attnum + LEFT JOIN pg_namespace n + ON n.oid = c.relnamespace + LEFT JOIN pg_constraint p + ON p.conrelid = c.oid + AND f.attnum = ANY (p.conkey) + LEFT JOIN pg_class AS g ON p.confrelid = g.oid + WHERE c.relkind = 'r'::char + AND f.attisdropped = false + AND n.nspname = $1 -- Replace with Schema name + AND c.relname = $2 -- Replace with table name + AND f.attnum > 0 + ORDER BY f.attnum" + (table-parameter-helper version>11 version>10 + char-max-length data-type-length + has-default default-value not-null + numeric-precision numeric-scale + storage primary primary-key-name + unique unique-key-name fkey fkey-name + fkey-col-id fkey-table fkey-local-col-id + identity generated collation + col-comments locally-defined inheritance-count + stat-collection)) + schema table :plists))) + (values col-descriptions overall-description constraint-checks)))))) (defun list-all-tables (&optional (fully-qualified-names-only nil)) "If fully-qualified-names-only is set to t, returns all schema.table names @@ -668,8 +896,9 @@ the names will be returned as strings with underscores converted to hyphens." ORDER BY table_name)" (to-sql-name schema-name)))))) (if strings-p - (mapcar 'from-sql-name result) - result ))) + (mapcar 'to-sql-name result) + result) + (alexandria:flatten result))) (defun list-tables (&optional (strings-p nil)) "DEPRECATED FOR LIST-ALL-TABLES. Return a list of the tables in the public @@ -769,24 +998,41 @@ either a string or quoted." ;; Columns -(defun get-column-comments (database schema table) - "Retrieves a list of lists of column names and comments, if any, from a table " - (query (format nil "SELECT - cols.column_name, - ( - SELECT - pg_catalog.col_description(c.oid, cols.ordinal_position::int) - FROM pg_catalog.pg_class c - WHERE - c.oid = (SELECT cols.table_name::regclass::oid) AND - c.relname = cols.table_name - ) as column_comment - - FROM information_schema.columns cols - WHERE - cols.table_catalog = '~a' AND - cols.table_schema = '~a' AND - cols.table_name = '~a';" database schema table))) +(defun get-column-comments (fully-qualified-table-name) + "Retrieves a list of lists of column names and comments, if any, from a table. +Each sublist will be in the form of (column-name comment-string)" + (query "SELECT a.attname, + pg_catalog.col_description(a.attrelid, a.attnum) + FROM pg_catalog.pg_attribute a + WHERE a.attrelid = $1 + AND a.attnum > 0 + AND NOT a.attisdropped + and pg_catalog.col_description(a.attrelid, a.attnum) is not null + ORDER BY a.attnum;" + (get-table-oid fully-qualified-table-name))) + +(defun get-column-comment (qualified-column-name) + "Retrieves a string which is the comment applied to a particular column in a table +in the currently connected database. The parameter can be in the form +of table.column, schema.table.column or database.schema.table.colum." + (let* ((split-name + (split-sequence:split-sequence #\. + (to-sql-name qualified-column-name) + :test 'equal)) + (col-name (car (last split-name))) + (qualified-table-name (format nil "~{~a~^.~}" (butlast split-name))) + (table-oid (get-table-oid qualified-table-name))) + (when table-oid + (cadar (query "SELECT a.attname, + pg_catalog.col_description(a.attrelid, a.attnum) + FROM pg_catalog.pg_attribute a + WHERE a.attrelid = $1 + AND a.attnum > 0 + AND NOT a.attisdropped + AND a.attname = $2 + and pg_catalog.col_description(a.attrelid, a.attnum) is not null + ORDER BY a.attnum;" + table-oid col-name))))) (defun list-columns (table-name) "Returns a list of strings of just the column names in a table. @@ -1029,7 +1275,7 @@ fully qualified table name e.g. schema-name.table-name." table))) (if just-key (loop for x in info collect (first x)) info))) -(defun list-foreign-keys (table schema) +(defun list-foreign-keys (table &optional (schema "public")) "Returns a list of sublists of foreign key info in the form of '((constraint-name local-table local-table-column foreign-table-name foreign-column-name))" @@ -1096,6 +1342,17 @@ Turns constraints into keywords if strings-p is not true." collect (mapcar 'from-sql-name x)))))) +(defun list-check-constraints (table-name) + "Takes a fully qualified table name and returns a list of lists of check constraints +where each sublist has the form of (check-constraint-name check). See postmodern doc for + example" + (query "SELECT r.conname, pg_catalog.pg_get_constraintdef(r.oid, true) + FROM pg_catalog.pg_constraint r + WHERE r.conrelid = $1 AND r.contype = 'c' + ORDER BY 1;" + (get-table-oid table-name))) + + (defun list-all-constraints (table-name &optional (strings-p)) "Uses information_schema to list all the constraints in a table. Table-name can be either a string or quoted. Turns constraints into keywords if strings-p @@ -1151,7 +1408,9 @@ table." table-name :alists)))) (defun describe-foreign-key-constraints () - "Generates a list of lists of information on the foreign key constraints" + "Generates a list of lists of information on the foreign key constraints +where each row returned is in the form of +(constraint-name 631066 table-name table-column 631061 foreign-table-name foreign-table-column)" (query (:order-by (:select 'conname (:as 'conrelid 'table) (:as 'pgc.relname 'tabname) diff --git a/s-sql/tests/test-intervals.lisp b/s-sql/tests/test-intervals.lisp index acc7f36..e191daf 100644 --- a/s-sql/tests/test-intervals.lisp +++ b/s-sql/tests/test-intervals.lisp @@ -114,7 +114,8 @@ ("6 years") ("5 months") ("5 months 12 hours")))) - (is-true (table-exists-p 'interval)))) + (is-true (table-exists-p 'interval)) + (query (:drop-table 'interval)))) (test intervals "Testing intervals" diff --git a/s-sql/tests/tests.lisp b/s-sql/tests/tests.lisp index fd275e6..91bef43 100644 --- a/s-sql/tests/tests.lisp +++ b/s-sql/tests/tests.lisp @@ -62,7 +62,8 @@ (is (equal (query (:select 'nullable :from 'null-test :where (:= 'id 2)) :single) :null)) (is (equal (query (:select '* :from 'null-test :where (:= 'id 2))) - '((2 :null)))))) + '((2 :null)))) + (query (:drop-table :if-exists 'null-test :cascade)))) (defun build-recipe-tables () "Build recipe tables uses in array tests"