Merge branch 'master' of git://factorcode.org/git/factor
						commit
						4d678d7436
					
				| 
						 | 
				
			
			@ -3,18 +3,23 @@
 | 
			
		|||
USING: accessors arrays continuations deques dlists fry
 | 
			
		||||
io.directories io.files io.files.info io.pathnames kernel
 | 
			
		||||
sequences system vocabs.loader locals math namespaces
 | 
			
		||||
sorting assocs ;
 | 
			
		||||
sorting assocs calendar threads ;
 | 
			
		||||
IN: io.directories.search
 | 
			
		||||
 | 
			
		||||
: qualified-directory-entries ( path -- seq )
 | 
			
		||||
    dup directory-entries
 | 
			
		||||
    [ [ append-path ] change-name ] with map ;
 | 
			
		||||
 | 
			
		||||
: qualified-directory-files ( path -- seq )
 | 
			
		||||
    dup directory-files [ append-path ] with map ;
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
TUPLE: directory-iterator path bfs queue ;
 | 
			
		||||
 | 
			
		||||
: qualified-directory ( path -- seq )
 | 
			
		||||
    dup directory-files [ append-path ] with map ;
 | 
			
		||||
 | 
			
		||||
: push-directory ( path iter -- )
 | 
			
		||||
    [ qualified-directory ] dip '[
 | 
			
		||||
    [ dup directory-entry? [ name>> ] when ] dip
 | 
			
		||||
    [ qualified-directory-entries ] dip '[
 | 
			
		||||
        _ [ queue>> ] [ bfs>> ] bi
 | 
			
		||||
        [ push-front ] [ push-back ] if
 | 
			
		||||
    ] each ;
 | 
			
		||||
| 
						 | 
				
			
			@ -25,8 +30,9 @@ TUPLE: directory-iterator path bfs queue ;
 | 
			
		|||
 | 
			
		||||
: next-file ( iter -- file/f )
 | 
			
		||||
    dup queue>> deque-empty? [ drop f ] [
 | 
			
		||||
        dup queue>> pop-back dup link-info directory?
 | 
			
		||||
        [ over push-directory next-file ] [ nip ] if
 | 
			
		||||
        dup queue>> pop-back dup directory?
 | 
			
		||||
        [ over push-directory next-file ]
 | 
			
		||||
        [ nip name>> ] if
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
:: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
 | 
			
		||||
| 
						 | 
				
			
			@ -71,29 +77,26 @@ ERROR: file-not-found ;
 | 
			
		|||
    '[ _ _ find-all-files ] map concat ; inline
 | 
			
		||||
 | 
			
		||||
: with-qualified-directory-files ( path quot -- )
 | 
			
		||||
    '[
 | 
			
		||||
        "" directory-files current-directory get
 | 
			
		||||
        '[ _ prepend-path ] map @
 | 
			
		||||
    ] with-directory ; inline
 | 
			
		||||
    '[ "" qualified-directory-files @ ] with-directory ; inline
 | 
			
		||||
 | 
			
		||||
: with-qualified-directory-entries ( path quot -- )
 | 
			
		||||
    '[
 | 
			
		||||
        "" directory-entries current-directory get
 | 
			
		||||
        '[ [ _ prepend-path ] change-name ] map @
 | 
			
		||||
    ] with-directory ; inline
 | 
			
		||||
    '[ "" qualified-directory-entries @ ] with-directory ; inline
 | 
			
		||||
 | 
			
		||||
: directory-size ( path -- n )
 | 
			
		||||
    0 swap t [ link-info size-on-disk>> + ] each-file ;
 | 
			
		||||
    0 swap t [
 | 
			
		||||
        [ link-info size-on-disk>> + ] [ 2drop ] recover
 | 
			
		||||
    ] each-file ;
 | 
			
		||||
 | 
			
		||||
: directory-usage ( path -- assoc )
 | 
			
		||||
    [
 | 
			
		||||
        [
 | 
			
		||||
: path>usage ( directory-entry -- name size )
 | 
			
		||||
    [ name>> dup ] [ directory? ] bi [
 | 
			
		||||
        directory-size
 | 
			
		||||
    ] [
 | 
			
		||||
                link-info size-on-disk>>
 | 
			
		||||
            ] if
 | 
			
		||||
        ] { } map>assoc
 | 
			
		||||
        [ link-info size-on-disk>> ] [ 2drop 0 ] recover
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
: directory-usage ( path -- assoc )
 | 
			
		||||
    [
 | 
			
		||||
        [ [ path>usage ] [ drop name>> 0 ] recover ] { } map>assoc
 | 
			
		||||
    ] with-qualified-directory-entries sort-values ;
 | 
			
		||||
 | 
			
		||||
os windows? [ "io.directories.search.windows" require ] when
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue