source: trunk/ccl/hemlock/src/files.lisp @ 798

Last change on this file since 798 was 798, checked in by gb, 15 years ago

Partial integration with Cocoa document handling.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.2 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Hemlock File manipulation functions.
13;;; Written by Skef Wholey, Horribly Hacked by Rob MacLachlan.
14;;; Unhacked by Gilbert Baumann.
15;;;
16
17(in-package :hemlock-internals)
18
19
20;;;; Utility functions.
21
22;; FIND-CHAR-FROM-SAP was here, deleted --GB
23
24
25;;; Read-File:
26
27(defun read-file (pathname mark)
28  "Inserts the contents of the file named by Pathname at the Mark."
29  (with-mark ((mark mark :left-inserting))
30    (let* ((first-line (mark-line mark))
31           (buffer (line-%buffer first-line)))
32      (modifying-buffer buffer)
33      (cocoa-read-file pathname mark buffer))))
34     
35
36
37
38;;; Write-File:
39
40(defun write-file (region pathname &key append
41                          (keep-backup (value hemlock::keep-backup-files))
42                          access)
43  "Writes the characters in region to the file named by pathname.  This writes
44   region using a stream opened with :if-exists :rename-and-delete, unless
45   either append or keep-backup is supplied.  If append is supplied, this
46   writes the file opened with :if-exists :append.  If keep-backup is supplied,
47   this writes the file opened with :if-exists :rename.  This signals an error
48   if both append and keep-backup are supplied.  Access is an implementation
49   dependent value that is suitable for setting pathname's access or protection
50   bits."
51  (declare (ignorable access))
52  (let ((if-exists-action (cond ((and keep-backup append)
53                                 (error "Cannot supply non-nil values for ~
54                                         both keep-backup and append."))
55                                (keep-backup :rename)
56                                (append :append)
57                                (t :rename-and-delete))))
58    (with-open-file (file pathname :direction :output
59                          :element-type 'base-char
60                          :if-exists if-exists-action)
61      (close-line)
62      (fast-write-file region file))
63    ;; ### access is always ignored
64    #+NIL
65    (when access
66      (multiple-value-bind
67          (winp code)
68          ;; Must do a TRUENAME in case the file has never been written.
69          ;; It may have Common Lisp syntax that Unix can't handle.
70          ;; If this is ever moved to the beginning of this function to use
71          ;; Unix CREAT to create the file protected initially, they TRUENAME
72          ;; will signal an error, and LISP::PREDICT-NAME will have to be used.
73          (unix:unix-chmod (namestring (truename pathname)) access)
74        (unless winp
75          (error "Could not set access code: ~S"
76                 (unix:get-unix-error-msg code)))))))
77
78(defun fast-write-file (region file)
79  (let* ((start (region-start region))
80         (start-line (mark-line start))
81         (start-charpos (mark-charpos start))
82         (end (region-end region))
83         (end-line (mark-line end))
84         (end-charpos (mark-charpos end)))
85    (if (eq start-line end-line)
86        ;; just one line (fragment)
87        (write-string (line-chars start-line) file
88                      :start start-charpos :end end-charpos)
89        ;; multiple lines
90        (let* ((first-length (- (line-length start-line) start-charpos))
91               (length (+ first-length end-charpos 1)))
92          ;; count number of octets to be written
93          (do ((line (line-next start-line) (line-next line)))
94              ((eq line end-line))
95            (incf length (1+ (line-length line))))
96          ;;
97          (macrolet ((chars (line)
98                       `(line-%chars ,line)))
99            (write-sequence (chars start-line) file :start start-charpos :end (+ start-charpos first-length))
100            (write-char #\newline file)
101            (let ((offset (1+ first-length)))
102              (do ((line (line-next start-line)
103                         (line-next line)))
104                  ((eq line end-line))
105                (let ((end (+ offset (line-length line))))
106                  (write-sequence (chars line) file :start 0 :end (- end offset))
107                  (write-char #\newline file)     
108                  (setf offset (1+ end))))
109              (unless (zerop end-charpos)
110                (write-sequence (chars end-line) file :start 0 :end end-charpos))))))))
Note: See TracBrowser for help on using the repository browser.