io.pathnames: adding file-directory.

diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor
index 94cb23832dd9ff2105ee77719298adf303796a22..fa9d67b09118f7790ecf8d57b7d36f5cd5c95600 100644 (file)
--- 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 7fc89cbb74c3bf18ea7d41f6a5818e3982822a5d..a3dd04afefcc692b73592584b62fdf88d796c97f 100644 (file)
--- 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' )