Dylan mode Module: locators-internals Synopsis: Abstract modeling of locations Author: Andy Armstrong Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. All rights reserved. License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND define open generic locator-server (locator :: <locator>) => (server :: false-or(<server-locator>)); define open generic locator-host (locator :: <locator>) => (host :: false-or(<string>)); define open generic locator-volume (locator :: <locator>) => (volume :: false-or(<string>)); define open generic locator-directory (locator :: <locator>) => (directory :: false-or(<directory-locator>)); define open generic locator-relative? (locator :: <locator>) => (relative? :: <boolean>); define open generic locator-path (locator :: <locator>) => (path :: <sequence>); define open generic locator-base (locator :: <locator>) => (base :: false-or(<string>)); define open generic locator-extension (locator :: <locator>) => (extension :: false-or(<string>)); /// Locator classes define open abstract class <directory-locator> (<physical-locator>) end class <directory-locator>; define open abstract class <file-locator> (<physical-locator>) end class <file-locator>; define method as (class == <directory-locator>, string :: <string>) => (locator :: <directory-locator>) as(<native-directory-locator>, string) end method as; define method make (class == <directory-locator>, #key server :: false-or(<server-locator>) = #f, path :: <sequence> = #[], relative? :: <boolean> = #f, name :: false-or(<string>) = #f) => (locator :: <directory-locator>) make(<native-directory-locator>, server: server, path: path, relative?: relative?, name: name) end method make; define method as (class == <file-locator>, string :: <string>) => (locator :: <file-locator>) as(<native-file-locator>, string) end method as; define method make (class == <file-locator>, #key directory :: false-or(<directory-locator>) = #f, base :: false-or(<string>) = #f, extension :: false-or(<string>) = #f, name :: false-or(<string>) = #f) => (locator :: <file-locator>) make(<native-file-locator>, directory: directory, base: base, extension: extension, name: name) end method make; /// Locator coercion //---*** andrewa: This caching scheme doesn't work yet, so disable it. define constant $cache-locators? = #f; define constant $cache-locator-strings? = #f; define constant $locator-to-string-cache = make(<object-table>, weak: #"key"); define constant $string-to-locator-cache = make(<string-table>, weak: #"value"); define open generic locator-as-string (class :: subclass(<string>), locator :: <locator>) => (string :: <string>); define open generic string-as-locator (class :: subclass(<locator>), string :: <string>) => (locator :: <locator>); define sealed sideways method as (class :: subclass(<string>), locator :: <locator>) => (string :: <string>) let string = element($locator-to-string-cache, locator, default: #f); if (string) as(class, string) else let string = locator-as-string(class, locator); if ($cache-locator-strings?) element($locator-to-string-cache, locator) := string; else string end end end method as; define sealed sideways method as (class :: subclass(<locator>), string :: <string>) => (locator :: <locator>) let locator = element($string-to-locator-cache, string, default: #f); if (instance?(locator, class)) locator else let locator = string-as-locator(class, string); if ($cache-locators?) element($string-to-locator-cache, string) := locator; else locator end end end method as; /// Locator conditions define class <locator-error> (<format-string-condition>, <error>) end class <locator-error>; define function locator-error (format-string :: <string>, #rest format-arguments) error(make(<locator-error>, format-string: format-string, format-arguments: format-arguments)) end function locator-error; /// Useful locator protocols define open generic locator-test (locator :: <directory-locator>) => (test :: <function>); define method locator-test (locator :: <directory-locator>) => (test :: <function>) \= end method locator-test; define open generic locator-might-have-links? (locator :: <directory-locator>) => (links? :: <boolean>); define method locator-might-have-links? (locator :: <directory-locator>) => (links? :: singleton(#f)) #f end method locator-might-have-links?; define method locator-relative? (locator :: <file-locator>) => (relative? :: <boolean>) let directory = locator.locator-directory; ~directory | directory.locator-relative? end method locator-relative?; define method current-directory-locator? (locator :: <directory-locator>) => (current-directory? :: <boolean>) locator.locator-relative? & locator.locator-path = #[#"self"] end method current-directory-locator?; define method locator-directory (locator :: <directory-locator>) => (parent :: false-or(<directory-locator>)) let path = locator.locator-path; unless (empty?(path)) make(object-class(locator), server: locator.locator-server, path: copy-sequence(path, end: path.size - 1), relative?: locator.locator-relative?) end end method locator-directory; /// Simplify locator define open generic simplify-locator (locator :: <physical-locator>) => (simplified-locator :: <physical-locator>); define method simplify-locator (locator :: <directory-locator>) => (simplified-locator :: <directory-locator>) let path = locator.locator-path; let relative? = locator.locator-relative?; let resolve-parent? = ~locator.locator-might-have-links?; let simplified-path = simplify-path(path, resolve-parent?: resolve-parent?, relative?: relative?); if (path ~= simplified-path) make(object-class(locator), server: locator.locator-server, path: simplified-path, relative?: locator.locator-relative?) else locator end end method simplify-locator; define method simplify-locator (locator :: <file-locator>) => (simplified-locator :: <file-locator>) let directory = locator.locator-directory; let simplified-directory = directory & simplify-locator(directory); if (directory ~= simplified-directory) make(object-class(locator), directory: simplified-directory, base: locator.locator-base, extension: locator.locator-extension) else locator end end method simplify-locator; /// Subdirectory locator define open generic subdirectory-locator (locator :: <directory-locator>, #rest sub-path) => (subdirectory :: <directory-locator>); define method subdirectory-locator (locator :: <directory-locator>, #rest sub-path) => (subdirectory :: <directory-locator>) let old-path = locator.locator-path; let new-path = concatenate-as(<simple-object-vector>, old-path, sub-path); make(object-class(locator), server: locator.locator-server, path: new-path, relative?: locator.locator-relative?) end method subdirectory-locator; /// Relative locator define open generic relative-locator (locator :: <physical-locator>, from-locator :: <physical-locator>) => (relative-locator :: <physical-locator>); define method relative-locator (locator :: <directory-locator>, from-locator :: <directory-locator>) => (relative-locator :: <directory-locator>) let path = locator.locator-path; let from-path = from-locator.locator-path; case ~locator.locator-relative? & from-locator.locator-relative? => locator-error ("Cannot find relative path of absolute locator %= from relative locator %=", locator, from-locator); locator.locator-server ~= from-locator.locator-server => locator; path = from-path => make(object-class(locator), path: vector(#"self"), relative?: #t); otherwise => make(object-class(locator), path: relative-path(path, from-path, test: locator.locator-test), relative?: #t); end end method relative-locator; define method relative-locator (locator :: <file-locator>, from-directory :: <directory-locator>) => (relative-locator :: <file-locator>) let directory = locator.locator-directory; let relative-directory = directory & relative-locator(directory, from-directory); if (relative-directory ~= directory) simplify-locator (make(object-class(locator), directory: relative-directory, base: locator.locator-base, extension: locator.locator-extension)) else locator end end method relative-locator; define method relative-locator (locator :: <physical-locator>, from-locator :: <file-locator>) => (relative-locator :: <physical-locator>) let from-directory = from-locator.locator-directory; case from-directory => relative-locator(locator, from-directory); ~locator.locator-relative? => locator-error ("Cannot find relative path of absolute locator %= from relative locator %=", locator, from-locator); otherwise => locator; end end method relative-locator; /// Merge locators define open generic merge-locators (locator :: <physical-locator>, from-locator :: <physical-locator>) => (merged-locator :: <physical-locator>); /// Merge locators define method merge-locators (locator :: <directory-locator>, from-locator :: <directory-locator>) => (merged-locator :: <directory-locator>) if (locator.locator-relative?) let path = concatenate(from-locator.locator-path, locator.locator-path); simplify-locator (make(object-class(locator), server: from-locator.locator-server, path: path, relative?: from-locator.locator-relative?)) else locator end end method merge-locators; define method merge-locators (locator :: <file-locator>, from-locator :: <directory-locator>) => (merged-locator :: <file-locator>) let directory = locator.locator-directory; let merged-directory = if (directory) merge-locators(directory, from-locator) else simplify-locator(from-locator) end; if (merged-directory ~= directory) make(object-class(locator), directory: merged-directory, base: locator.locator-base, extension: locator.locator-extension) else locator end end method merge-locators; define method merge-locators (locator :: <physical-locator>, from-locator :: <file-locator>) => (merged-locator :: <physical-locator>) let from-directory = from-locator.locator-directory; if (from-directory) merge-locators(locator, from-directory) else locator end end method merge-locators; /// Locator protocols define sideways method supports-open-locator? (locator :: <file-locator>) => (openable? :: <boolean>) ~locator.locator-relative? end method supports-open-locator?; define sideways method open-locator (locator :: <file-locator>, #rest keywords, #key, #all-keys) => (stream :: <stream>) apply(open-file-stream, locator, keywords) end method open-locator; MIME types defined: text/x-dylan.
