File: large-object.lisp

package info (click to toggle)
cl-pg 1:20061216-4
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 276 kB
  • ctags: 233
  • sloc: lisp: 3,125; makefile: 43
file content (124 lines) | stat: -rw-r--r-- 4,827 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
;;; large-object.lisp -- support for BLOBs
;;;
;;; Author: Eric Marsden <eric.marsden@free.fr>
;;
;;
;; Sir Humphrey: Who is Large and to what does he object?
;;
;; Large objects are the PostgreSQL way of doing what most databases
;; call BLOBs (binary large objects). In addition to being able to
;; stream data to and from large objects, PostgreSQL's
;; object-relational capabilities allow the user to provide functions
;; which act on the objects.
;;
;; For example, the user can define a new type called "circle", and
;; define a C or Tcl function called `circumference' which will act on
;; circles. There is also an inheritance mechanism in PostgreSQL.
;;
;; The PostgreSQL large object interface is similar to the Unix file
;; system, with open, read, write, lseek etc.
;;
;; Implementation note: the network protocol for large objects changed
;; around version 6.5 to use network order for integers.
;; =====================================================================

(in-package :postgresql)

(defconstant +INV_ARCHIVE+ #x10000)     ; fe-lobj.c
(defconstant +INV_WRITE+   #x20000)
(defconstant +INV_READ+    #x40000)
(defconstant +LO_BUFSIZ+   1024)


(defvar *lo-initialized* nil)
(defvar *lo-functions* '())

(defun lo-init (connection)
  (let ((res (pg-exec connection
                    "SELECT proname, oid from pg_proc WHERE "
                    "proname = 'lo_open' OR "
                    "proname = 'lo_close' OR "
                    "proname = 'lo_creat' OR "
                    "proname = 'lo_unlink' OR "
                    "proname = 'lo_lseek' OR "
                    "proname = 'lo_tell' OR "
                    "proname = 'loread' OR "
                    "proname = 'lowrite'")))
    (setq *lo-functions* '())
    (dolist (tuple (pg-result res :tuples))
      (push (cons (car tuple) (cadr tuple)) *lo-functions*))
    (unless (= 8 (length *lo-functions*))
      (error "Couldn't find OIDs for all the large object functions"))
    (setq *lo-initialized* t)))


;; returns an OID
(defun pglo-create (connection &optional (modestr "r"))
  (let* ((mode (cond ((integerp modestr) modestr)
                     ((string= "r" modestr) +INV_READ+)
                     ((string= "w" modestr) +INV_WRITE+)
                     ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+))
                     (t (error "Bad mode ~s" modestr))))
         (oid (fn connection "lo_creat" t mode)))
    (unless (integerp oid)
      (error 'backend-error :reason "Didn't return an OID"))
    (when (zerop oid)
      (error 'backend-error :reason "Can't create large object"))
    oid))

;; args = modestring (default "r", or "w" or "rw")
;; returns a file descriptor for use in later lo-* procedures
(defun pglo-open (connection oid &optional (modestr "r"))
  (let* ((mode (cond ((integerp modestr) modestr)
                     ((string= "r" modestr) +INV_READ+)
                     ((string= "w" modestr) +INV_WRITE+)
                     ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+))
                     (t (error 'program-error (format nil "Bad mode ~s" modestr)))))
         (fd (fn connection "lo_open" t oid mode)))
    (assert (integerp fd))
    fd))

(defun pglo-close (connection fd)
  (fn connection "lo_close" t fd))

;; pglo-read has moved to v2-protocol.lisp and v3-protocol.lisp
;;
;; the difference between the v3 and v2 protocols is that in the former case
;; data is read in binary format, whereas in the latter data is read as text. 

(defun pglo-write (connection fd buf)
  (fn connection "lowrite" t fd buf))

(defun pglo-lseek (connection fd offset whence)
  (fn connection "lo_lseek" t fd offset whence))

(defun pglo-tell (connection fd)
  (fn connection "lo_tell" t fd))

(defun pglo-unlink (connection oid)
  (fn connection "lo_unlink" t oid))

(defun pglo-import (connection filename)
  (let ((buf (make-array +LO_BUFSIZ+ :element-type '(unsigned-byte 8)))
        (oid (pglo-create connection "rw")))
    (with-open-file (in filename :direction :input
                        :element-type '(unsigned-byte 8))
       (loop :with fdout = (pglo-open connection oid "w")
             :for bytes = (read-sequence buf in)
             :until (< bytes +LO_BUFSIZ+)
             :do (pglo-write connection fdout buf)
             :finally
             (pglo-write connection fdout (subseq buf 0 bytes))
             (pglo-close connection fdout)))
    oid))

(defun pglo-export (connection oid filename)
  (with-open-file (out filename :direction :output
                       :element-type '(unsigned-byte 8))
     (loop :with fdin = (pglo-open connection oid "r")
           :for str = (pglo-read connection fdin +LO_BUFSIZ+)
           :until (zerop (length str))
           :do (write-sequence str out)
           :finally (pglo-close connection fdin))))

;; EOF