diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index 94cb23832d..fa9d67b091 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -33,13 +33,21 @@ HELP: file-extension HELP: file-stem { $values { "path" "a pathname string" } { "stem" string } } -{ $description "Outputs the " { $link file-name } " of " { $snippet "filename" } " with the file extension removed, if any." } +{ $description "Outputs the " { $link file-name } " of " { $snippet "path" } " with the file extension removed, if any." } { $examples { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-stem ." "\"gcc\"" } { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-stem ." "\"gui\"" } } ; -{ file-name file-stem file-extension } related-words +HELP: file-directory +{ $values { "path" "a pathname string" } { "directory" string } } +{ $description "Outputs the directory of " { $snippet "path" } " with the " { $link file-name } " removed, if any." } +{ $examples + { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-directory ." "\"/usr/bin\"" } + { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-directory ." "\"/home/csi\"" } +} ; + +{ file-name file-stem file-extension file-directory } related-words HELP: path-components { $values { "path" "a pathnames string" } { "seq" sequence } } diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 7fc89cbb74..a3dd04afef 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -76,6 +76,13 @@ ERROR: no-parent-directory path ; [ f ] } cond ; +: special-path ( path -- prefix ) + { + { [ dup "resource:" head? ] [ drop "resource:" ] } + { [ dup "vocab:" head? ] [ drop "vocab:" ] } + [ drop "" ] + } cond ; + PRIVATE> : absolute-path? ( path -- ? ) @@ -125,6 +132,11 @@ PRIVATE> : file-extension ( path -- extension ) file-name "." split1-last nip ; +: file-directory ( path -- directory ) + [ special-path ] [ special-path? drop ] bi + dup last-path-separator [ head append ] [ 2drop ] if + [ path-separator ] when-empty ; + : path-components ( path -- seq ) normalize-path path-separator split harvest ; @@ -155,9 +167,9 @@ M: string absolute-path "~" ?head [ trim-head-separators home prepend-path absolute-path - ] [ + ] [ current-directory get prepend-path - ] if ] if + ] if ] if ] if ; M: object normalize-path ( path -- path' )