source: release/1.9/source/library/mac-file-io.lisp @ 15706

Last change on this file since 15706 was 2323, checked in by bryan, 14 years ago

add (in-package "CCL") forms.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.6 KB
Line 
1;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of Opensourced MCL.
5;;;
6;;;   Opensourced MCL is free software; you can redistribute it and/or
7;;;   modify it under the terms of the GNU Lesser General Public
8;;;   License as published by the Free Software Foundation; either
9;;;   version 2.1 of the License, or (at your option) any later version.
10;;;
11;;;   Opensourced MCL is distributed in the hope that it will be useful,
12;;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;;;   Lesser General Public License for more details.
15;;;
16;;;   You should have received a copy of the GNU Lesser General Public
17;;;   License along with this library; if not, write to the Free Software
18;;;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
19;;;
20
21
22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23;;
24;; mac-file-io.lisp
25;;
26
27;; This file implements something similar to the high-level file I/O
28;; primitives in Inside Macintosh.
29;; It does NOT support asynchronous I/O (and neither does the Macintosh, really).
30
31;; Routines that take an errorp parameter will signal an error if
32;; the parameter is unspecified or true, otherwise, if there is an
33;; error they return two values: NIL & the error number.
34;; If there is no error, routines return one or more values the
35;; first of which is non-NIL.
36
37;;;;;;;;;;;;;
38;;
39;; Modification History
40;;
41
42(in-package "CCL")
43
44(eval-when (:compile-toplevel :execute)
45  (require 'sysequ))
46
47(eval-when (:compile-toplevel :load-toplevel :execute)
48  (export '(with-FSOpen-file FSOpen FSClose FSRead FSWrite setFPos getFPos getEOF)))
49
50(defmacro with-FSOpen-file ((pb filename &optional read-write-p (vrefnum 0))
51                            &body body)
52  `(let ((,pb (FSOpen ,filename ,read-write-p ,vrefnum)))
53     (unwind-protect
54       (progn ,@body)
55       (FSClose ,pb))))
56
57(defmacro with-FSOpen-file-noerr ((pb filename &optional read-write-p (vrefnum 0))
58                                  &body body)
59  `(let ((,pb (ignore-errors
60               (FSOpen ,filename ,read-write-p ,vrefnum))))
61     (when ,pb
62       (unwind-protect
63         (progn ,@body)
64         (FSClose ,pb)))))
65
66; Returns a paramBlock for doing furthur I/O with the file
67(defun FSOpen (filename &optional read-write-p (vrefnum 0) (errorp t)
68                        (resolve-aliases-p t))
69  (when resolve-aliases-p (setq filename (truename filename)))
70  (let ((paramBlock (make-record :hparamblockrec))
71        ok)
72    (unwind-protect
73      (with-pstrs ((pname (mac-namestring filename)))
74        (setf (pref paramblock :hparamblockrec.ioNameptr) pname
75              (pref paramblock :hparamblockrec.ioVrefnum) vrefnum
76              (pref paramblock :hparamblockrec.ioVersNum) 0
77              (pref paramblock :hparamblockrec.ioPermssn) (if read-write-p #$fsRdWrPerm #$fsRdPerm)
78              (pref paramblock :hparamblockrec.ioMisc) (%null-ptr))
79        (#_PBOpenSync paramBlock)
80        (let ((res (pref paramBlock :hparamblockrec.ioResult)))
81          (if (eql #$NoErr res)
82            (progn
83              (setf (pref paramblock :hparamblockrec.ioPosOffSet) 0
84                    (pref paramblock :hparamblockrec.ioPosMode) #$fsAtMark)
85              (setq ok t)
86              paramBlock)
87            (maybe-file-error errorp res filename))))
88      (unless ok
89        (#_DisposePtr paramBlock)))))
90
91(defun FSClose (paramBlock &optional (errorp t))
92  (#_PBCloseSync paramBlock)
93  (let ((errnum (pref paramBlock :hparamblockrec.ioResult)))
94    (#_DisposePtr paramBlock)
95    (or (eql errnum #$noErr)
96        (maybe-file-error errorp errnum))))
97
98; Returns two values: the number of bytes actually read, and the
99; location of the file mark.
100(defun fsRead (paramBlock count buffer &optional (offset 0) (errorp t))
101  (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset)
102        (pref paramBlock :hparamblockrec.ioReqCount) count)
103  (#_PBReadSync paramBlock)
104  (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark)
105  (let ((errnum (pref paramBlock :hparamblockrec.ioResult)))
106    (if (or (eql #$noErr errnum) (eql #$eofErr errnum))
107      (values (pref paramBlock :hparamblockrec.ioActCount)
108              (pref paramBlock :hparamblockrec.ioPosOffset))
109      (maybe-file-error errorp errnum))))
110
111; Returns two values: the number of bytes actually written, and the
112; location of the file mark.
113(defun fsWrite (paramBlock count buffer &optional (offset 0) (errorp t))
114  (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset)
115        (pref paramBlock :hparamblockrec.ioReqCount) count)
116  (#_PBWriteSync paramBlock)
117  (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark)
118  (let ((errnum (pref paramBlock :hparamblockrec.ioResult)))
119    (if (or (eql #$noErr errnum) (eql #$eofErr errnum))
120      (values (pref paramBlock :hparamblockrec.ioActCount)
121              (pref paramBlock :hparamblockrec.ioPosOffset))
122      (maybe-file-error errorp errnum))))
123
124(defun setFPos (paramBlock pos)
125  (setf (pref paramBlock :hparamblockrec.ioPosOffset) pos
126        (pref paramblock :hparamblockrec.ioPosMode) #$fsFromStart)
127  pos)
128
129(defun getFPos (paramBlock)
130  (pref paramBlock :hparamblockrec.ioPosOffset))
131
132(defun getEOF (paramBlock &optional (errorp t))
133  (let* ((errnum (#_PBGetEOFSync paramBlock)))
134    (if (eql #$noErr errnum)
135      (%ptr-to-int (pref paramblock :hparamblockrec.ioMisc))
136      (maybe-file-error errorp errnum))))
137
138(defun GetVInfo (&key (volName "") (vRefNum 0))
139  (let* ((vol-pathname (truename (make-pathname :type nil :name nil :defaults volName)))
140         (directory    (pathname-directory vol-pathname)))
141    (assert (and directory (eq :absolute (car directory))))
142    (rlet ((paramBlock :hparamblockrec))
143      (with-returned-pstrs ((pname (cadr directory)))
144        (setf (pref paramblock :hparamblockrec.ioCompletion) (%null-ptr)
145              (pref paramblock :hparamblockrec.ioNamePtr)    pname
146              (pref paramblock :hparamblockrec.ioVRefNum)    vRefNum
147              (pref paramblock :hparamblockrec.ioVolIndex)   0)
148        (values (#_PBHGetVInfoSync paramBlock)
149                (* (%get-unsigned-long paramblock $ioVAlBlkSiz)         ; see IM:Files 2-46
150                   (pref paramblock :hparamblockrec.ioVFrBlk))
151                (pref paramblock :hparamblockrec.ioVRefNum)
152                (%get-string (pref paramblock :hparamblockrec.ioNamePtr)))))))
153
154(defun maybe-file-error (errorp errnum &optional filename)
155  (if errorp
156    (%err-disp errnum filename)
157    (values nil errnum)))
158
159(provide :mac-file-io)
160
161; End of mac-file-io.lisp
Note: See TracBrowser for help on using the repository browser.