Update of /var/lib/cvs/src/common/system/file-system
In directory cantor:/tmp/cvs-serv4899/file-system
Added Files:
file-stream.dylan file-system.dylan macintosh-locators.dylan
microsoft-locators.dylan native-microsoft-locators.dylan
native-posix-locators.dylan posix-locators.dylan
unix-ffi.dylan unix-file-accessor.dylan unix-file-system.dylan
unix-interface.dylan win32-ffi.dylan win32-file-accessor.dylan
win32-file-system.dylan win32-interface.dylan
wrapper-file-accessor.dylan
Log Message:
Port to Gwydion Dylan of the Functional Developer system library
and its test suite.
--- NEW FILE: file-stream.dylan ---
Module: system-internals
Synopsis: Implementation of concrete file streams
Author: Toby Weinberg, Scott McKay, Marc Ferguson, Eliot Miranda
Copyright: Original Code is Copyright (c) 1994-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define sideways sealed method open-file-stream
(locator :: <file-locator>, #rest keywords, #key, #all-keys)
=> (stream :: <stream>)
apply(make, <file-stream>, locator: locator, keywords)
end method open-file-stream;
define sideways sealed method open-file-stream
(string :: <string>, #rest keywords, #key, #all-keys)
=> (stream :: <file-stream>)
apply(open-file-stream, as(<file-locator>, string), keywords)
end method open-file-stream;
define macro with-open-file
{ with-open-file (?stream:variable = ?locator:expression,
#rest ?keys:expression)
?body:body
end }
=> { begin
let _stream = #f;
block ()
_stream := open-file-stream(?locator, ?keys);
let ?stream :: <file-stream> = _stream;
?body
cleanup
if (_stream & stream-open?(_stream)) close(_stream) end;
end
end }
end macro with-open-file;
--- NEW FILE: file-system.dylan ---
Module: system-internals
Author: Gary Palter
Synopsis: A platform independent file system API
Copyright: Original Code is Copyright (c) 1998-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// Types
/// Needs a better name, I think ...
define constant <file-type> = one-of(#"file", #"directory", #"link");
define constant <copy/rename-disposition> = one-of(#"signal", #"replace");
define open abstract class <file-system-locator> (<physical-locator>)
end class <file-system-locator>;
define class <file-system-directory-locator> (<file-system-locator>,
<directory-locator>)
end class <file-system-directory-locator>;
define class <file-system-file-locator> (<file-system-locator>, <file-locator>)
end class <file-system-file-locator>;
define sealed class <file-system-error> (<error>, <simple-condition>)
end class <file-system-error>;
define sealed class <file-error> (<file-system-error>)
constant slot file-error-locator :: <file-system-file-locator>,
required-init-keyword: locator:;
end class <file-error>;
define sealed class <file-exists-error> (<file-error>)
end class <file-exists-error>;
define sealed class <file-does-not-exist-error> (<file-error>)
end class <file-does-not-exist-error>;
define sealed class <invalid-file-permissions-error> (<file-error>)
end class <invalid-file-permissions-error>;
/// Locators
define constant <pathname> = type-union(<string>, <file-system-locator>);
define method as
(class == <file-system-locator>, string :: <string>)
=> (locator :: <file-system-locator>)
as(<native-file-system-locator>, string)
end method as;
/// Condition reporting
define method condition-to-string
(error :: <file-exists-error>) => (string :: <string>)
format-to-string("File %s exists", file-error-locator(error))
end method condition-to-string;
define method condition-to-string
(error :: <file-does-not-exist-error>) => (string :: <string>)
format-to-string("File %s does not exist", file-error-locator(error))
end method condition-to-string;
define method condition-to-string
(error :: <invalid-file-permissions-error>) => (string :: <string>)
format-to-string("Invalid file permissions for file %s",
file-error-locator(error))
end method condition-to-string;
/// And now, the functions ...
/// Given a pathname, returns its fully exanded form
define generic expand-pathname (path :: <pathname>) => (expanded-path ::
<pathname>);
define method expand-pathname (path :: <file-system-locator>) => (expanded-path
:: <pathname>)
%expand-pathname(path)
end method expand-pathname;
define method expand-pathname (path :: <string>) => (expanded-path ::
<pathname>)
expand-pathname(as(<file-system-locator>, path))
end method expand-pathname;
/// Given a pathname, returns the shortest equivalent form (e.g., a DOS
pathname on Windows)
define generic shorten-pathname (path :: <pathname>) => (shortened-path ::
<pathname>);
define method shorten-pathname (path :: <file-system-locator>) =>
(shortened-path :: <pathname>)
%shorten-pathname(path)
end method shorten-pathname;
define method shorten-pathname (path :: <string>) => (shortened-path ::
<pathname>)
shorten-pathname(as(<file-system-locator>, path))
end method shorten-pathname;
///
define generic file-exists? (file :: <pathname>) => (exists? :: <boolean>);
define method file-exists? (file :: <file-system-locator>) => (exists? ::
<boolean>);
%file-exists?(file)
end method file-exists?;
define method file-exists? (file :: <string>) => (exists? :: <boolean>);
file-exists?(as(<file-system-locator>, file))
end method file-exists?;
///
define generic file-type (file :: <pathname>) => (file-type :: <file-type>);
define method file-type (file :: <file-system-locator>) => (file-type ::
<file-type>)
%file-type(file)
end method file-type;
define method file-type (file :: <string>) => (file-type :: <file-type>)
file-type(as(<file-system-locator>, file))
end method file-type;
///
define generic link-target (link :: <pathname>) => (target :: <pathname>);
define method link-target (link :: <file-system-locator>) => (target ::
<pathname>)
%link-target(link)
end method link-target;
define method link-target (link :: <string>) => (target :: <pathname>)
link-target(as(<file-system-locator>, link))
end method link-target;
///
define generic delete-file (file :: <pathname>) => ();
define method delete-file (file :: <file-system-locator>) => ()
%delete-file(file)
end method delete-file;
define method delete-file (file :: <string>) => ()
delete-file(as(<file-system-locator>, file))
end method delete-file;
///
define generic copy-file
(source :: <pathname>, destination :: <pathname>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ();
define method copy-file
(source :: <file-system-locator>, destination :: <file-system-locator>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
%copy-file(source, destination, if-exists: if-exists)
end method copy-file;
define method copy-file
(source :: <file-system-locator>, destination :: <string>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
copy-file(source, as(<file-system-locator>, destination), if-exists:
if-exists)
end method copy-file;
define method copy-file
(source :: <string>, destination :: <file-system-locator>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
copy-file(as(<file-system-locator>, source), destination, if-exists:
if-exists)
end method copy-file;
define method copy-file
(source :: <string>, destination :: <string>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
copy-file(as(<file-system-locator>, source), as(<file-system-locator>,
destination),
if-exists: if-exists)
end method copy-file;
///
define generic rename-file
(source :: <pathname>, destination :: <pathname>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ();
define method rename-file
(source :: <file-system-locator>, destination :: <file-system-locator>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
%rename-file(source, destination, if-exists: if-exists)
end method rename-file;
define method rename-file
(source :: <file-system-locator>, destination :: <string>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
rename-file(source, as(<file-system-locator>, destination),
if-exists: if-exists)
end method rename-file;
define method rename-file
(source :: <string>, destination :: <file-system-locator>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
rename-file(as(<file-system-locator>, source), destination,
if-exists: if-exists)
end method rename-file;
define method rename-file
(source :: <string>, destination :: <string>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
rename-file(as(<file-system-locator>, source), as(<file-system-locator>,
destination),
if-exists: if-exists)
end method rename-file;
///
define generic file-properties
(file :: <pathname>) => (properties :: <explicit-key-collection>);
define method file-properties
(file :: <file-system-locator>) => (properties :: <explicit-key-collection>)
let properties = %file-properties(file);
properties[#"write-date"] := properties[#"modification-date"];
properties
end method file-properties;
define method file-properties
(file :: <string>) => (properties :: <explicit-key-collection>)
file-properties(as(<file-system-locator>, file))
end method file-properties;
/// "Standard" properties are:
/// author, size, creation-date, access-date, modification-date, readable?,
executable?
/// Other properties may be defined by the platform.
define generic file-property (file :: <pathname>, key :: <symbol>) => (value);
define method file-property (file :: <file-system-locator>, key :: <symbol>) =>
(value)
%file-property(file, key)
end method file-property;
define method file-property (file :: <string>, key :: <symbol>) => (value)
file-property(as(<file-system-locator>, file), key)
end method file-property;
define generic %file-property (file :: <file-system-locator>, key :: <symbol>)
=> (value);
define method %file-property (file :: <file-system-locator>, key ==
#"write-date")
=> (write-date :: false-or(<date>))
%file-property(file, #"modification-date")
end method %file-property;
define method %file-property (file :: <file-system-locator>, key :: <symbol>)
=> (value)
error(make(<file-system-error>,
format-string: "Native file system does not implement the %s
property",
format-arguments: list(key)))
end method %file-property;
/// Not all properties are settable:
/// See the platform's implementation for details
define generic file-property-setter
(new-value, file :: <pathname>, key :: <symbol>) => (new-value);
define method file-property-setter
(new-value, file :: <file-system-locator>, key :: <symbol>) => (new-value)
%file-property-setter(new-value, file, key)
end method file-property-setter;
define method file-property-setter
(new-value, file :: <string>, key :: <symbol>) => (new-value)
file-property-setter(new-value, as(<file-system-locator>, file), key)
end method file-property-setter;
define generic %file-property-setter
(new-value, file :: <pathname>, key :: <symbol>) => (new-value);
define method %file-property-setter
(new-write-date :: false-or(<date>), file :: <file-system-locator>, key ==
#"write-date")
=> (new-write-date :: false-or(<date>))
%file-property-setter(new-write-date, file, #"modification-date")
end method %file-property-setter;
define method %file-property-setter
(new-value, file :: <file-system-locator>, key :: <symbol>) => (new-value)
error(make(<file-system-error>,
format-string: "Native file system cannot set the %s property",
format-arguments: list(key)))
end method %file-property-setter;
///
define generic do-directory (f :: <function>, directory :: <pathname>) => ();
define method do-directory (f :: <function>, directory ::
<file-system-directory-locator>) => ()
%do-directory(f, directory)
end method do-directory;
define method do-directory (f :: <function>, directory ::
<file-system-file-locator>) => ()
do-directory(f, locator-directory(directory))
end method do-directory;
define method do-directory (f :: <function>, directory :: <string>) => ()
do-directory(f, as(<file-system-locator>, directory))
end method do-directory;
///---*** FINISH ME!
define function directory-contents () => ()
error(make(<file-system-error>,
format-string: "directory-contents is not yet implemented",
format-arguments: #()))
end function directory-contents;
///
define generic create-directory (parent :: <pathname>, name :: <string>)
=> (directory :: <pathname>);
define method create-directory (parent :: <file-system-directory-locator>, name
:: <string>)
=> (directory :: <pathname>)
let directory = subdirectory-locator(parent, name);
%create-directory(directory)
end method create-directory;
define method create-directory (parent :: <file-system-file-locator>, name ::
<string>)
=> (directory :: <pathname>)
create-directory(locator-directory(parent), name)
end method create-directory;
define method create-directory (parent :: <string>, name :: <string>)
=> (directory :: <pathname>)
create-directory(as(<file-system-directory-locator>, parent), name)
end method create-directory;
///
///---*** Should we add an 'if-not-empty?' keyword argument?
define generic delete-directory (directory :: <pathname>) => ();
define method delete-directory (directory :: <file-system-directory-locator>)
=> ()
%delete-directory(directory)
end method delete-directory;
define method delete-directory (directory :: <file-system-file-locator>) => ()
delete-directory(locator-directory(directory))
end method delete-directory;
define method delete-directory (directory :: <string>) => ()
delete-directory(as(<file-system-directory-locator>, directory))
end method delete-directory;
///
define generic ensure-directories-exist (file :: <pathname>) => (created? ::
<boolean>);
define method ensure-directories-exist (file :: <file-system-directory-locator>)
=> (created? :: <boolean>)
local method doit (directory :: false-or(<file-system-directory-locator>)) =>
(created? :: <boolean>)
if (false?(directory))
#f // Presume that the root exists...
elseif (file-exists?(directory))
#f
else
let parent = locator-directory(directory);
doit(parent);
%create-directory(directory);
#t
end
end method doit;
doit(file)
end method ensure-directories-exist;
define method ensure-directories-exist (file :: <file-system-file-locator>) =>
(created? :: <boolean>)
ensure-directories-exist(locator-directory(file))
end method ensure-directories-exist;
define method ensure-directories-exist (file :: <string>) => (created? ::
<boolean>)
ensure-directories-exist(as(<file-system-locator>, file))
end method ensure-directories-exist;
///
define generic directory-empty? (directory :: <pathname>) => (empty? ::
<boolean>);
define method directory-empty? (directory :: <file-system-directory-locator>)
=> (empty? :: <boolean>)
%directory-empty?(directory)
end method directory-empty?;
define method directory-empty? (directory :: <file-system-file-locator>) =>
(empty? :: <boolean>)
directory-empty?(locator-directory(directory))
end method directory-empty?;
define method directory-empty? (directory :: <string>) => (empty? :: <boolean>)
directory-empty?(as(<file-system-locator>, directory))
end method directory-empty?;
///
define function home-directory () => (home-directory :: false-or(<pathname>))
%home-directory()
end function home-directory;
///
define function working-directory () => (working-directory ::
false-or(<pathname>))
%working-directory()
end function working-directory;
///
define generic working-directory-setter (new-working-directory :: <pathname>)
=> (new-working-directory :: <pathname>);
define method working-directory-setter (new-working-directory ::
<file-system-locator>)
=> (new-working-directory :: <pathname>)
%working-directory-setter(new-working-directory)
end method working-directory-setter;
define method working-directory-setter (new-working-directory ::
<file-system-file-locator>)
=> (new-working-directory :: <pathname>)
working-directory-setter(locator-directory(new-working-directory))
end method working-directory-setter;
define method working-directory-setter (new-working-directory :: <string>)
=> (new-working-directory :: <pathname>)
working-directory-setter(as(<file-system-directory-locator>,
new-working-directory))
end method working-directory-setter;
///
define function temp-directory () => (temp-directory :: false-or(<pathname>))
%temp-directory()
end function temp-directory;
///
define function root-directories () => (roots :: <sequence>)
%root-directories()
end function root-directories;
/// Finally, two functions defined as part of Common Dylan's locators-protocol
module
///
define sideways method supports-list-locator?
(directory :: <file-system-directory-locator>) => (listable? :: <boolean>)
~directory.locator-relative?
end method supports-list-locator?;
///
define sideways method list-locator
(locator :: <file-system-directory-locator>) => (locators :: <sequence>)
let locators :: <stretchy-object-vector> = make(<stretchy-object-vector>);
do-directory
(method (directory :: <pathname>, name :: <string>, type :: <file-type>)
ignore(directory);
let sublocator
= select (type)
#"file", #"link" =>
make(<file-system-file-locator>,
directory: locator,
name: name);
#"directory" =>
subdirectory-locator(locator, name);
end;
add!(locators, sublocator)
end,
locator);
locators
end method list-locator;
--- NEW FILE: macintosh-locators.dylan ---
Module: system-internals
Synopsis: Abstract modeling of locations
Author: Gary Palter
Copyright: Original Code is Copyright (c) 1999-2000 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define constant $macintosh-separator = ':';
define constant $macintosh-extension-separator = '.';
define sealed abstract class <macintosh-server-locator> (<server-locator>)
end class <macintosh-server-locator>;
define sealed class <macintosh-volume-locator> (<macintosh-server-locator>)
sealed constant slot locator-volume :: <byte-string>,
required-init-keyword: volume:;
end class <macintosh-volume-locator>;
define sealed method make
(class == <macintosh-volume-locator>,
#key name :: false-or(<string>) = #f,
volume :: false-or(<string>) = #f)
=> (locator :: <macintosh-volume-locator>)
next-method(class, volume: volume | name)
end method make;
define sealed method locator-name
(locator :: <macintosh-volume-locator>) => (name :: <string>)
locator.locator-volume
end method locator-name;
define sealed method \=
(locator1 :: <macintosh-volume-locator>,
locator2 :: <macintosh-volume-locator>)
=> (equal? :: <boolean>)
case-insensitive=(locator1.locator-volume, locator2.locator-volume)
end method \=;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <macintosh-volume-locator>)
=> (string :: <string>)
concatenate-as(class,
locator.locator-name,
delimiter-to-string($macintosh-separator))
end method locator-as-string;
define sealed abstract class <macintosh-file-system-locator>
(<file-system-locator>)
end class <macintosh-file-system-locator>;
define sealed method string-as-locator
(class == <macintosh-file-system-locator>, string :: <string>)
=> (locator :: <macintosh-file-system-locator>)
let pos = find-delimiter-from-end(string, $macintosh-separator);
if (pos == string.size - 1)
string-as-locator(<macintosh-directory-locator>, string)
else
string-as-locator(<macintosh-file-locator>, string)
end
end method string-as-locator;
define sealed class <macintosh-directory-locator>
(<file-system-directory-locator>, <macintosh-file-system-locator>)
sealed constant slot locator-server :: false-or(<macintosh-server-locator>) =
#f,
init-keyword: server:;
sealed constant slot locator-relative? :: <boolean> = #f,
init-keyword: relative?:;
sealed constant slot locator-path :: <simple-object-vector>,
required-init-keyword: path:;
end class <macintosh-directory-locator>;
define sealed method make
(class == <macintosh-directory-locator>,
#key server :: false-or(<macintosh-server-locator>) = #f,
path :: false-or(<sequence>) = #f,
relative? :: <boolean> = #f,
directory :: false-or(<macintosh-directory-locator>) = #f,
name :: false-or(<string>))
=> (locator :: <macintosh-directory-locator>)
let path
= if (name | directory)
concatenate(if (directory) directory.locator-path else #[] end,
if (name) vector(name) else #[] end)
elseif (path)
as(<simple-object-vector>, path)
else
#[]
end;
next-method(class,
server: server,
path: path,
relative?: relative?)
end method make;
define sealed method locator-name
(locator :: <macintosh-directory-locator>)
=> (name :: false-or(<string>))
let path = locator.locator-path;
unless (empty?(path))
path[size(path) - 1]
end
end method locator-name;
define sealed method \=
(locator1 :: <macintosh-directory-locator>,
locator2 :: <macintosh-directory-locator>)
=> (equal? :: <boolean>)
locator1.locator-relative? = locator2.locator-relative?
& locator1.locator-server = locator2.locator-server
& locator1.locator-path.size = locator2.locator-path.size
& every?(case-insensitive=, locator1.locator-path, locator2.locator-path)
end method \=;
define sealed method string-as-locator
(class == <macintosh-directory-locator>, string :: <string>)
=> (locator :: <macintosh-directory-locator>)
let relative? = string[0] = $macintosh-separator;
let (server, start)
= if (relative?)
values(#f, 0)
else
let pos = find-delimiter(string, $macintosh-separator)
// If there's just a name, presume it's a volume name ...
| size(string);
let volume = copy-sequence(string, end: pos);
values(make(<macintosh-volume-locator>, volume: volume), pos)
end;
let path = macintosh-parse-path(string, relative?: relative?, start: start);
make(<macintosh-directory-locator>,
server: server,
path: path,
relative?: relative?)
end method string-as-locator;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <macintosh-directory-locator>)
=> (string :: <string>)
let server = locator.locator-server;
let path = locator.locator-path;
let relative? = locator.locator-relative?;
let directory-string
= macintosh-path-to-string(locator.locator-path, locator.locator-relative?,
class);
if (server)
concatenate-as(class,
as(class, server),
directory-string)
else
directory-string
end
end method locator-as-string;
define sealed method locator-test
(locator :: <macintosh-directory-locator>) => (test :: <function>)
case-insensitive=
end method locator-test;
define method macintosh-parse-path
(string :: <string>,
#key relative? :: <boolean> = #f,
start :: <integer> = 0,
end: stop :: <integer> = string.size)
=> (path :: <simple-object-vector>)
let path :: <stretchy-object-vector> = make(<stretchy-object-vector>);
let old-position :: <integer> = start;
let position :: <integer> = old-position;
while (position < stop)
let character = string[position];
if (character = $macintosh-separator)
case
position = start =>
// Ensures that ":" satisfies the current-directory-locator?
predicate...
if (relative?)
add!(path, #"self")
end;
string[position - 1] = $macintosh-separator =>
add!(path, #"parent");
end;
if (old-position < position)
add!(path, copy-sequence(string, start: old-position, end: position))
end;
old-position := position + 1;
end;
position := position + 1
end;
if (old-position < stop)
add!(path, copy-sequence(string, start: old-position, end: stop))
end;
as(<simple-object-vector>, path)
end method macintosh-parse-path;
/*
//---*** It is a pity that we need this for efficiency...
define sealed copy-down-method macintosh-parse-path
(string :: <byte-string>,
#key relative? :: <boolean> = #f,
start :: <integer> = 0,
end: stop :: <integer> = string.size)
=> (path :: <simple-object-vector>);
*/
define function macintosh-path-to-string
(path :: <sequence>, relative? :: <boolean>, class :: subclass(<string>))
=> (string :: <string>)
let string-size :: <integer> = size(path) + if (relative?) 1 else 0 end;
for (item in path)
let item-size = select (item)
#"self" => -1; // Not even a separator will
appear ...
#"parent" => 0;
otherwise => item.size;
end;
string-size := string-size + item-size;
end;
let string = make(class, size: string-size);
let pos :: <integer> = 0;
if (relative?)
string[pos] := $macintosh-separator;
pos := pos + 1;
end;
for (item in path)
select (item)
#"self" =>
#f;
#"parent" =>
string[pos] := $macintosh-separator;
pos := pos + 1;
otherwise =>
for (character :: <character> in item)
string[pos] := character;
pos := pos + 1;
end;
string[pos] := $macintosh-separator;
pos := pos + 1;
end
end;
string
end function macintosh-path-to-string;
define sealed class <macintosh-file-locator>
(<file-system-file-locator>, <macintosh-file-system-locator>)
sealed constant slot locator-directory ::
false-or(<macintosh-directory-locator>) = #f,
init-keyword: directory:;
sealed constant slot locator-base :: false-or(<string>) = #f,
init-keyword: base:;
sealed constant slot locator-extension :: false-or(<string>) = #f,
init-keyword: extension:;
end class <macintosh-file-locator>;
define sealed method make
(class == <macintosh-file-locator>,
#key directory :: false-or(<macintosh-directory-locator>) = #f,
base :: false-or(<string>),
extension :: false-or(<string>),
name :: false-or(<string>))
=> (locator :: <macintosh-file-locator>)
let directory
= unless (directory & current-directory-locator?(directory))
directory
end;
let pos = name & find-delimiter-from-end(name,
$macintosh-extension-separator);
let base = base | if (pos) copy-sequence(name, end: pos) else name end;
let extension = extension | if (pos) copy-sequence(name, start: pos + 1) end;
if (~base)
locator-error("Attemped to create a file locator without a base")
end;
next-method(class,
directory: directory,
base: base,
extension: extension)
end method make;
define sealed method locator-name
(locator :: <macintosh-file-locator>)
=> (name :: false-or(<string>))
let base = locator.locator-base;
let extension = locator.locator-extension;
if (extension)
concatenate(base | "",
delimiter-to-string($macintosh-extension-separator),
extension)
else
base
end
end method locator-name;
define sealed method \=
(locator1 :: <macintosh-file-locator>,
locator2 :: <macintosh-file-locator>)
=> (equal? :: <boolean>)
locator1.locator-directory = locator2.locator-directory
& case-insensitive=(locator1.locator-base, locator2.locator-base)
& case-insensitive=(locator1.locator-extension, locator2.locator-extension)
end method \=;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <macintosh-file-locator>)
=> (string :: <string>)
let directory = locator.locator-directory;
let name = locator.locator-name;
if (directory)
concatenate-as(class, as(<string>, directory), name)
else
as(class, name)
end
end method locator-as-string;
define sealed method string-as-locator
(class == <macintosh-file-locator>, string :: <string>)
=> (locator :: <macintosh-file-locator>)
let pos = find-delimiter-from-end(string, $macintosh-separator);
let (directory, name)
= if (pos)
values(as(<macintosh-directory-locator>,
// Include trailing separator to properly handle #"parent"
// references that appear just before the filename ...
copy-sequence(string, end: pos + 1)),
copy-sequence(string, start: pos + 1))
else
values(#f, string)
end;
make(<macintosh-file-locator>,
directory: directory,
name: name)
end method string-as-locator;
--- NEW FILE: microsoft-locators.dylan ---
Module: system-internals
Synopsis: Abstract modeling of locations
Author: Andy Armstrong
Copyright: Original Code is Copyright (c) 1999-2000 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define constant $microsoft-separators = #['\\', '/'];
define constant $extension-separator = '.';
define constant $volume-separator = ':';
define constant $unc-prefix = "\\\\";
define constant $alternative-unc-prefix = "//";
define sealed abstract class <microsoft-server-locator> (<server-locator>)
end class <microsoft-server-locator>;
define sealed class <microsoft-unc-locator> (<microsoft-server-locator>)
sealed constant slot locator-host :: <string>,
required-init-keyword: host:;
end class <microsoft-unc-locator>;
define sealed method make
(class == <microsoft-unc-locator>,
#key name :: false-or(<string>) = #f,
host :: false-or(<string>) = #f)
=> (locator :: <microsoft-unc-locator>)
next-method(class, host: host | name)
end method make;
define sealed method locator-name
(locator :: <microsoft-unc-locator>) => (name :: <string>)
locator.locator-host
end method locator-name;
define sealed method \=
(locator1 :: <microsoft-unc-locator>,
locator2 :: <microsoft-unc-locator>)
=> (equal? :: <boolean>)
case-insensitive=(locator1.locator-host, locator2.locator-host)
end method \=;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <microsoft-unc-locator>)
=> (string :: <string>)
concatenate-as(class, $unc-prefix, locator.locator-host)
end method locator-as-string;
define sealed class <microsoft-volume-locator> (<microsoft-server-locator>)
sealed constant slot locator-drive :: <character>,
required-init-keyword: drive:;
end class <microsoft-volume-locator>;
define sealed method make
(class == <microsoft-volume-locator>,
#key name :: false-or(<string>) = #f,
volume :: false-or(<string>) = name,
drive :: false-or(<character>) = #f)
=> (locator :: <microsoft-volume-locator>)
if (volume)
unless (volume.size == 1)
locator-error("Invalid drive specification %=", volume)
end;
next-method(class, drive: volume[0])
else
next-method()
end
end method make;
define sealed method locator-volume
(locator :: <microsoft-volume-locator>) => (volume :: <string>)
make(<byte-string>, size: 1, fill: locator.locator-drive)
end method locator-volume;
define sealed method locator-name
(locator :: <microsoft-volume-locator>) => (name :: <string>)
locator.locator-volume
end method locator-name;
define sealed method \=
(locator1 :: <microsoft-volume-locator>,
locator2 :: <microsoft-volume-locator>)
=> (equal? :: <boolean>)
case-insensitive=(locator1.locator-drive, locator2.locator-drive)
end method \=;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <microsoft-volume-locator>)
=> (string :: <string>)
concatenate-as(class,
make(<byte-string>, size: 1, fill: locator.locator-drive),
delimiter-to-string($volume-separator))
end method locator-as-string;
define sealed abstract class <microsoft-file-system-locator>
(<file-system-locator>)
end class <microsoft-file-system-locator>;
define sealed method string-as-locator
(class == <microsoft-file-system-locator>, string :: <string>)
=> (locator :: <microsoft-file-system-locator>)
let pos = find-delimiters-from-end(string, $microsoft-separators);
if (pos == string.size - 1)
string-as-locator(<microsoft-directory-locator>, string)
else
string-as-locator(<microsoft-file-locator>, string)
end
end method string-as-locator;
define sealed class <microsoft-directory-locator>
(<file-system-directory-locator>, <microsoft-file-system-locator>)
sealed constant slot locator-server :: false-or(<microsoft-server-locator>) =
#f,
init-keyword: server:;
sealed constant slot locator-relative? :: <boolean> = #f,
init-keyword: relative?:;
sealed constant slot locator-path :: <simple-object-vector>,
required-init-keyword: path:;
end class <microsoft-directory-locator>;
define sealed method make
(class == <microsoft-directory-locator>,
#key server :: false-or(<microsoft-server-locator>) = #f,
path :: false-or(<sequence>) = #f,
relative? :: <boolean> = #f,
directory :: false-or(<microsoft-directory-locator>) = #f,
name :: false-or(<string>))
=> (locator :: <microsoft-directory-locator>)
let path
= if (name | directory)
concatenate(if (directory) directory.locator-path else #[] end,
if (name) vector(name) else #[] end)
else
path
end;
next-method(class,
server: server,
path: canonicalize-path(path),
relative?: relative?)
end method make;
define sealed method locator-name
(locator :: <microsoft-directory-locator>)
=> (name :: false-or(<string>))
let path = locator.locator-path;
unless (empty?(path))
path[size(path) - 1]
end
end method locator-name;
define sealed method \=
(locator1 :: <microsoft-directory-locator>,
locator2 :: <microsoft-directory-locator>)
=> (equal? :: <boolean>)
locator1.locator-relative? = locator2.locator-relative?
& locator1.locator-server = locator2.locator-server
& locator1.locator-path.size = locator2.locator-path.size
& every?(case-insensitive=, locator1.locator-path, locator2.locator-path)
end method \=;
define sealed method string-as-locator
(class == <microsoft-directory-locator>, string :: <string>)
=> (locator :: <microsoft-directory-locator>)
let unc?
= prefix-equal?(string, $unc-prefix)
| prefix-equal?(string, $alternative-unc-prefix);
let volume?
= ~unc? & string.size > 1 & string[1] == $volume-separator;
let (server, next-pos)
= case
unc? =>
let start = $unc-prefix.size;
let pos
= find-delimiters(string, $microsoft-separators, start: start);
if (pos)
let host = copy-sequence(string, start: start, end: pos);
values(make(<microsoft-unc-locator>, host: host), pos)
else
locator-error("Invalid directory %=", string)
end;
volume? =>
values(make(<microsoft-volume-locator>, drive: string[0]), 2);
otherwise =>
values(#f, 0);
end;
let (path, relative?)
= parse-path(string,
start: next-pos,
test: rcurry(member?, $microsoft-separators));
make(<microsoft-directory-locator>,
server: server,
path: path,
relative?: relative?)
end method string-as-locator;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <microsoft-directory-locator>)
=> (string :: <string>)
let server = locator.locator-server;
let directory-string
= path-to-string(locator.locator-path,
class: class,
separator: $microsoft-separators[0],
relative?: locator.locator-relative?);
if (server)
concatenate-as(class,
as(class, server),
directory-string)
else
directory-string
end
end method locator-as-string;
define sealed method locator-test
(locator :: <microsoft-directory-locator>) => (test :: <function>)
case-insensitive=
end method locator-test;
define sealed class <microsoft-file-locator>
(<file-system-file-locator>, <microsoft-file-system-locator>)
sealed constant slot locator-directory ::
false-or(<microsoft-directory-locator>) = #f,
init-keyword: directory:;
sealed constant slot locator-base :: false-or(<string>) = #f,
init-keyword: base:;
sealed constant slot locator-extension :: false-or(<string>) = #f,
init-keyword: extension:;
end class <microsoft-file-locator>;
define sealed method make
(class == <microsoft-file-locator>,
#key directory :: false-or(<microsoft-directory-locator>) = #f,
base :: false-or(<string>),
extension :: false-or(<string>),
name :: false-or(<string>))
=> (locator :: <microsoft-file-locator>)
let directory
= unless (directory & current-directory-locator?(directory))
directory
end;
let pos = name & find-delimiter-from-end(name, $extension-separator);
let base = base | if (pos) copy-sequence(name, end: pos) else name end;
let extension = extension | if (pos) copy-sequence(name, start: pos + 1) end;
if (~base)
locator-error("Attemped to create a file locator without a base")
end;
next-method(class,
directory: directory,
base: base,
extension: extension)
end method make;
define sealed method locator-name
(locator :: <microsoft-file-locator>)
=> (name :: false-or(<string>))
let base = locator.locator-base;
let extension = locator.locator-extension;
if (extension)
concatenate(base | "",
delimiter-to-string($extension-separator),
extension)
else
base
end
end method locator-name;
define sealed method \=
(locator1 :: <microsoft-file-locator>,
locator2 :: <microsoft-file-locator>)
=> (equal? :: <boolean>)
locator1.locator-directory = locator2.locator-directory
& case-insensitive=(locator1.locator-base, locator2.locator-base)
& case-insensitive=(locator1.locator-extension, locator2.locator-extension)
end method \=;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <microsoft-file-locator>)
=> (string :: <string>)
let directory = locator.locator-directory;
let name = locator.locator-name;
if (directory)
concatenate-as(class, as(<string>, directory), name)
else
as(class, name)
end
end method locator-as-string;
define sealed method string-as-locator
(class == <microsoft-file-locator>, string :: <string>)
=> (locator :: <microsoft-file-locator>)
let pos = find-delimiters-from-end(string, $microsoft-separators);
let (directory, name)
= if (pos)
values(as(<microsoft-directory-locator>,
copy-sequence(string, end: pos + 1)),
copy-sequence(string, start: pos + 1))
else
values(#f, string)
end;
make(<microsoft-file-locator>,
directory: directory,
name: name)
end method string-as-locator;
--- NEW FILE: native-microsoft-locators.dylan ---
Module: system-internals
Synopsis: Abstract modeling of locations
Author: Andy Armstrong
Copyright: Original Code is Copyright (c) 1999-2000 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define constant <native-file-system-locator> = <microsoft-file-system-locator>;
define constant <native-directory-locator> = <microsoft-directory-locator>;
define constant <native-file-locator> = <microsoft-file-locator>;
define function file-system-separator
() => (separator :: <character>)
$microsoft-separators[0]
end function file-system-separator;
--- NEW FILE: native-posix-locators.dylan ---
Module: system-internals
Synopsis: Abstract modeling of locations
Author: Andy Armstrong
Copyright: Original Code is Copyright (c) 1999-2000 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define constant <native-file-system-locator> = <posix-file-system-locator>;
define constant <native-directory-locator> = <posix-directory-locator>;
define constant <native-file-locator> = <posix-file-locator>;
define function file-system-separator
() => (separator :: <character>)
$posix-separator
end function file-system-separator;
--- NEW FILE: posix-locators.dylan ---
Module: system-internals
Synopsis: Abstract modeling of locations
Author: Andy Armstrong
Copyright: Original Code is Copyright (c) 1999-2000 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define constant $posix-separator = '/';
define constant $posix-extension-separator = '.';
define sealed abstract class <posix-file-system-locator> (<file-system-locator>)
end class <posix-file-system-locator>;
define sealed method string-as-locator
(class == <posix-file-system-locator>, string :: <string>)
=> (locator :: <posix-file-system-locator>)
let pos = find-delimiter-from-end(string, $posix-separator);
if (pos == string.size - 1)
string-as-locator(<posix-directory-locator>, string)
else
string-as-locator(<posix-file-locator>, string)
end
end method string-as-locator;
define sealed class <posix-directory-locator>
(<file-system-directory-locator>, <posix-file-system-locator>)
sealed constant slot locator-relative? :: <boolean> = #f,
init-keyword: relative?:;
sealed constant slot locator-path :: <simple-object-vector>,
required-init-keyword: path:;
end class <posix-directory-locator>;
define sealed method make
(class == <posix-directory-locator>,
#key server :: false-or(<server-locator>) = #f,
path :: false-or(<sequence>) = #f,
relative? :: <boolean> = #f,
directory :: false-or(<posix-directory-locator>) = #f,
name :: false-or(<string>))
=> (locator :: <posix-directory-locator>)
if (server)
locator-error("Cannot specify server for posix directory locator: %=",
server)
end;
let path
= if (name | directory)
concatenate(if (directory) directory.locator-path else #[] end,
if (name) vector(name) else #[] end)
else
path
end;
next-method(class,
path: canonicalize-path(path),
relative?: relative?)
end method make;
define sealed method initialize
(locator :: <posix-directory-locator>, #key server) => ()
next-method();
end method initialize;
define method locator-server
(locator :: <posix-directory-locator>) => (server :: singleton(#f))
#f
end method locator-server;
define sealed method locator-name
(locator :: <posix-directory-locator>)
=> (name :: false-or(<string>))
let path = locator.locator-path;
unless (empty?(path))
path[size(path) - 1]
end
end method locator-name;
define sealed method \=
(locator1 :: <posix-directory-locator>,
locator2 :: <posix-directory-locator>)
=> (equal? :: <boolean>)
locator1.locator-relative? = locator2.locator-relative?
& locator1.locator-path.size = locator2.locator-path.size
& every?(\=, locator1.locator-path, locator2.locator-path)
end method \=;
define sealed method string-as-locator
(class == <posix-directory-locator>, string :: <string>)
=> (locator :: <posix-directory-locator>)
let (path, relative?)
= parse-path(string, test: curry(\==, $posix-separator));
make(<posix-directory-locator>,
path: path,
relative?: relative?)
end method string-as-locator;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <posix-directory-locator>)
=> (string :: <string>)
let separator = $posix-separator;
path-to-string(locator.locator-path,
class: class,
separator: separator,
relative?: locator.locator-relative?)
end method locator-as-string;
define sealed method locator-test
(locator :: <posix-directory-locator>) => (test :: <function>)
\=
end method locator-test;
define method locator-might-have-links?
(locator :: <posix-directory-locator>) => (links? :: singleton(#t))
#t
end method locator-might-have-links?;
define sealed class <posix-file-locator>
(<file-system-file-locator>, <posix-file-system-locator>)
sealed constant slot locator-directory :: false-or(<posix-directory-locator>)
= #f,
init-keyword: directory:;
sealed constant slot locator-base :: false-or(<string>) = #f,
init-keyword: base:;
sealed constant slot locator-extension :: false-or(<string>) = #f,
init-keyword: extension:;
end class <posix-file-locator>;
define sealed method make
(class == <posix-file-locator>,
#key directory :: false-or(<posix-directory-locator>),
base :: false-or(<string>),
extension :: false-or(<string>),
name :: false-or(<string>))
=> (locator :: <posix-file-locator>)
let directory
= unless (directory & current-directory-locator?(directory))
directory
end;
let pos = name & find-delimiter-from-end(name, $posix-extension-separator);
let base = base | if (pos) copy-sequence(name, end: pos) else name end;
let extension = extension | if (pos) copy-sequence(name, start: pos + 1) end;
if (~base)
locator-error("Attemped to create a file locator without a base")
end;
next-method(class,
directory: directory,
base: base,
extension: extension)
end method make;
define sealed method locator-name
(locator :: <posix-file-locator>)
=> (name :: false-or(<string>))
let base = locator.locator-base;
let extension = locator.locator-extension;
if (extension)
concatenate(base | "",
delimiter-to-string($posix-extension-separator),
extension)
else
base
end
end method locator-name;
define sealed method \=
(locator1 :: <posix-file-locator>,
locator2 :: <posix-file-locator>)
=> (equal? :: <boolean>)
locator1.locator-directory = locator2.locator-directory
& locator1.locator-base = locator2.locator-base
& locator1.locator-extension = locator2.locator-extension
end method \=;
define sealed method locator-as-string
(class :: subclass(<string>), locator :: <posix-file-locator>)
=> (string :: <string>)
let directory = locator.locator-directory;
let name = locator.locator-name;
if (directory)
concatenate-as(class, as(<string>, directory), name)
else
name
end
end method locator-as-string;
define sealed method string-as-locator
(class == <posix-file-locator>, string :: <string>)
=> (locator :: <posix-file-locator>)
let pos = find-delimiter-from-end(string, $posix-separator);
let (directory, name)
= if (pos)
values(as(<posix-directory-locator>,
copy-sequence(string, end: pos)),
copy-sequence(string, start: pos + 1))
else
values(#f, string)
end;
make(<posix-file-locator>,
directory: directory,
name: name)
end method string-as-locator;
/// Posix locator overrides
define method simplify-locator
(locator :: <posix-directory-locator>)
=> (simplified-locator :: <posix-directory-locator>)
// Posix locators can't safely be simplified because '..' has a complicated
// meaning when dealing with links, so just return the original.
locator
end method simplify-locator;
--- NEW FILE: unix-ffi.dylan ---
Module: system-internals
Author: Gary Palter
Synopsis: UNIX implementation of the File System library API
Copyright: Original Code is Copyright (c) 1998-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// From <sys/stat.h> ...
// define constant $S_ISUID = #o0004000; // set user id on execution
// define constant $S_ISGID = #o0002000; // set group id on execution
define constant $S_IRWXU = #o0000700; // read,write,execute perm:
owner
define constant $S_IRUSR = #o0000400; // read permission: owner
define constant $S_IWUSR = #o0000200; // write permission: owner
define constant $S_IXUSR = #o0000100; // execute/search permission:
owner
define constant $S_IRWXG = #o0000070; // read,write,execute perm:
group
define constant $S_IRGRP = #o0000040; // read permission: group
define constant $S_IWGRP = #o0000020; // write permission: group
define constant $S_IXGRP = #o0000010; // execute/search permission:
group
define constant $S_IRWXO = #o0000007; // read,write,execute perm:
other
define constant $S_IROTH = #o0000004; // read permission: other
define constant $S_IWOTH = #o0000002; // write permission: other
define constant $S_IXOTH = #o0000001; // execute/search permission:
other
define constant $S_IFMT = #o0170000; // type of file mask
define constant $S_IFDIR = #o0040000; // directory
define constant $S_IFLNK = #o0120000; // symbolic link
/// From <unistd.h> ...
// define constant $F_OK = #o0;
define constant $X_OK = #o1;
define constant $W_OK = #o2;
define constant $R_OK = #o4;
/// From <errno.h>
define constant $ENOENT = 2;
define constant $EACCESS = 13;
define constant $EINVAL = 22;
/// Used instead of define C-struct to avoid relying on the C-FFI library ...
/// From <sys/stat.h> ...
define system-offset stat-size (alpha 10, x86 22, ppc 22) 18;
define system-offset st-mode (x86 4, ppc 4) 2;
define system-offset st-uid (x86 6, ppc 6) 4;
define system-offset st-gid (x86 7, ppc 7) 5;
define system-offset st-size (alpha 4, x86 11, ppc 11) 7;
define system-offset st-atime (alpha 10, x86 14, ppc 14) 8;
define system-offset st-mtime (alpha 12, x86 16, ppc 16) 10;
define system-offset st-ctime (alpha 14, x86 18, ppc 18) 12;
define constant $STAT_SIZE =
$stat-size-offset * raw-as-integer(primitive-word-size());
define macro with-stack-stat
{ with-stack-stat (?st:name, ?file:expression) ?:body end }
=> { begin
let ?st = primitive-wrap-machine-word(integer-as-raw(0));
block ()
?st := primitive-wrap-machine-word
(primitive-cast-pointer-as-raw
(%call-c-function ("GC_malloc")
(nbytes :: <raw-c-unsigned-long>) => (p ::
<raw-c-pointer>)
(integer-as-raw($STAT_SIZE))
end));
if (primitive-machine-word-equal?(primitive-unwrap-machine-word(?st),
integer-as-raw(0)))
unix-file-error("get space for STAT structure for", "%s", ?file)
end;
?body
cleanup
if
(primitive-machine-word-not-equal?(primitive-unwrap-machine-word(?st),
integer-as-raw(0)))
%call-c-function ("GC_free") (p :: <raw-c-pointer>) => (void ::
<raw-c-void>)
(primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(?st)))
end;
#f
end
end
end }
end macro with-stack-stat;
define inline-only function st-mode (st :: <machine-word>) => (mode ::
<abstract-integer>)
raw-as-abstract-integer
(primitive-c-unsigned-int-at(primitive-unwrap-machine-word(st),
integer-as-raw($st-mode-offset),
integer-as-raw(0)))
end function st-mode;
define inline-only function st-uid (st :: <machine-word>) => (uid ::
<abstract-integer>)
raw-as-abstract-integer
(primitive-c-unsigned-int-at(primitive-unwrap-machine-word(st),
integer-as-raw($st-uid-offset),
integer-as-raw(0)))
end function st-uid;
define inline-only function st-gid (st :: <machine-word>) => (gid ::
<abstract-integer>)
raw-as-abstract-integer
(primitive-c-unsigned-int-at(primitive-unwrap-machine-word(st),
integer-as-raw($st-gid-offset),
integer-as-raw(0)))
end function st-gid;
ignore(st-gid);
define inline-only function st-size (st :: <machine-word>) => (size ::
<abstract-integer>)
raw-as-abstract-integer
(primitive-c-signed-long-at(primitive-unwrap-machine-word(st),
integer-as-raw($st-size-offset),
integer-as-raw(0)))
end function st-size;
define inline-only function st-atime (st :: <machine-word>) => (atime ::
<abstract-integer>)
raw-as-abstract-integer
(primitive-c-signed-int-at(primitive-unwrap-machine-word(st),
integer-as-raw($st-atime-offset),
integer-as-raw(0)))
end function st-atime;
define inline-only function st-mtime (st :: <machine-word>) => (mtime ::
<abstract-integer>)
raw-as-abstract-integer
(primitive-c-signed-int-at(primitive-unwrap-machine-word(st),
integer-as-raw($st-mtime-offset),
integer-as-raw(0)))
end function st-mtime;
define inline-only function st-ctime (st :: <machine-word>) => (ctime ::
<abstract-integer>)
raw-as-abstract-integer
(primitive-c-signed-int-at(primitive-unwrap-machine-word(st),
integer-as-raw($st-ctime-offset),
integer-as-raw(0)))
end function st-ctime;
/// Used instead of define C-struct to avoid relying on the C-FFI library ...
/// From <pwd.h> ...
define system-offset passwd-name () 0;
define system-offset passwd-dir (alpha 4) 5;
define inline-only function passwd-name (passwd :: <machine-word>) => (name ::
<byte-string>)
primitive-raw-as-string
(primitive-c-pointer-at(primitive-unwrap-machine-word(passwd),
integer-as-raw($passwd-name-offset),
integer-as-raw(0)))
end function passwd-name;
define inline-only function passwd-dir (passwd :: <machine-word>) => (dir ::
<byte-string>)
primitive-raw-as-string
(primitive-c-pointer-at(primitive-unwrap-machine-word(passwd),
integer-as-raw($passwd-dir-offset),
integer-as-raw(0)))
end function passwd-dir;
/// From <grp.h> ...
define system-offset group-name () 0;
define inline-only function group-name (group :: <machine-word>) => (name ::
<byte-string>)
primitive-raw-as-string
(primitive-c-pointer-at(primitive-unwrap-machine-word(group),
integer-as-raw($group-name-offset),
integer-as-raw(0)))
end function group-name;
/// Used instead of define C-struct to avoid relying on the C-FFI library ...
/// From <dirent.h> ...
define system-offset dirent-name (x86 11, ppc 11) 8;
define inline-only function dirent-name (dirent :: <machine-word>) => (name ::
<byte-string>)
primitive-raw-as-string
(primitive-cast-raw-as-pointer
(primitive-machine-word-add(primitive-unwrap-machine-word(dirent),
integer-as-raw($dirent-name-offset))))
end function dirent-name;
/// Error handling
define function unix-last-error () => (errno :: <integer>)
raw-as-integer
(primitive-c-signed-int-at
(%call-c-function ("__errno_location") () => (errnop :: <raw-pointer>) ()
end,
integer-as-raw(0), integer-as-raw(0)))
end function unix-last-error;
define function unix-last-error-setter (errno :: <integer>) => (errno ::
<integer>)
primitive-c-signed-int-at
(%call-c-function ("__errno_location") () => (errnop :: <raw-pointer>) ()
end,
integer-as-raw(0), integer-as-raw(0))
:= integer-as-raw(errno);
errno
end function unix-last-error-setter;
define function unix-last-error-message () => (message :: <string>)
let message :: <byte-string>
= primitive-raw-as-string
(%call-c-function ("strerror")
(errno :: <raw-c-signed-int>) => (message :: <raw-byte-string>)
(integer-as-raw(unix-last-error()))
end);
// Make a copy to avoid it being overwritten ...
copy-sequence(message)
end function unix-last-error-message;
define function unix-file-error
(operation :: <string>, additional-information, #rest
additional-information-args)
=> (will-never-return :: <bottom>)
let status-message = unix-last-error-message();
if (additional-information)
error(make(<file-system-error>,
format-string: concatenate("%s: Can't %s ",
additional-information),
format-arguments: concatenate(list(status-message),
list(operation),
map(method (x)
if (instance?(x, <locator>))
as(<string>, x)
else
x
end
end method,
additional-information-args))))
else
error(make(<file-system-error>,
format-string: "%s: Can't %s",
format-arguments: list(status-message, operation)))
end;
end function unix-file-error;
/*
File attributes on x86-Linux
zab.functionalobjects.com:/u/ldisk/nosa/libc/include/sys/stat.h
struct stat {
dev_t st_dev;
#ifdef __SVR4_I386_ABI_L1__
long st_pad1[3];
#else
unsigned short __pad1;
#endif
ino_t st_ino;
umode_t st_mode;
nlink_t st_nlink;
uid_t st_uid;
gid_t st_gid;
dev_t st_rdev;
#ifdef __SVR4_I386_ABI_L1__
long st_pad2[2];
#else
unsigned short __pad2;
#endif
off_t st_size;
#ifdef __SVR4_I386_ABI_L1__
timestruc_t st_atim;
timestruc_t st_mtim;
timestruc_t st_ctim;
long st_blksize;
long st_blocks;
#define FSTYPSZ 16
char st_fstype[FSTYPSZ];
long st_pad4[8];
#define st_atime st_atim.tv_sec
#define st_mtime st_mtim.tv_sec
#define st_ctime st_ctim.tv_sec
#else /*! __SVR4_I386_ABI_L1__*/
unsigned long st_blksize;
unsigned long st_blocks;
time_t st_atime;
unsigned long __unused1;
time_t st_mtime;
unsigned long __unused2;
time_t st_ctime;
unsigned long __unused3;
unsigned long __unused4;
unsigned long __unused5;
#endif /*! __SVR4_I386_ABI_L1__*/
};
(gdb) p *(struct stat *)0x8065e10
$3 = {st_dev = 2054, __pad1 = 0, st_ino = 139286, st_mode = 33277,
st_nlink = 1, st_uid = 681, st_gid = 100, st_rdev = 0, __pad2 = 0,
st_size = 11276, st_blksize = 4096, st_blocks = 24, st_atime = 930182170,
__unused1 = 0, st_mtime = 930182170, __unused2 = 0, st_ctime = 930182170,
__unused3 = 0, __unused4 = 0, __unused5 = 0}
(gdb) x /32 0x8065e10
0x8065e10: 0x00000806 0x00000000 0x00000000 0x00022016
0x8065e20: 0x000081fd 0x00000001 0x000002a9 0x00000064
0x8065e30: 0x00000000 0x00000000 0x00000000 0x00002c0c
0x8065e40: 0x00001000 0x00000018 0x3771741a 0x00000000
0x8065e50: 0x3771741a 0x00000000 0x3771741a 0x00000000
0x8065e60: 0x00000000 0x00000000 0x4040e250 0x403b7cb4
0x8065e70: 0x40386614 0x40386614 0x40386614 0x403669f8
0x8065e80: 0x40322374 0x402e2844 0x402e2844 0x402e2844
(gdb)
*/
--- NEW FILE: unix-file-accessor.dylan ---
Module: system-internals
Synopsis: Unix stream accessors (assuming ~ System V release 5.3 semantics)
Author: Eliot Miranda, Scott McKay, Marc Ferguson
Copyright: Original Code is Copyright (c) 1994-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define sealed class <unix-file-accessor> (<external-file-accessor>)
slot fd-file-accessor :: false-or(<external-file-accessor>) = #f;
end class <unix-file-accessor>;
// An attempt at a portable flexible interface to OS read/write/seek
// functionality. Legal values for TYPE might include #"file", #"pipe",
// #"tcp", #"udp". Legal values for LOCATOR depend on TYPE.
define sideways method platform-accessor-class
(type == #"file", locator :: <object>)
=> (class :: singleton(<unix-file-accessor>))
<unix-file-accessor>
end method platform-accessor-class;
define constant $file_create_permissions
= logior($S_IRUSR, $S_IWUSR, $S_IRGRP, $S_IWGRP, $S_IROTH, $S_IWOTH);
// Legal values for direction are #"input", #"output", #"input-output"
// Legal values for if-exists are #"new-version", #"overwrite", #"replace",
// #"truncate", #"signal", #"append"
// NB #"append" does _not_ imply unix open(2) append semantics, _only_
// that writing is likely to continue from the end. So its merely a hint
// as to where to go first.
// Legal values for if-does-not-exist are #"signal", #"create"
define method accessor-open
(accessor :: <unix-file-accessor>,
#key direction = #"input", if-exists, if-does-not-exist,
locator,
file-position: initial-file-position = #f, // :: false-or(<integer>)?
file-size: initial-file-size = #f, // :: false-or(<integer>)?
#all-keys) => ()
block (return)
let pathstring = as(<byte-string>, locator);
let (stat-err?, st) = %stat(pathstring);
let exists = ~stat-err?;
let (mode-code, if-exists, if-does-not-exist)
= select (direction)
#"input" =>
values($O_RDONLY,
#"overwrite",
(if-does-not-exist | #"signal"));
#"output" =>
values(logior($O_WRONLY, $O_SYNC),
(if-exists | #"new-version"),
(if-does-not-exist | #"create"));
#"input-output" =>
values(logior($O_RDWR, $O_SYNC),
(if-exists | #"overwrite"),
(if-does-not-exist | #"create"));
end;
let mode-code
= if (exists)
select (if-exists)
#"signal" =>
return(signal(make(<file-exists-error>,
locator: as(<posix-file-locator>, locator))));
#"new-version", #"replace" =>
if (~%unlink(pathstring))
logior(mode-code, $O_CREAT);
else
let errno = unix-last-error();
if (errno = $EACCES)
return(signal(make(<invalid-file-permissions-error>,
locator: locator)));
else
unix-file-error("unlink", "%s", locator);
end;
end;
#"overwrite", #"append" =>
mode-code;
#"truncate" =>
logior(mode-code, $O_TRUNC);
end
else
select (if-does-not-exist)
#"signal" =>
return(signal(make(<file-does-not-exist-error>,
locator: as(<posix-file-locator>, locator))));
#"create" =>
logior(mode-code, $O_CREAT);
end
end;
let fd = %open(pathstring, mode-code, $file_create_permissions);
if (fd < 0)
let errno = unix-last-error();
if (errno = $EACCES)
return(signal(make(<invalid-file-permissions-error>,
locator: as(<posix-file-locator>, locator))));
else
unix-file-error("open", "%s", locator);
end
else
let fd-accessor
= new-accessor(#"file", locator: fd, file-descriptor: fd);
accessor.fd-file-accessor := fd-accessor;
*open-accessors*[accessor] := #t;
if (if-exists == #"append")
fd-accessor.accessor-position := fd-accessor.accessor-size;
end;
// IMPORTANT!!
// Once the file has been created the required reopen behaviour is
// overwrite. E.g., if an if-exists: #"truncate" file-stream is
// reopened after close we don't want it truncated again.
// accessor.exists-behaviour = #"overwrite";
// By the same token, if the underlying file has been removed by the
// time a reopen occurs a signal is appropriate.
// accessor.not-exists-behaviour = #"signal";
end
end
end method accessor-open;
define method accessor-close
(accessor :: <unix-file-accessor>,
#key abort? = #f, wait? = #t)
=> (closed? :: <boolean>)
if (accessor.fd-file-accessor)
accessor-close(accessor.fd-file-accessor);
accessor.fd-file-accessor := #f;
#t
end
end method accessor-close;
define method accessor-open?
(accessor :: <unix-file-accessor>) => (open? :: <boolean>)
accessor.fd-file-accessor & accessor-open?(accessor.fd-file-accessor)
end method accessor-open?;
define method accessor-preferred-buffer-size
(accessor :: <unix-file-accessor>)
=> (preferred-buffer-size :: <integer>)
accessor-preferred-buffer-size(accessor.fd-file-accessor);
end method accessor-preferred-buffer-size;
define method accessor-size
(accessor :: <unix-file-accessor>)
=> (size :: false-or(<integer>))
accessor-size(accessor.fd-file-accessor);
end method accessor-size;
define inline method accessor-position
(accessor :: <unix-file-accessor>)
=> (position :: <integer>)
accessor-position(accessor.fd-file-accessor);
end method accessor-position;
define method accessor-position-setter
(position :: <integer>, accessor :: <unix-file-accessor>)
=> (position :: <integer>)
accessor-position-setter(position, accessor.fd-file-accessor);
end method accessor-position-setter;
define method accessor-read-into!
(accessor :: <unix-file-accessor>, stream :: <file-stream>,
offset :: <integer>, count :: <integer>, #key buffer)
=> (nread :: <integer>)
accessor-read-into!(accessor.fd-file-accessor, stream,
offset, count, buffer: buffer);
end method accessor-read-into!;
define method accessor-write-from
(accessor :: <unix-file-accessor>, stream :: <file-stream>,
offset :: <integer>, count :: <integer>, #key buffer,
return-fresh-buffer? = #f)
=> (nwritten :: <integer>, new-buffer :: <buffer>)
accessor-write-from(accessor.fd-file-accessor, stream,
offset, count,
buffer: buffer,
return-fresh-buffer?: return-fresh-buffer?);
end method accessor-write-from;
define method accessor-newline-sequence
(accessor :: <unix-file-accessor>)
=> (string :: <string>)
"\n"
end method accessor-newline-sequence;
--- NEW FILE: unix-file-system.dylan ---
Module: system-internals
Author: Gary Palter
Synopsis: UNIX implementation of the File System library API
Copyright: Original Code is Copyright (c) 1998-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// Handles expansion of "~" and "~USER" in a pathname
define method %expand-pathname
(path :: <posix-directory-locator>)
=> (expanded-path :: <locator>)
block (return)
if (locator-relative?(path))
let elements = locator-path(path);
if (size(elements) > 0)
let first = elements[0];
if (instance?(first, <string>)
& size(first) > 0
& first[0] = '~')
let name = if (first = "~")
login-name()
else
copy-sequence(first, start: 1)
end;
let passwd = %getpwnam(name);
if (passwd =~ null-pointer)
let homedir = as(<native-directory-locator>, pw-dir(passwd));
return(merge-locators(make(<native-directory-locator>,
path: copy-sequence(elements, start: 1),
relative?: #t),
homedir))
else
return(path)
end
else
return(path)
end
else
return(path)
end
else
return(path)
end
end
end method %expand-pathname;
define method %expand-pathname
(path :: <posix-file-locator>)
=> (expanded-path :: <locator>)
let directory = locator-directory(path);
let expanded-directory = directory & %expand-pathname(directory);
if (directory ~= expanded-directory)
make(<native-file-locator>,
directory: expanded-directory,
base: locator-base(path),
extension: locator-extension(path))
else
path
end
end method %expand-pathname;
define method %expand-pathname
(path :: <posix-file-system-locator>) => (expanded-path :: <locator>)
path
end method %expand-pathname;
///
define function %shorten-pathname
(path :: <posix-file-system-locator>)
=> (shortened-path :: <posix-file-system-locator>)
path
end function %shorten-pathname;
///
define function %file-exists?
(file :: <posix-file-system-locator>) => (exists? :: <boolean>)
let file = %expand-pathname(file);
let (err?, st) = %stat(as(<byte-string>, file));
~err?
end function %file-exists?;
///
define function %file-type
(file :: <posix-file-system-locator>, #key if-not-exists = #f)
=> (file-type :: <file-type>)
let file = %expand-pathname(file);
let (err?, st) = %lstat(as(<byte-string>, file));
if (~err?)
if (unix-last-error() = $ENOENT & if-not-exists)
if-not-exists
else
unix-file-error("determine the type of", "%s", file)
end
elseif (logand(st-mode(st), $S_IFMT) = $S_IFDIR)
#"directory"
elseif (logand(st-mode(st), $S_IFMT) = $S_IFLNK)
#"link"
else // if (logand(st-mode(st), $S_IFMT) = $S_IFREG)
#"file"
end
end function %file-type;
///
define function %link-target
(link :: <posix-file-system-locator>) => (target ::
<posix-file-system-locator>)
let link = %expand-pathname(link);
while (%file-type(link, if-not-exists: #"file") == #"link")
let link-path = as(<byte-string>, link);
let buffer-size = %pathconf(link-path, $_PC_SYMLINK_MAX);
let buffer = make(<c-string>, size: buffer-size, fill: '\0');
let count = %readlink(link-path, buffer, buffer-size);
if (count = -1)
unless (unix-last-error() = $ENOENT | unix-last-error() = $EINVAL)
unix-file-error("readlink", "%s", link)
end
else
let target = as(<physical-locator>, copy-sequence(buffer, end: count));
link := merge-locators(target, link)
end
end;
link
end function %link-target;
///
define function %delete-file
(file :: <posix-file-system-locator>) => ()
let file = %expand-pathname(file);
if (%unlink(as(<byte-string>, file)))
unix-file-error("delete", "%s", file)
end
end function %delete-file;
/// Whoever heard of an OS that doesn't provide a primitive to copy files?
/// Why, the creators of UNIX, of course since it doesn't. We have to resort
/// to invoking the cp (copy) command via RUN-APPLICATION.
define function %copy-file
(source :: <posix-file-system-locator>, destination ::
<posix-file-system-locator>,
#key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
let source = %expand-pathname(source);
let destination = %expand-pathname(destination);
// UNIX strikes again! The copy command will overwrite its target if
// the user has write access and the only way to prevent it would
// require the user to respond to a question! So, we have to manually
// check beforehand. (Just another reason I'm a member of Unix-Haters)
if (if-exists = #"signal" & file-exists?(destination))
error(make(<file-system-error>,
format-string: "File exists: Can't copy %s to %s",
format-arguments: list(as(<string>, source),
as(<string>, destination))))
end;
run-application
(concatenate
(if ($os-name = #"osf3") "cp -pf" else "cp -p" end,
" '",
as(<string>, source),
"' '",
as(<string>, destination),
"'"))
end function %copy-file;
///
define function %rename-file
(source :: <posix-file-system-locator>, destination ::
<posix-file-system-locator>,
#Key if-exists :: <copy/rename-disposition> = #"signal")
=> ()
let source = %expand-pathname(source);
let destination = %expand-pathname(destination);
// UNIX strikes again! It's rename function always replaces the target.
// So, if the caller doesn't want to overwrite an existing file, we have
// to manually check beforehand. (Sigh)
if (if-exists = #"signal" & file-exists?(destination))
error(make(<file-system-error>,
format-string: "File exists: Can't rename %s to %s",
format-arguments: list(as(<string>, source),
as(<string>, destination))))
end;
if (%rename(as(<byte-string>, source), as(<byte-string>, destination)))
unix-file-error("rename", "%s to %s", source, destination)
end
end function %rename-file;
///
define function %file-properties
(file :: <posix-file-system-locator>)
=> (properties :: <explicit-key-collection>)
let file = %expand-pathname(file);
let properties = make(<table>);
let (err?, st) = %stat(as(<byte-string>, file));
if (err?)
unix-file-error("get attributes of", "%s", file)
else
properties[#"size"] := st-size(st);
// ### st_ctime is the "Time of last status change", not creation-date
// ### st_birthtime is available on FreeBSD 5, but not elsewhere
properties[#"creation-date"] := make(<date>, native-clock: st-ctime(st));
properties[#"access-date"] := make(<date>, native-clock: st-atime(st));
properties[#"modification-date"] := make(<date>, native-clock: st-mtime(st))
end;
properties[#"author"] := %file-property(file, #"author");
properties[#"readable?"] := %file-property(file, #"readable?");
properties[#"writeable?"] := %file-property(file, #"writeable?");
properties[#"executable?"] := %file-property(file, #"executable?");
properties
end function %file-properties;
/// "Standard" properties not implemented on this platform:
/// ?
/// "Standard" properties not settable on this platform:
/// author, size, creation-date, access-date, modification-date
define method %file-property
(file :: <posix-file-system-locator>, key == #"author")
=> (author :: false-or(<string>))
let file = %expand-pathname(file);
let (err?, st) = %stat(as(<byte-string>, file));
if (err?)
unix-file-error("get the author of", "%s", file)
end;
let passwd = %getpwuid(st-uid(st));
if (passwd ~= null-pointer)
as(<byte-string>, pw-name(passwd))
else
unix-file-error("get the author of", "%s", file)
end
end method %file-property;
define method %file-property
(file :: <posix-file-system-locator>, key == #"size")
=> (file-size :: <abstract-integer>)
let file = %expand-pathname(file);
let (err?, st) = %stat(as(<byte-string>, file));
if (err?)
unix-file-error("get the size of", "%s", file)
else
st-size(st)
end
end method %file-property;
define method %file-property
(file :: <posix-file-system-locator>, key == #"creation-date")
=> (creation-date :: <date>)
let file = %expand-pathname(file);
let (err?, st) = %stat(as(<byte-string>, file));
if (err?)
unix-file-error("get the creation date of", "%s", file)
else
make(<date>, native-clock: st-ctime(st))
end
end method %file-property;
define method %file-property
(file :: <posix-file-system-locator>, key == #"access-date")
=> (access-date :: <date>)
let file = %expand-pathname(file);
let (err?, st) = %stat(as(<byte-string>, file));
if (err?)
unix-file-error("get the access date of", "%s", file)
else
make(<date>, native-clock: st-atime(st))
end
end method %file-property;
define method %file-property
(file :: <posix-file-system-locator>, key == #"modification-date")
=> (modification-date :: <date>)
let file = %expand-pathname(file);
let (err?, st) = %stat(as(<byte-string>, file));
if (err?)
unix-file-error("get the modification date of", "%s", file)
else
make(<date>, native-clock: st-mtime(st))
end
end method %file-property;
define function accessible?
(file :: <posix-file-system-locator>, mode :: <integer>)
=> (accessible? :: <boolean>)
let file = %expand-pathname(file);
if (%access(as(<byte-string>, file), mode))
unless (unix-last-error() = $EACCES)
unix-file-error("determine access to", "%s", file)
end;
#f
else
#t
end
end function accessible?;
define function accessible?-setter
(new-mode :: <integer>, file :: <posix-file-system-locator>, on? ::
<boolean>)
=> (new-mode :: <integer>)
let file = %expand-pathname(file);
let (err?, st) = %stat(as(<byte-string>, file));
if (err?)
unix-file-error("get permissions for", "%s", file)
else
let old-mode = st-mode(st);
let mode = if (on?)
logior(old-mode, new-mode)
else
logand(old-mode, lognot(new-mode))
end;
if (%chmod(as(<byte-string>, file), mode))
unix-file-error("set permissions for", "%s", file)
end;
end;
new-mode
end function accessible?-setter;
define method %file-property
(file :: <posix-file-system-locator>, key == #"readable?")
=> (readable? :: <boolean>)
accessible?(file, $R_OK)
end method %file-property;
define method %file-property-setter
(new-readable? :: <boolean>, file :: <posix-file-system-locator>,
key == #"readable?")
=> (new-readable? :: <boolean>)
if (new-readable? ~= %file-property(file, #"readable?"))
accessible?(file, new-readable?) := logior($S_IRUSR, $S_IRGRP, $S_IROTH)
end;
new-readable?
end method %file-property-setter;
define method %file-property
(file :: <posix-file-system-locator>, key == #"writeable?")
=> (writeable? :: <boolean>)
accessible?(file, $W_OK)
end method %file-property;
define method %file-property-setter
(new-writeable? :: <boolean>, file :: <posix-file-system-locator>,
key == #"writeable?")
=> (new-writeable? :: <boolean>)
if (new-writeable? ~= %file-property(file, #"writeable?"))
accessible?(file, new-writeable?) := logior($S_IWUSR, $S_IWGRP, $S_IWOTH)
end;
new-writeable?
end method %file-property-setter;
define method %file-property
(file :: <posix-file-system-locator>, key == #"executable?")
=> (executable? :: <boolean>)
accessible?(file, $X_OK)
end method %file-property;
define method %file-property-setter
(new-executable? :: <boolean>, file :: <posix-file-system-locator>,
key == #"executable?")
=> (new-executable? :: <boolean>)
if (new-executable? ~= %file-property(file, #"executable?"))
accessible?(file, new-executable?) := logior($S_IXUSR, $S_IXGRP, $S_IXOTH)
end;
new-executable?
end method %file-property-setter;
///
define function %do-directory
(f :: <function>, directory :: <posix-directory-locator>) => ()
let directory = %expand-pathname(directory);
let directory-fd :: <DIR*> = as(<DIR*>, null-pointer);
block ()
directory-fd := %opendir(as(<byte-string>, directory));
if (directory-fd = null-pointer)
unix-file-error("start listing of", "%s", directory)
end;
unix-last-error() := 0;
let dirent = %readdir(directory-fd);
while (dirent ~= null-pointer)
let filename :: <byte-string> = dirent-name(dirent);
let type :: <file-type>
= %file-type(make(<posix-file-locator>,
directory: directory,
name: filename));
unless (type == #"directory" & (filename = "." | filename = ".."))
f(directory,
filename,
type)
end;
unix-last-error() := 0;
dirent := %readdir(directory-fd);
end;
if (unix-last-error() ~= 0)
unix-file-error("continue listing of", "%s", directory)
end;
cleanup
if (directory-fd ~= null-pointer)
%closedir(directory-fd);
end
end
end function %do-directory;
///
define function %create-directory
(directory :: <posix-directory-locator>)
=> (directory :: <posix-directory-locator>)
let directory = %expand-pathname(directory);
// Let the process' UMASK restrict access to the directory as desired
if (%mkdir(as(<byte-string>, directory),
logior($S_IRWXU, $S_IRWXG, $S_IRWXO)))
unix-file-error("create the directory", "%s", directory)
else
directory
end
end function %create-directory;
///
define function %delete-directory
(directory :: <posix-directory-locator>) => ()
let directory = %expand-pathname(directory);
if (%rmdir(as(<byte-string>, directory)))
unix-file-error("delete", "%s", directory)
end
end function %delete-directory;
///---*** Is there an easier way? (Look into it ...)
define function %directory-empty?
(directory :: <posix-directory-locator>) => (empty? :: <boolean>)
~%file-exists?(directory)
| block (return)
%do-directory
(method (directory :: <posix-directory-locator>, name :: <string>,
type :: <file-type>)
ignore(directory); ignore(name); ignore(type);
return(#f)
end,
directory);
#t
end
end function %directory-empty?;
///
define function %home-directory
() => (home-directory :: false-or(<posix-directory-locator>))
let path = environment-variable("HOME");
path
& as(<posix-directory-locator>, path)
end function %home-directory;
///
define function %working-directory
() => (working-directory :: false-or(<posix-directory-locator>))
let bufsiz :: <integer> = %pathconf(".", $_PC_PATH_MAX);
let buffer :: <c-string> = make(<c-string>, size: bufsiz, fill: '\0');
let result :: <c-string> = %getcwd(buffer, bufsiz);
if (result ~= null-pointer)
as(<directory-locator>, buffer);
else
// Arrive here iff we couldn't get the working directory
unix-file-error("getcwd", #f)
end
end function %working-directory;
///
define function %working-directory-setter
(new-working-directory :: <posix-directory-locator>)
=> (new-working-directory :: <posix-directory-locator>)
let directory = %expand-pathname(new-working-directory);
if (%chdir(as(<byte-string>, directory)))
unix-file-error("chdir", "%s", directory)
end;
directory
end function %working-directory-setter;
///
define variable *temp-directory* = #f;
define function %temp-directory
() => (temp-directory :: false-or(<posix-directory-locator>))
*temp-directory*
| (*temp-directory*
:= as(<posix-directory-locator>,
environment-variable("TMPDIR") | "/tmp"))
end function %temp-directory;
/// A UNIX system has exactly one root directory
define function %root-directories () => (roots :: <sequence>)
vector(as(<posix-directory-locator>, "/"))
end function %root-directories;
--- NEW FILE: unix-interface.dylan ---
Module: system-internals
Synopsis: An interface to file-related unix system.
Author: Eliot Miranda, Scott McKay, Marc Ferguson
Copyright: Original Code is Copyright (c) 1995-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// LOW LEVEL FFI
define function unix-open
(path :: <byte-string>, mode :: <integer>, create-flags :: <integer>) =>
(fd :: <integer>)
raw-as-integer
(%call-c-function ("open")
(path :: <raw-byte-string>, oflag :: <raw-c-unsigned-int>,
mode :: <raw-c-unsigned-int>)
=> (fd :: <raw-c-unsigned-int>)
(primitive-string-as-raw(path),
integer-as-raw(mode),
integer-as-raw(create-flags))
end);
end function unix-open;
define function unix-close (fd :: <integer>) => (result :: <integer>)
raw-as-integer
(%call-c-function ("close") (fd :: <raw-c-unsigned-int>)
=> (result :: <raw-c-signed-int>)
(integer-as-raw(fd)) end)
end function unix-close;
define function unix-read
(fd :: <integer>, data :: <buffer>, offset :: <integer>, count ::
<integer>) => (result :: <integer>)
raw-as-integer
(%call-c-function ("read")
(fd :: <raw-c-unsigned-int>, address :: <raw-pointer>,
size :: <raw-c-unsigned-long>)
=> (result :: <raw-c-signed-int>)
(integer-as-raw(fd),
primitive-cast-raw-as-pointer
(primitive-machine-word-add
(primitive-cast-pointer-as-raw
(primitive-repeated-slot-as-raw(data,
primitive-repeated-slot-offset(data))),
primitive-cast-pointer-as-raw(integer-as-raw(offset)))),
integer-as-raw(count))
end)
end function unix-read;
define function unix-write
(fd :: <integer>, data, offset :: <integer>, count :: <integer>) => (result
:: <integer>)
raw-as-integer
(%call-c-function ("write")
(fd :: <raw-c-unsigned-int>, address :: <raw-pointer>,
size :: <raw-c-unsigned-long>)
=> (result :: <raw-c-signed-int>)
(integer-as-raw(fd),
primitive-cast-raw-as-pointer
(primitive-machine-word-add
(primitive-cast-pointer-as-raw
(primitive-repeated-slot-as-raw(data,
primitive-repeated-slot-offset(data))),
primitive-cast-pointer-as-raw(integer-as-raw(offset)))),
integer-as-raw(count))
end)
end function unix-write;
define function unix-lseek
(fd :: <integer>, position :: <integer>, mode :: <integer>) => (position ::
<integer>)
raw-as-integer
(%call-c-function ("lseek")
(fd :: <raw-c-unsigned-int>, position :: <raw-c-unsigned-long>,
mode :: <raw-c-unsigned-int>)
=> (result :: <raw-c-signed-int>)
(integer-as-raw(fd),
integer-as-raw(position), integer-as-raw(mode))
end)
end function unix-lseek;
define function get-unix-error (errno :: <integer>) => (message :: <string>)
let message :: <byte-string>
= primitive-raw-as-string
(%call-c-function ("strerror")
(errno :: <raw-c-signed-int>) => (message :: <raw-byte-string>)
(integer-as-raw(errno))
end);
// Make a copy to avoid it being overwritten ...
copy-sequence(message)
end function get-unix-error;
define function unix-errno-value () => (errno :: <integer>)
raw-as-integer
(primitive-c-signed-int-at
(%call-c-function ("__errno_location") () => (errnop :: <raw-pointer>) ()
end,
integer-as-raw(0), integer-as-raw(0)))
end function unix-errno-value;
/// HIGHER LEVEL INTERFACE
/// This value is overkill, actually ...
define constant $stat-size = 128 * raw-as-integer(primitive-word-size());
define thread variable *stat-buffer* = make(<byte-vector>, size: $stat-size,
fill: '\0');
define function unix-file-exists? (path :: <byte-string>) => (exists? ::
<boolean>)
~primitive-raw-as-boolean
(%call-c-function ("stat")
(path :: <raw-byte-string>, statbuf :: <raw-pointer>)
=> (result :: <raw-c-signed-int>)
(primitive-string-as-raw(path),
primitive-cast-raw-as-pointer(primitive-string-as-raw(*stat-buffer*)))
end)
end function unix-file-exists?;
define function unix-delete-file (path :: <byte-string>) => (ok :: <boolean>)
raw-as-integer(%call-c-function ("unlink")
(path :: <raw-byte-string>) => (result ::
<raw-c-signed-int>)
(primitive-string-as-raw(path))
end)
= 0;
end function unix-delete-file;
// POSIX lseek whence definitions:
define constant $seek_set = 0;
// define constant $seek_cur = 1;
define constant $seek_end = 2;
// Definitions for open mode arg.
define constant $o_rdonly = 0;
define constant $o_wronly = 1;
define constant $o_rdwr = 2;
// define constant $o_append = 8;
// The following are very OS specific :(
define constant $o_creat
= select ($os-name)
#"linux" => 64;
#"Solaris2", #"IRIX5" => 256;
#"SunOS4", #"OSF3" => 512;
end;
define constant $o_trunc
= select ($os-name)
#"Solaris2", #"IRIX5", #"linux" => 512;
#"SunOS4", #"OSF3" => 1024;
end;
define constant $o_sync
= select ($os-name)
#"Solaris2", #"IRIX5" => 16;
#"linux" => 4096;
#"SunOS4" => 8192;
#"OSF3" => 16384;
end;
// standard unix error definitions
define constant $e_access = 13;
define function unix-error (syscall :: <string>, #key errno = #f) => ()
let message :: <string>
= get-unix-error
(if (~errno) unix-errno-value() else errno end);
error("%s %s", syscall, message);
end function unix-error;
--- NEW FILE: win32-ffi.dylan ---
Module: system-internals
Author: Gary Palter
Synopsis: Win32 implementation of the File System library API
Copyright: Original Code is Copyright (c) 1998-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// From WINDOWS.H et al.
define constant $MAX_PATH = 260;
define constant $INVALID_HANDLE_VALUE = -1;
define constant $FILE_ATTRIBUTE_READONLY = #x00000001;
define constant $FILE_ATTRIBUTE_READONLY_BIT = 0; // #x00000001
define constant $FILE_ATTRIBUTE_DIRECTORY_BIT = 4; // #x00000010
define constant $FORMAT_MESSAGE_FLAGS = #x00001100;
define constant $FORMAT_MESSAGE_LANGUAGE = #x00000400;
//---*** NOTE: See the code for the #"executable?" property for an explanation
//---*** of why the next three values are presently unused...
// define constant $NO_ERROR = 0;
// define constant $ERROR_BAD_EXE_FORMAT = 193;
// define constant $ERROR_ACCESS_DENIED = 5;
define constant $ERROR_FILE_NOT_FOUND = 2;
define constant $ERROR_PATH_NOT_FOUND = 3;
define constant $ERROR_NOT_READY = 21;
define constant $ERROR_NO_MORE_FILES = 18;
define constant $ERROR_NOT_SUPPORTED = 50;
define constant $SHGFI_EXETYPE = #x00002000;
///
define macro with-stack-dword
{ with-stack-dword (?dword:name) ?:body end }
=> { begin
let ?dword = primitive-wrap-machine-word(integer-as-raw(0));
block ()
?dword := primitive-wrap-machine-word
(primitive-cast-pointer-as-raw
(%call-c-function ("LocalAlloc", c-modifiers:
"__stdcall")
(flags :: <raw-c-unsigned-int>, bytes ::
<raw-c-unsigned-int>)
=> (pointer :: <raw-c-pointer>)
(integer-as-raw(0), integer-as-raw($DWORD_SIZE))
end));
if
(primitive-machine-word-equal?(primitive-unwrap-machine-word(?dword),
integer-as-raw(0)))
// Can't use win32-file-error as we may be called from there!
error("Can't allocate space for a DWORD")
end;
?body
cleanup
if
(primitive-machine-word-not-equal?(primitive-unwrap-machine-word(?dword),
integer-as-raw(0)))
%call-c-function ("LocalFree", c-modifiers: "__stdcall")
(pointer :: <raw-c-pointer>) => (null-pointer ::
<raw-c-pointer>)
(primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(?dword)))
end
end
end
end }
end macro with-stack-dword;
define macro with-stack-path
{ with-stack-path (?path:name) ?:body end }
=> { begin
let ?path :: <byte-string> = make(<byte-string>, size: $MAX_PATH + 1,
fill: '\0');
?body
end }
end macro with-stack-path;
///
/// Used instead of define C-struct to avoid relying on the C-FFI library ...
define constant $FILETIME_SIZE = 2 * raw-as-integer(primitive-word-size());
define constant $FIND_DATA_SIZE =
begin
$DWORD_SIZE // sizeof(dwFileAttributes)
+ $FILETIME_SIZE // sizeof(ftCreationTime)
+ $FILETIME_SIZE // sizeof(ftLastAccessTime)
+ $FILETIME_SIZE // sizeof(ftLastWriteTime)
+ $DWORD_SIZE // sizeof(nFileSizeHigh)
+ $DWORD_SIZE // sizeof(nFileSizeLow)
+ $DWORD_SIZE // sizeof(dwReserved0)
+ $DWORD_SIZE // sizeof(dwReserved1)
+ $MAX_PATH // sizeof(cFileName)
+ 14 // sizeof(cAlternateFileName)
end;
define macro with-stack-win32-find-data
{ with-stack-win32-find-data (?wfd:name, ?directory:expression) ?:body end }
=> { begin
let ?wfd = primitive-wrap-machine-word(integer-as-raw(0));
block ()
?wfd := primitive-wrap-machine-word
(primitive-cast-pointer-as-raw
(%call-c-function ("LocalAlloc", c-modifiers:
"__stdcall")
(flags :: <raw-c-unsigned-int>, bytes ::
<raw-c-unsigned-int>)
=> (pointer :: <raw-c-pointer>)
(integer-as-raw(0), integer-as-raw($FIND_DATA_SIZE))
end));
if
(primitive-machine-word-equal?(primitive-unwrap-machine-word(?wfd),
integer-as-raw(0)))
win32-file-system-error("get space for WIN32_FIND_DATA for", "%s",
?directory)
end;
?body
cleanup
if
(primitive-machine-word-not-equal?(primitive-unwrap-machine-word(?wfd),
integer-as-raw(0)))
%call-c-function ("LocalFree", c-modifiers: "__stdcall")
(pointer :: <raw-c-pointer>) => (null-pointer ::
<raw-c-pointer>)
(primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(?wfd)))
end
end
end
end }
end macro with-stack-win32-find-data;
define inline-only function win32-find-data-attributes
(win32-find-data :: <machine-word>) => (attributes :: <machine-word>)
primitive-wrap-machine-word
(primitive-c-unsigned-long-at(primitive-unwrap-machine-word(win32-find-data),
integer-as-raw(0),
integer-as-raw(0)))
end function win32-find-data-attributes;
define inline-only function win32-find-data-filename
(win32-find-data :: <machine-word>) => (filename :: <byte-string>)
primitive-raw-as-string
(primitive-cast-raw-as-pointer
(primitive-machine-word-add
(primitive-unwrap-machine-word(win32-find-data),
integer-as-raw(0 // offset(dwFileAttributes)
+ $DWORD_SIZE // offset(ftCreationTime)
+ $FILETIME_SIZE // offset(ftLastAccessTime)
+ $FILETIME_SIZE // offset(ftLastWriteTime)
+ $FILETIME_SIZE // offset(nFileSizeHigh)
+ $DWORD_SIZE // offset(nFileSizeLow)
+ $DWORD_SIZE // offset(dwReserved0)
+ $DWORD_SIZE // offset(dwReserved1)
+ $DWORD_SIZE)))) // offset(cFileName)
end function win32-find-data-filename;
///
define macro with-file-attributes
{ with-file-attributes (?file:expression, ?fa:name) ?:body end }
=> { begin
do-with-file-attributes(?file,
method (?fa :: <machine-word>)
?body
end)
end }
end macro with-file-attributes;
define function do-with-file-attributes (file :: <locator>, f :: <function>)
let file = %expand-pathname(file);
if (instance?(file, <directory-locator>))
// FindFirstFile requires that there be a filename ...
file := make(<file-locator>,
directory: file,
name: ".");
end;
let finder =
primitive-wrap-machine-word(integer-as-raw($INVALID_HANDLE_VALUE));
with-stack-win32-find-data (fa, file)
block ()
finder := primitive-wrap-machine-word
(primitive-cast-pointer-as-raw
(%call-c-function ("FindFirstFileA", c-modifiers:
"__stdcall")
(lpFileName :: <raw-byte-string>,
lpFindFileData :: <raw-c-pointer>)
=> (hFindFile :: <raw-c-pointer>)
(primitive-string-as-raw(as(<byte-string>, file)),
primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(fa)))
end));
if (primitive-machine-word-equal?
(primitive-unwrap-machine-word(finder),
integer-as-raw($INVALID_HANDLE_VALUE)))
win32-file-system-error("get attributes of", "%s", file);
end;
f(fa)
cleanup
if (primitive-machine-word-not-equal?
(primitive-unwrap-machine-word(finder),
integer-as-raw($INVALID_HANDLE_VALUE)))
%call-c-function ("FindClose", c-modifiers: "__stdcall")
(hFindFile :: <raw-c-pointer>) => (closed? :: <raw-c-signed-int>)
(primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(finder)))
end
end
end
end
end function do-with-file-attributes;
define inline-only function fa-attributes (fa :: <machine-word>) => (attrs ::
<machine-word>)
primitive-wrap-machine-word
(primitive-c-unsigned-long-at(primitive-unwrap-machine-word(fa),
integer-as-raw(0),
integer-as-raw(0)))
end function fa-attributes;
define inline-only function fa-creation-time (fa :: <machine-word>)
=> (creation-time :: <machine-word>)
primitive-wrap-machine-word
(primitive-machine-word-add
(primitive-unwrap-machine-word(fa),
integer-as-raw(0 // offset(dwFileAttributes)
+ $DWORD_SIZE))) // offset(ftCreationTime)
end function fa-creation-time;
define inline-only function fa-access-time (fa :: <machine-word>)
=> (access-time :: <machine-word>)
primitive-wrap-machine-word
(primitive-machine-word-add
(primitive-unwrap-machine-word(fa),
integer-as-raw(0 // offset(dwFileAttributes)
+ $DWORD_SIZE // offset(ftCreationTime)
+ $FILETIME_SIZE))) // offset(ftLastAccessTime)
end function fa-access-time;
define inline-only function fa-write-time (fa :: <machine-word>)
=> (write-time :: <machine-word>)
primitive-wrap-machine-word
(primitive-machine-word-add
(primitive-unwrap-machine-word(fa),
integer-as-raw(0 // offset(dwFileAttributes)
+ $DWORD_SIZE // offset(ftCreationTime)
+ $FILETIME_SIZE // offset(ftLastAccessTime)
+ $FILETIME_SIZE))) // offset(ftLastWriteTime)
end function fa-write-time;
define inline-only function fa-size-low (fa :: <machine-word>) => (size-low ::
<integer>)
raw-as-abstract-integer
(primitive-c-unsigned-long-at(primitive-unwrap-machine-word(fa),
integer-as-raw(8),
integer-as-raw(0)))
end function fa-size-low;
/// High order 32-bits of the number of 100-nanosecond ticks since January 1,
1601
/// corresponding to an interval of 300 years (i.e., January 1, 1901)
define constant $300-years = 22042728;
define inline-only function filetime-valid? (ft :: <machine-word>) => (valid?
:: <boolean>)
primitive-machine-word-greater-than?
(primitive-c-unsigned-long-at(primitive-unwrap-machine-word(ft),
integer-as-raw(1),
integer-as-raw(0)),
integer-as-raw($300-years))
end function filetime-valid?;
/// Error handling
define function win32-last-error-message () => (message :: <string>)
let status = primitive-wrap-machine-word
(%call-c-function ("GetLastError", c-modifiers: "__stdcall")
() => (status :: <raw-c-unsigned-long>)
()
end);
%call-c-function ("FormatMessageA", c-modifiers: "__stdcall")
(flags :: <raw-c-unsigned-long>, lpSource :: <raw-c-pointer>,
message-id :: <raw-c-unsigned-long>, language-id ::
<raw-c-unsigned-long>,
lpBuffer :: <raw-c-pointer>, bytes :: <raw-c-unsigned-long>,
lpArguments :: <raw-c-pointer>)
=> (count :: <raw-c-unsigned-long>)
(integer-as-raw($FORMAT_MESSAGE_FLAGS),
primitive-cast-raw-as-pointer(integer-as-raw(0)),
primitive-unwrap-machine-word(status),
integer-as-raw($FORMAT_MESSAGE_LANGUAGE),
primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(message-buffer-ptr)),
integer-as-raw(0),
primitive-cast-raw-as-pointer(integer-as-raw(0)))
end;
let message = primitive-raw-as-string
(primitive-c-pointer-at
(primitive-unwrap-machine-word(message-buffer-ptr),
integer-as-raw(0),
integer-as-raw(0)));
%call-c-function ("LocalFree", c-modifiers: "__stdcall")
(pointer :: <raw-c-pointer>) => (null-pointer :: <raw-c-pointer>)
(primitive-c-pointer-at(primitive-unwrap-machine-word(message-buffer-ptr),
integer-as-raw(0),
integer-as-raw(0)))
end;
message
end function win32-last-error-message;
/*---*** andrewa: old version
define function win32-last-error-message () => (message :: <string>)
let status = primitive-wrap-machine-word
(%call-c-function ("GetLastError", c-modifiers: "__stdcall")
() => (status :: <raw-c-unsigned-long>)
()
end);
with-stack-dword (message-address)
%call-c-function ("FormatMessageA", c-modifiers: "__stdcall")
(flags :: <raw-c-unsigned-long>, lpSource :: <raw-c-pointer>,
message-id :: <raw-c-unsigned-long>, language-id ::
<raw-c-unsigned-long>,
lpBuffer :: <raw-c-pointer>, bytes :: <raw-c-unsigned-long>,
lpArguments :: <raw-c-pointer>)
=> (count :: <raw-c-unsigned-long>)
(integer-as-raw($FORMAT_MESSAGE_FLAGS),
primitive-cast-raw-as-pointer(integer-as-raw(0)),
primitive-unwrap-machine-word(status),
integer-as-raw($FORMAT_MESSAGE_LANGUAGE),
primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(message-address)),
integer-as-raw(0),
primitive-cast-raw-as-pointer(integer-as-raw(0)))
end;
let message = primitive-raw-as-string
(primitive-c-pointer-at(primitive-unwrap-machine-word(message-address),
integer-as-raw(0),
integer-as-raw(0)));
%call-c-function ("LocalFree", c-modifiers: "__stdcall")
(pointer :: <raw-c-pointer>) => (null-pointer :: <raw-c-pointer>)
(primitive-c-pointer-at(primitive-unwrap-machine-word(message-address),
integer-as-raw(0),
integer-as-raw(0)))
end;
message
end
end function win32-last-error-message;
*/
// Should really signal a distint error class, perhaps a subclass of
<file-error> ...
define function win32-file-system-error
(operation :: <string>, additional-information, #rest
additional-information-args) => (res :: <bottom>)
let status-message = win32-last-error-message();
if (additional-information)
error(make(<file-system-error>,
format-string: concatenate("%s: Can't %s ",
additional-information),
format-arguments: concatenate(list(status-message),
list(operation),
map(method (x)
if (instance?(x, <locator>))
as(<string>, x)
else
x
end
end method,
additional-information-args))))
else
error(make(<file-system-error>,
format-string: "%s: Can't %s",
format-arguments: list(status-message, operation)))
end;
end function win32-file-system-error;
--- NEW FILE: win32-file-accessor.dylan ---
Module: system-internals
Synopsis: Win32 stream accessors
Author: Eliot Miranda, Scott McKay, Marc Ferguson, Gary Palter
Copyright: Original Code is Copyright (c) 1994-2001 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define constant $preferred-buffer-size = 1024 * 16;
define sealed class <win32-file-accessor> (<external-file-accessor>)
slot file-handle :: false-or(<machine-word>) = #f;
slot file-position :: <integer> = -1;
slot actual-file-position :: <integer> = -1; // The physical file position
// for async access.
constant slot locator,
required-init-keyword: locator:;
constant slot asynchronous? :: <boolean> = #f,
init-keyword: asynchronous?:;
slot access-lock :: <simple-lock>; // Lock for accesses - async stream only.
end class <win32-file-accessor>;
// An attempt at a portable flexible interface to OS read/write/seek
// functionality. Legal values for TYPE might include #"file", #"pipe",
// #"tcp", #"udp". Legal values for LOCATOR depend on TYPE.
define sideways method platform-accessor-class
(type == #"file", locator)
=> (class :: singleton(<win32-file-accessor>))
<win32-file-accessor>
end method platform-accessor-class;
define method accessor-fd
( the-accessor :: <win32-file-accessor> )
=> (the-fd :: false-or(<machine-word>))
if (the-accessor.file-handle)
the-accessor.file-handle
end if
end method;
// Should really signal a subclass of <file-error> ...
define function win32-file-error
(accessor :: <win32-file-accessor>, operation :: <string>,
additional-information, #rest additional-information-args)
let reference = as(<string>, accessor.locator);
let status-message = win32-last-error-message();
if (additional-information)
apply(error,
concatenate("%s: Can't %s %s ", additional-information),
status-message, operation, reference, additional-information-args)
else
error("%s: Can't %s %s", status-message, operation, reference)
end;
#f
end function win32-file-error;
// Legal values for direction are #"input", #"output", #"input-output"
// Legal values for if-exists are #"new-version", #"overwrite", #"replace",
// #"truncate", #"signal", #"append"
// NB #"append" does _not_ imply unix open(2) append semantics, _only_
// that writing is likely to continue from the end. So its merely a hint
// as to where to go first.
// Legal values for if-does-not-exist are #"signal", #"create"
define method accessor-open
(accessor :: <win32-file-accessor>,
#key direction = #"input", if-exists, if-does-not-exist,
fd: initial-file-handle = #f, // :: false-or(<machine-word>)
file-position: initial-file-position = #f, // :: false-or(<integer>)?
file-size: initial-file-size = #f, // :: false-or(<integer>)?
overlapped? :: <boolean> = #f,
share? :: <boolean> = #t, // only shared access allowed in the past
share-mode :: one-of(#"default", #"exclusive", #"share-read",
#"share-write", #"share-read-write") = #"default",
#all-keys) => ();
block (return)
if (initial-file-handle)
accessor.file-handle := as(<machine-word>, initial-file-handle);
accessor.file-size :=
if (initial-file-size) as(<integer>, initial-file-size) else #f end if;
accessor.file-position :=
if (initial-file-position) as(<integer>, initial-file-position)
else -1 end if;
return()
elseif (initial-file-position | initial-file-size)
error("Cannot create a file accessor which specifies either"
"file-position: or file-size: keywords but does not specify"
"file-handle:");
end if;
select (direction)
#"input" =>
if-exists := #"overwrite";
if-does-not-exist := if-does-not-exist | #"signal";
#"output" =>
if-exists := if-exists | #"new-version";
if-does-not-exist := if-does-not-exist | #"create";
#"input-output" =>
if-exists := if-exists | #"overwrite";
if-does-not-exist := if-does-not-exist | #"create";
end;
let fdwAccess
= select (direction)
#"input" => $GENERIC_READ;
#"output" => $GENERIC_WRITE;
#"input-output" => logior($GENERIC_READ, $GENERIC_WRITE);
end;
// Actually the #"default" share-mode doesn't really make a sense
// at all it's here for backward compatibility only. The default
// translates as:
//
// If it's input, allow others to read and nobody else to write.
// That isn't senseless but but isn't consistent with the behavior
// of input-output.
// If it's output, allow others to write but nobody to read. Why
// on earth allow others to write?
// If it's input-output allow others to read or write. That
// makes no sense. The logic of the others should have the access
// be exclusive for this case.
// I expect the default was intended to be share read and write,
// but somebody thought you couldn't have the access different
// from the direction somehow?
if (share-mode = #"default" & (~share?))
share-mode := #"exclusive";
end if;
let fdwShareMode
= select (share-mode by \==)
#"default" =>
select (direction)
#"input" => $FILE_SHARE_READ;
#"output" => $FILE_SHARE_WRITE;
#"input-output" =>
logior($FILE_SHARE_READ, $FILE_SHARE_WRITE);
end select;
#"exclusive" => 0;
#"share-read" => $FILE_SHARE_READ;
#"share-write" => $FILE_SHARE_WRITE;
#"share-read-write" =>
logior($FILE_SHARE_READ, $FILE_SHARE_WRITE);
end select;
let path = as(<string>, accessor.locator);
let exists :: <boolean> = win32-file-exists?(path);
let fdwCreate = 0;
if (exists)
select (if-exists)
#"signal" =>
return(signal(make(<file-exists-error>, locator: accessor.locator)));
#"new-version", #"replace" =>
fdwCreate := $CREATE_ALWAYS;
#"overwrite", #"append" =>
fdwCreate := $OPEN_EXISTING;
#"truncate" =>
fdwCreate := $TRUNCATE_EXISTING;
end
else
select (if-does-not-exist)
#"signal" =>
return(signal(make(<file-does-not-exist-error>, locator:
accessor.locator)));
#"create" =>
fdwCreate := $CREATE_NEW;
end
end;
let handle =
win32-open/create(path, fdwAccess, fdwShareMode, fdwCreate,
overlapped?: overlapped?);
if (handle)
accessor.file-handle := handle;
*open-accessors*[accessor] := #t;
let fsize = w |
