From: Chris Hanson Date: Wed, 25 Oct 1995 02:19:50 +0000 (+0000) Subject: Merge common parts of DOS/WIN32 and OS2 file-name customization. X-Git-Tag: 20090517-FFI~5861 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0e3ad93988fb8c83fae706cec97a659c15610868;p=mit-scheme.git Merge common parts of DOS/WIN32 and OS2 file-name customization. --- diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index d894f4cf6..3fb6c216c 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dos.scm,v 1.28 1995/10/24 05:37:48 cph Exp $ +;;; $Id: dos.scm,v 1.29 1995/10/25 02:19:50 cph Exp $ ;;; ;;; Copyright (c) 1992-95 Massachusetts Institute of Technology ;;; @@ -46,174 +46,27 @@ (declare (usual-integrations)) -(define-variable backup-by-copying-when-linked - "True means use copying to create backups for files with multiple names. -This causes the alternate names to refer to the latest version as edited. -This variable is relevant only if backup-by-copying is false." - false - boolean?) +(define dos/encoding-pathname-types + '()) -(define-variable backup-by-copying-when-mismatch - "True means create backups by copying if this preserves owner or group. -Renaming may still be used (subject to control of other variables) -when it would not result in changing the owner or group of the file; -that is, for files which are owned by you and whose group matches -the default for a new file created there by you. -This variable is relevant only if Backup By Copying is false." - false - boolean?) - -(define-variable version-control - "Control use of version numbers for backup files. -#T means make numeric backup versions unconditionally. -#F means make them for files that have some already. -'NEVER means do not make them." - true - (lambda (thing) - (or (eq? thing 'NEVER) (boolean? thing)))) - -(define-variable kept-old-versions - "Number of oldest versions to keep when a new numbered backup is made." - 2 - exact-nonnegative-integer?) - -(define-variable kept-new-versions - "Number of newest versions to keep when a new numbered backup is made. -Includes the new backup. Must be > 0." - 2 - (lambda (n) (and (exact-integer? n) (> n 0)))) - -(define os/directory-char-set (char-set #\\ #\/)) -(define os/expand-char-set (char-set #\$ #\~)) - -(define (os/trim-pathname-string string prefix) - (let ((index (string-match-forward prefix string))) - (if (and index - (re-match-substring-forward - (re-compile-pattern "[\\/$~]\\|[a-zA-Z]:" #t) - #t #f string index (string-length string))) - (string-tail string index) - string))) - -(define os/pathname->display-string - ->namestring) - -(define (file-type->version type version) - (let ((version-string - (and (fix:fixnum? version) - (number->string (fix:remainder version 1000))))) - (if (not version-string) - (error "Illegal version" version) - (let ((version-string - (string-pad-left version-string 3 #\0))) - (if (string? type) - (if (fix:> (string-length type) 0) - (string-append (substring type 0 1) - (substring version-string 1 3)) - version-string) - version-string))))) - -(define (filename->version-number filename) - (let ((type (pathname-type filename))) - (and (string? type) - (fix:= (string-length type) 3) - (or (string->number type) - (string->number (substring type 1 3)))))) - -(define (os/auto-save-pathname pathname buffer) - buffer - (pathname-new-type pathname - (file-type->version (pathname-type pathname) 0))) - -(define (os/precious-backup-pathname pathname) - ;; Use the autosave name for the precious backup - (pathname-new-type pathname - (file-type->version (pathname-type pathname) 0))) +(define dos/executable-pathname-types + ;; Not sure if there are other possibilities under WinNT and/or Win95. + '("exe" "com" "bat")) -(define (os/backup-buffer? truename) - (let ((attrs (file-attributes truename))) - (and attrs - (memv (string-ref (file-attributes/mode-string attrs) 0) - '(#\- #\l)) - (not (let ((directory (pathname-directory truename))) - (and (pair? directory) - (eq? 'ABSOLUTE (car directory)) - (pair? (cdr directory)) - (eqv? "tmp" (cadr directory)))))))) +(define dos/default-shell-file-name + ;; Not sure if this is right for WinNT and/or Win95. + "command.com") -(define (os/default-backup-filename) - "c:/tmp/edwin.bak") +(define (os/form-shell-command command) + ;; Not sure if this is right. + (list "/c" command)) -(define (os/truncate-filename-for-modeline filename width) - (let ((length (string-length filename))) - (if (< 0 width length) - (let ((result - (substring - filename - (let ((index (- length width))) - (or (and (not - (char-set-member? os/directory-char-set - (string-ref filename index))) - (substring-find-next-char-in-set - filename index length os/directory-char-set)) - (1+ index))) - length))) - (string-set! result 0 #\$) - result) - filename))) - -(define (os/backup-by-copying? truename buffer) - truename buffer - false) - -(define (os/buffer-backup-pathname truename) - (let ((directory (directory-namestring truename)) - (type (pathname-type truename)) - (filename (pathname-name truename))) +(define (os/directory-list directory) + (os/directory-list-completions directory "")) - (define (no-versions) - (values (pathname-new-type truename (file-type->version type 0)) '())) - (define (version->pathname version) - (pathname-new-type truename (file-type->version type version))) - (define (files->versions files) - (if (or (not files) (null? files)) - '() - (let ((type-number (filename->version-number (car files)))) - (if type-number - (cons type-number (files->versions (cdr files))) - (files->versions (cdr files)))))) - - (if (eq? 'NEVER (ref-variable version-control)) - (no-versions) - (let ((search-name (string-append filename "."))) - (let ((filenames - (os/directory-list-completions directory search-name))) - (let ((versions (sort (files->versions filenames) <))) - (let ((high-water-mark (apply max (cons 0 versions)))) - (if (or (ref-variable version-control) - (positive? high-water-mark)) - (values - (version->pathname (+ high-water-mark 1)) - (let ((start (ref-variable kept-old-versions)) - (end (fix:- (length versions) - (fix:-1+ - (ref-variable kept-new-versions))))) - (if (fix:< start end) - (map version->pathname - (sublist versions start end)) - '()))) - (no-versions))))))))) - (define (os/directory-list-completions directory prefix) - (define (->directory-namestring s) - (->namestring (pathname-as-directory (->pathname s)))) - - (define (->directory-wildcard s) - (string-append (->directory-namestring s) - "*.*")) - (let ((plen (string-length prefix))) - (let loop ((pathnames (directory-read (->directory-wildcard directory)))) + (let loop ((pathnames (directory-read (pathname-as-directory directory)))) (if (null? pathnames) '() (let ((filename (file-namestring (car pathnames)))) @@ -222,105 +75,45 @@ Includes the new backup. Must be > 0." (cons filename (loop (cdr pathnames))) (loop (cdr pathnames)))))))) -(define (os/directory-list directory) - (os/directory-list-completions directory "")) - -(define dos/encoding-pathname-types '()) - -(define dos/backup-suffixes '()) - -(define (os/backup-filename? filename) - (let ((version (filename->version-number filename))) - (and (fix:fixnum? version) - (fix:> version 0)))) - -(define (os/numeric-backup-filename? filename) - (let ((type (pathname-type filename))) - (and (string? type) - (fix:= (string-length type) 3) - (let ((version (string->number type))) - (and version - (cons (->namestring (pathname-new-type filename #f)) - version))) - (let ((version (substring->number type 1 3))) - (and version - (cons (->namestring (pathname-new-type filename - (string-head type 1))) - version)))))) - -(define (os/auto-save-filename? filename) - (let ((version (filename->version-number filename))) - (and (fix:fixnum? version) - (fix:= version 0)))) - -(define (os/pathname-type-for-mode pathname) - (let ((type (pathname-type pathname))) - (if (member type dos/encoding-pathname-types) - (pathname-type (->namestring (pathname-new-type pathname false))) - type))) - -(define (os/completion-ignore-filename? filename) - (or (os/backup-filename? filename) - (os/auto-save-filename? filename) - (and (not (file-directory? filename)) - (there-exists? (ref-variable completion-ignored-extensions) - (lambda (extension) - (string-suffix? extension filename)))))) +(define (os/set-file-modes-writable! pathname) + (set-file-modes! pathname #o777)) -(define (os/completion-ignored-extensions) - (append '(".bin" ".com" ".ext" - ".inf" ".bif" ".bsm" ".bci" ".bcs" - ".psb" ".moc" ".fni" - ".bco" ".bld" ".bad" ".glo" ".fre" - ".obj" ".exe" ".pif" ".grp" - ".dvi" ".toc" ".log" ".aux") - (list-copy dos/backup-suffixes))) +(define (os/scheme-can-quit?) + #t) -(define-variable completion-ignored-extensions - "Completion ignores filenames ending in any string in this list." - (os/completion-ignored-extensions) - (lambda (extensions) - (and (list? extensions) - (for-all? extensions - (lambda (extension) - (and (string? extension) - (not (string-null? extension)))))))) +(define (os/quit dir) + (with-real-working-directory-pathname dir %quit)) -(define (os/file-type-to-major-mode) - (alist-copy - `(("asm" . midas) - ("bat" . text) - ("bib" . text) - ("c" . c) - ("h" . c) - ("m4" . midas) - ("pas" . pascal) - ("s" . scheme) - ("scm" . scheme) - ("txi" . texinfo) - ("txt" . text)))) - -(define (os/init-file-name) - (let ((user-init-file - (merge-pathnames "edwin.ini" - (pathname-as-directory (current-home-directory))))) - (if (file-exists? user-init-file) - (->namestring user-init-file) - "/scheme/lib/edwin.ini"))) +(define (with-real-working-directory-pathname dir thunk) + (let ((inside (->namestring (directory-pathname-as-file dir))) + (outside false)) + (dynamic-wind + (lambda () + (stop-thread-timer) + (set! outside + (->namestring + (directory-pathname-as-file (working-directory-pathname)))) + (set-working-directory-pathname! inside) + ((ucode-primitive set-working-directory-pathname! 1) inside)) + thunk + (lambda () + (set! inside + (->namestring + (directory-pathname-as-file (working-directory-pathname)))) + ((ucode-primitive set-working-directory-pathname! 1) outside) + (set-working-directory-pathname! outside) + (start-thread-timer))))) -(define (os/find-file-initialization-filename pathname) - (or (and (equal? "scm" (pathname-type pathname)) - (let ((pathname (pathname-new-type pathname "ffi"))) - (and (file-exists? pathname) - pathname))) - (let ((pathname - (merge-pathnames "edwin.ffi" (directory-pathname pathname)))) - (and (file-exists? pathname) - pathname)))) +(define (os/interprogram-cut string push?) string push? unspecific) +(define (os/interprogram-paste) #f) (define (os/read-file-methods) '()) (define (os/write-file-methods) '()) (define (os/alternate-pathnames group pathname) group pathname '()) + +(define (os/sendmail-program) "sendmail.exe") +(define (os/rmail-pop-procedure) #f) +(define (os/hostname) (error "OS/HOSTNAME procedure unimplemented.")) ;;;; Dired customization @@ -347,21 +140,13 @@ Includes the new backup. Must be > 0." ;; 'DIRECTORY means FILE is a directory and a full listing is expected. ;; 'FILE means FILE itself should be listed, and not its contents. ;; SWITCHES are ignored. - (case type - ((WILDCARD) - (generate-dired-listing! file mark)) - ((DIRECTORY) - (generate-dired-listing! - (string-append (->namestring (pathname-as-directory file)) - "*.*") - mark)) - (else - (generate-dired-entry! file mark)))) - -;;; Scheme version of ls + (generate-dired-listing (if (eq? type 'DIRECTORY) + (pathname-as-directory file) + file) + mark)) (define (generate-dired-listing! pathname point) - (let ((files (directory-read (->namestring (merge-pathnames pathname))))) + (let ((files (directory-read pathname))) (for-each (lambda (file) (generate-dired-entry! file point)) files))) @@ -372,15 +157,14 @@ Includes the new backup. Must be > 0." (file-time->string (file-attributes/modification-time attr)))) (if (string? time-string) (or (let ((len (string-length time-string))) - (and (fix:> len 5) ;; Grap the space char as well + (and (fix:> len 5) ;; Grab the space char as well (string-append (substring time-string (fix:- len 5) len) " " (substring time-string 0 (fix:- len 5))))) "")))) (let ((name (file-namestring file)) - (attr (or (file-attributes file) - (dummy-file-attributes)))) + (attr (or (file-attributes file) (dummy-file-attributes)))) (let ((entry (string-append (string-pad-right ; Mode string (file-attributes/mode-string attr) 12 #\Space) @@ -395,133 +179,4 @@ Includes the new backup. Must be > 0." (mark-temporary! point))))) (define-integrable (dummy-file-attributes) - '#(#f 0 0 0 0 0 0 0 "----------" 0)) - -(define (os/scheme-can-quit?) - true) - -(define (os/quit dir) - (with-real-working-directory-pathname dir %quit)) - -(define (with-real-working-directory-pathname dir thunk) - (let ((inside (->namestring (directory-pathname-as-file dir))) - (outside false)) - (dynamic-wind - (lambda () - (stop-thread-timer) - (set! outside (->namestring - (directory-pathname-as-file - (working-directory-pathname)))) - (set-working-directory-pathname! inside) - ((ucode-primitive set-working-directory-pathname! 1) inside)) - thunk - (lambda () - (set! inside (->namestring - (directory-pathname-as-file - (working-directory-pathname)))) - ((ucode-primitive set-working-directory-pathname! 1) outside) - (set-working-directory-pathname! outside) - (start-thread-timer))))) - -(define (os/set-file-modes-writable! pathname) - (set-file-modes! pathname #o777)) - -(define (os/sendmail-program) - "sendmail.exe") - -(define (os/rmail-pop-procedure) - #f) - -(define (os/hostname) - (error "OS/HOSTNAME procedure unimplemented.")) - -(define (os/interprogram-cut string push?) - string push? - unspecific) - -(define (os/interprogram-paste) - #f) - -(define (os/comint-filename-region start point end) - (let ((chars "]\\\\A-Za-z0-9!#$%&'()+,.:;=@[^_`{}~---")) - (let ((start (skip-chars-backward chars point start))) - (make-region start (skip-chars-forward chars start end))))) - -;;;; Subprocess/Shell Support - -(define (os/parse-path-string string) - (let ((end (string-length string)) - (substring - (lambda (string start end) - (pathname-as-directory (substring string start end))))) - (let loop ((start 0)) - (if (< start end) - (let ((index (substring-find-next-char string start end #\;))) - (if index - (if (= index start) - (loop (+ index 1)) - (cons (substring string start index) - (loop (+ index 1)))) - (list (substring string start end)))) - '())))) - -(define (os/find-program program default-directory) - (or (dos/find-program program (ref-variable exec-path) default-directory) - (error "Can't find program:" (->namestring program)))) - -(define (dos/find-program program exec-path default-directory) - (let* ((types dos/executable-suffixes) - (try - (lambda (pathname) - (let ((type (pathname-type pathname))) - (if type - (and (member type types) - (file-exists? pathname) - (->namestring pathname)) - (let loop ((types types)) - (and (not (null? types)) - (let ((p - (pathname-new-type pathname (car types)))) - (if (file-exists? p) - (->namestring p) - (loop (cdr types))))))))))) - (cond ((pathname-absolute? program) - (try program)) - ((not default-directory) - (let loop ((path exec-path)) - (and (not (null? path)) - (or (and (pathname-absolute? (car path)) - (try (merge-pathnames program (car path)))) - (loop (cdr path)))))) - (else - (let ((default-directory (merge-pathnames default-directory))) - (let loop ((path exec-path)) - (and (not (null? path)) - (or (try (merge-pathnames - program - (merge-pathnames (car path) - default-directory))) - (loop (cdr path)))))))))) - -(define (os/shell-file-name) - (or (get-environment-variable "SHELL") - ;; Not sure if this is right for WinNT and/or Win95. - "command.com")) - -(define dos/executable-suffixes - ;; Not sure if there are other possibilities under WinNT and/or Win95. - '("exe" "com" "bat")) - -(define (os/form-shell-command command) - (list "/c" command)) - -(define (os/shell-name pathname) - (if (member (pathname-type pathname) dos/executable-suffixes) - (pathname-name pathname) - (file-namestring pathname))) - -(define (os/default-shell-prompt-pattern) - "^\\[[^]]*] *") - -(define (os/default-shell-args) - '()) \ No newline at end of file + '#(#f 0 0 0 0 0 0 0 "----------" 0)) \ No newline at end of file diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index d2c125b34..a3de07da1 100644 --- a/v7/src/edwin/edwin.ldr +++ b/v7/src/edwin/edwin.ldr @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.ldr,v 1.55 1995/04/13 23:38:09 cph Exp $ +$Id: edwin.ldr,v 1.56 1995/10/25 02:19:36 cph Exp $ Copyright (c) 1989-95 Massachusetts Institute of Technology @@ -152,12 +152,15 @@ MIT in each case. |# (load "rgxcmp" (->environment '(EDWIN REGULAR-EXPRESSION-COMPILER))) (load "linden" (->environment '(EDWIN LISP-INDENTATION))) - (load-case 'OS-TYPE - '((UNIX . "unix") - (DOS . "dos") - (NT . "dos") - (OS/2 . "os2")) - environment) + (case (lookup 'OS-TYPE) + ((UNIX) + (load "unix" environment)) + ((DOS NT) + (load "dos" environment) + (load "dosfile" environment)) + ((OS/2) + (load "os2" environment) + (load "dosfile" environment))) (load "fileio" environment) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index d15abc820..d1f39514a 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.180 1995/10/24 05:38:04 cph Exp $ +$Id: edwin.pkg,v 1.181 1995/10/25 02:19:27 cph Exp $ Copyright (c) 1989-95 Massachusetts Institute of Technology @@ -1106,7 +1106,7 @@ MIT in each case. |# (global-definitions "../win32/win32") (extend-package (edwin) - (files "dos")) + (files "dos" "dosfile")) (extend-package (edwin screen console-screen) (files "ansi" "bios")) @@ -1158,7 +1158,7 @@ MIT in each case. |# ((os/2) (extend-package (edwin) - (files "os2") + (files "os2" "dosfile") (import (runtime os2-window-primitives) os2-clipboard-read-text os2-clipboard-write-text)) diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm index 2b2e7ebd9..fa4594961 100644 --- a/v7/src/edwin/os2.scm +++ b/v7/src/edwin/os2.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: os2.scm,v 1.23 1995/10/12 22:47:48 cph Exp $ +;;; $Id: os2.scm,v 1.24 1995/10/25 02:19:44 cph Exp $ ;;; ;;; Copyright (c) 1994-95 Massachusetts Institute of Technology ;;; @@ -45,82 +45,17 @@ (declare (usual-integrations)) -(define-variable version-control - "Control use of version numbers for backup files. -#T means make numeric backup versions unconditionally. -#F means make them for files that have some already. -'NEVER means do not make them." - #f - (lambda (object) (or (eq? object 'NEVER) (boolean? object)))) - -(define-variable kept-old-versions - "Number of oldest versions to keep when a new numbered backup is made." - 2 - exact-nonnegative-integer?) - -(define-variable kept-new-versions - "Number of newest versions to keep when a new numbered backup is made. -Includes the new backup. Must be > 0." - 2 - (lambda (n) (and (exact-integer? n) (> n 0)))) - -(define os2/encoding-pathname-types +(define dos/encoding-pathname-types '("gz" #|"ky"|#)) -(define os2/backup-suffixes - (cons "~" - (map (lambda (type) (string-append "~." type)) - os2/encoding-pathname-types))) - -(define-variable completion-ignored-extensions - "Completion ignores filenames ending in any string in this list." - (append (list ".bin" ".com" ".ext" - ".inf" ".bif" ".bsm" ".bci" ".bcs" - ".psb" ".moc" ".fni" - ".bco" ".bld" ".bad" ".glo" ".fre" - ".obj" ".exe" ".pif" ".grp" - ".dvi" ".toc" ".log" ".aux") - (list-copy os2/backup-suffixes)) - (lambda (extensions) - (and (list? extensions) - (for-all? extensions - (lambda (extension) - (and (string? extension) - (not (string-null? extension)))))))) - -;;;; Filename I/O - -(define (os/trim-pathname-string string prefix) - (let ((index (string-match-forward prefix string))) - (if (and index - (re-match-substring-forward - (re-compile-pattern "[\\/$~]\\|[a-zA-Z]:" #t) - #t #f string index (string-length string))) - (string-tail string index) - string))) - -(define (os/pathname->display-string pathname) - (or (let ((relative (enough-pathname pathname (user-homedir-pathname)))) - (and (not (pathname-device relative)) - (not (pathname-absolute? relative)) - (string-append "~\\" (->namestring relative)))) - (->namestring pathname))) - -(define (os/truncate-filename-for-modeline filename width) - (let ((length (string-length filename))) - (if (< 0 width length) - (let ((result - (substring - filename - (let ((index (- length width))) - (if (char=? #\\ (string-ref filename index)) - index - (or (substring-find-next-char filename index length #\\) - (fix:+ index 1)))) - length))) - (string-set! result 0 #\$) - result) - filename))) +(define dos/executable-pathname-types + '("exe" "cmd")) + +(define dos/default-shell-file-name + "cmd.exe") + +(define (os/form-shell-command command) + (list "/c" command)) (define (os/directory-list directory) (let ((channel (directory-channel-open directory))) @@ -141,232 +76,9 @@ Includes the new backup. Must be > 0." (begin (directory-channel-close channel) result)))))) - -;;;; Backup and Auto-Save Filenames - -(define (os/buffer-backup-pathname truename) - (call-with-values - (lambda () - (if (os2/fs-long-filenames? truename) - (let ((type (pathname-type truename))) - (if (member type os2/encoding-pathname-types) - (values (pathname-new-type truename #f) - (string-append "~." type)) - (values truename "~"))) - (values truename ""))) - (lambda (truename suffix) - (if (eq? 'NEVER (ref-variable version-control)) - (values (os2/make-backup-pathname truename #f suffix) '()) - (let ((prefix - (if (os2/fs-long-filenames? truename) - (string-append (file-namestring truename) ".~") - (string-append (pathname-name truename) ".")))) - (let ((backups - (let loop - ((filenames - (os/directory-list-completions - (directory-namestring truename) - prefix)) - (backups '())) - (if (null? filenames) - (sort backups (lambda (x y) (< (cdr x) (cdr y)))) - (loop (cdr filenames) - (let ((root.version - (os/numeric-backup-filename? - (car filenames)))) - (if root.version - (cons (cons (car filenames) - (cdr root.version)) - backups) - backups))))))) - (if (null? backups) - (values (os2/make-backup-pathname - truename - (and (ref-variable version-control) 1) - suffix) - '()) - (values (os2/make-backup-pathname - truename - (+ (apply max (map cdr backups)) 1) - suffix) - (let ((start (ref-variable kept-old-versions)) - (end - (- (length backups) - (- (ref-variable kept-new-versions) 1)))) - (if (< start end) - (map car (sublist backups start end)) - '())))))))))) - -(define (os2/make-backup-pathname pathname version suffix) - (if (os2/fs-long-filenames? pathname) - (string-append (->namestring pathname) - (if version - (string-append ".~" (number->string version) suffix) - suffix)) - (pathname-new-type pathname - (if (and version (< version 1000)) - (let ((type (pathname-type pathname)) - (vs (number->string version))) - (if (and (< version 100) - (string? type) - (not (string-null? type))) - (string-append (substring type 0 1) - (string-pad-left vs 2 #\0)) - (string-pad-left vs 3 #\0))) - "bak")))) - -(define (os/default-backup-filename) - "$TMP\\edwin.bak") - -(define (os/backup-filename? filename) - (or (there-exists? os2/backup-suffixes - (lambda (suffix) - (string-suffix? suffix filename))) - (let ((type (pathname-type filename))) - (and (string? type) - (or (string-ci=? "bak" type) - (re-match-string-forward (re-compile-pattern ".[0-9][0-9]" #f) - #f - #f - type)))))) - -(define (os/numeric-backup-filename? filename) - (and (let ((try - (lambda (pattern) - (re-search-string-forward (re-compile-pattern pattern #f) - #f - #f - filename)))) - (or (try "^\\([^.]+\\)\\.\\([0-9][0-9][0-9]\\)$") - (try "^\\([^.]+\\.[^.]\\)\\([0-9][0-9]\\)$") - (there-exists? os2/backup-suffixes - (lambda (suffix) - (try (string-append "^\\(.+\\)\\.~\\([0-9]+\\)" - (re-quote-string suffix) - "$")))))) - (let ((root-start (re-match-start-index 1)) - (root-end (re-match-end-index 1)) - (version-start (re-match-start-index 2)) - (version-end (re-match-end-index 2))) - (let ((version - (substring->number filename version-start version-end))) - (and (> version 0) - (cons (substring filename root-start root-end) - version)))))) - -(define (os/auto-save-filename? filename) - (or (re-match-string-forward (re-compile-pattern "^#.+#$" #f) - #f - #f - (file-namestring filename)) - (let ((type (pathname-type filename))) - (and (string? type) - (string-ci=? "sav" type))))) - -(define (os/precious-backup-pathname pathname) - (if (os2/fs-long-filenames? pathname) - (let ((directory (directory-pathname pathname))) - (let loop ((i 0)) - (let ((pathname - (merge-pathnames (string-append "#tmp#" (number->string i)) - directory))) - (if (allocate-temporary-file pathname) - (begin - (deallocate-temporary-file pathname) - pathname) - (loop (+ i 1)))))) - (os/auto-save-pathname pathname #f))) - -(define (os/auto-save-pathname pathname buffer) - (let ((pathname - (or pathname - (let ((directory (buffer-default-directory buffer))) - (merge-pathnames (if (os2/fs-long-filenames? directory) - (string-append "%" - (buffer-hpfs-name buffer)) - "%buffer%") - directory))))) - (if (os2/fs-long-filenames? pathname) - (merge-pathnames (string-append "#" (file-namestring pathname) "#") - (directory-pathname pathname)) - (pathname-new-type pathname "sav")))) - -(define (buffer-hpfs-name buffer) - (let ((name (buffer-name buffer))) - (let ((length (string-length name))) - (let ((copy (make-string length))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i length)) - (string-set! - copy i - (let ((char (string-ref name i))) - (if (char-set-member? char-set:valid-hpfs-chars - char) - char - #\_)))) - copy)))) - -(define char-set:valid-hpfs-chars - (char-set-invert - (char-set-union (char-set #\\ #\/ #\: #\* #\? #\" #\< #\> #\|) - (char-set-union (ascii-range->char-set 0 #x21) - (ascii-range->char-set #x7F #x100))))) - -;;;; Miscellaneous - -(define (os/backup-buffer? truename) - (let ((attrs (file-attributes truename))) - (and attrs - (eq? #f (file-attributes/type attrs))))) -(define (os/backup-by-copying? truename buffer) - truename buffer - #f) - -(define (os/pathname-type-for-mode pathname) - (let ((type (pathname-type pathname))) - (if (member type os2/encoding-pathname-types) - (pathname-type (->namestring (pathname-new-type pathname false))) - type))) - -(define (os/completion-ignore-filename? filename) - (or (os/backup-filename? filename) - (os/auto-save-filename? filename) - (and (not (file-directory? filename)) - (there-exists? (ref-variable completion-ignored-extensions) - (lambda (extension) - (string-suffix? extension filename)))))) - -(define (os/file-type-to-major-mode) - (alist-copy - `(("asm" . midas) - ("bat" . text) - ("bib" . text) - ("c" . c) - ("h" . c) - ("m4" . midas) - ("pas" . pascal) - ("s" . scheme) - ("scm" . scheme) - ("txi" . texinfo) - ("txt" . text)))) - -(define (os/init-file-name) - (let ((name "edwin.ini")) - (let ((user-init-file (merge-pathnames name (user-homedir-pathname)))) - (if (file-exists? user-init-file) - user-init-file - (merge-pathnames name (system-library-directory-pathname #f)))))) - -(define (os/find-file-initialization-filename pathname) - (or (and (equal? "scm" (pathname-type pathname)) - (let ((pathname (pathname-new-type pathname "ffi"))) - (and (file-exists? pathname) - pathname))) - (let ((pathname - (merge-pathnames "edwin.ffi" (directory-pathname pathname)))) - (and (file-exists? pathname) - pathname)))) +(define (os/set-file-modes-writable! pathname) + (set-file-modes! pathname (fix:andc (file-modes pathname) #x0001))) (define (os/scheme-can-quit?) #f) @@ -374,9 +86,6 @@ Includes the new backup. Must be > 0." (define (os/quit dir) dir (error "Can't quit.")) - -(define (os/set-file-modes-writable! pathname) - (set-file-modes! pathname (fix:andc (file-modes pathname) #x0001))) ;;;; OS/2 Clipboard Interface @@ -539,85 +248,6 @@ Includes the new backup. Must be > 0." (+ (* (quotient time 16) 12) (remainder time 16)))) -;;;; Subprocess/Shell Support - -(define (os/parse-path-string string) - (let ((end (string-length string)) - (substring - (lambda (string start end) - (pathname-as-directory (substring string start end))))) - (let loop ((start 0)) - (if (< start end) - (let ((index (substring-find-next-char string start end #\;))) - (if index - (if (= index start) - (loop (+ index 1)) - (cons (substring string start index) - (loop (+ index 1)))) - (list (substring string start end)))) - '())))) - -(define (os/find-program program default-directory) - (or (os2/find-program program (ref-variable exec-path) default-directory) - (error "Can't find program:" (->namestring program)))) - -(define (os2/find-program program exec-path default-directory) - (let* ((types '("exe" "cmd")) - (try - (lambda (pathname) - (let ((type (pathname-type pathname))) - (if type - (and (member type types) - (file-exists? pathname) - (->namestring pathname)) - (let loop ((types types)) - (and (not (null? types)) - (let ((p - (pathname-new-type pathname (car types)))) - (if (file-exists? p) - (->namestring p) - (loop (cdr types))))))))))) - (cond ((pathname-absolute? program) - (try program)) - ((not default-directory) - (let loop ((path exec-path)) - (and (not (null? path)) - (or (and (pathname-absolute? (car path)) - (try (merge-pathnames program (car path)))) - (loop (cdr path)))))) - (else - (let ((default-directory (merge-pathnames default-directory))) - (let loop ((path exec-path)) - (and (not (null? path)) - (or (try (merge-pathnames - program - (merge-pathnames (car path) - default-directory))) - (loop (cdr path)))))))))) - -(define (os/shell-file-name) - (or (get-environment-variable "SHELL") - "cmd.exe")) - -(define (os/form-shell-command command) - (list "/c" command)) - -(define (os/shell-name pathname) - (if (member (pathname-type pathname) '("exe" "cmd")) - (pathname-name pathname) - (file-namestring pathname))) - -(define (os/default-shell-prompt-pattern) - "^\\[[^]]*] *") - -(define (os/default-shell-args) - '()) - -(define (os/comint-filename-region start point end) - (let ((chars "]\\\\A-Za-z0-9!#$%&'()+,.:;=@[^_`{}~---")) - (let ((start (skip-chars-backward chars point start))) - (make-region start (skip-chars-forward chars start end))))) - ;;;; Compressed Files (define (os/read-file-methods) @@ -634,7 +264,7 @@ Includes the new backup. Must be > 0." (define (os/alternate-pathnames group pathname) (if (and (ref-variable enable-compressed-files group) - (os2/fs-long-filenames? pathname) + (dos/fs-long-filenames? pathname) (not (equal? "gz" (pathname-type pathname)))) (list (string-append (->namestring pathname) ".gz")) '())) @@ -708,7 +338,7 @@ filename suffix \".gz\"." (define (os2-pop-client server user-name password directory) (let ((target (->namestring - (merge-pathnames (if (os2/fs-long-filenames? directory) + (merge-pathnames (if (dos/fs-long-filenames? directory) ".popmail" "popmail.tmp") directory))))