Changeset 34127 in project


Ignore:
Timestamp:
05/30/17 08:33:40 (5 months ago)
Author:
kon
Message:

added tests, re-flow

Location:
release/4/directory-utils
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/directory-utils/tags/1.0.5/directory-utils.scm

    r20913 r34127  
    88(module directory-utils
    99
    10   (;export
    11     pathname? check-pathname error-pathname
    12     filename? check-filename error-filename
    13     dot-pathname? dot-filename?
    14     #;directory? check-directory error-directory
    15     directory-fold
    16     push-directory
    17     pop-directory
    18     pop-toplevel-directory
    19     create-pathname-directory
    20     make-program-filename
    21     make-shell-filename
    22     file-exists/directory?
    23     find-file-pathnames
    24     find-program-pathnames
    25     which-command-pathnames
    26     which-command-pathname
    27     remove-dotfiles
    28     ; DEPRECATED
    29     create-directory/parents)
    30 
    31   (import
    32     scheme
    33     chicken
    34     (only data-structures
    35       string-split)
    36     (only files
    37       make-pathname
    38       pathname-directory pathname-extension pathname-file
    39       decompose-pathname decompose-directory)
    40     (only posix
    41       directory directory? current-directory create-directory
    42       file-exists?)
    43     (only srfi-1
    44       first fold append! filter-map remove any)
    45     (only srfi-13
    46       string-null? string-prefix?)
    47     (only miscmacros
    48       until)
    49     (only list-utils
    50       not-null? ensure-list)
    51     (only stack
    52       make-stack stack-push! stack-empty? stack-pop!)
    53     (only type-checks
    54       define-check+error-type
    55       check-procedure))
    56 
    57   (require-library
    58     data-structures srfi-1 srfi-13 files posix
    59     miscmacros list-utils stack type-checks)
     10(;export
     11  pathname? check-pathname error-pathname
     12  filename? check-filename error-filename
     13  dot-pathname? dot-filename?
     14  #;directory? check-directory error-directory
     15  directory-fold
     16  push-directory
     17  pop-directory
     18  pop-toplevel-directory
     19  create-pathname-directory
     20  make-program-filename
     21  make-shell-filename
     22  file-exists/directory?
     23  find-file-pathnames
     24  find-program-pathnames
     25  which-command-pathnames
     26  which-command-pathname
     27  remove-dotfiles
     28  ; DEPRECATED
     29  create-directory/parents)
     30
     31(import scheme)
     32
     33(import
     34  chicken
     35  (only data-structures
     36    string-split)
     37  (only files
     38    make-pathname
     39    pathname-directory pathname-extension pathname-file
     40    decompose-pathname decompose-directory)
     41  (only posix
     42    directory directory? current-directory create-directory
     43    file-exists?)
     44  (only srfi-1
     45    first fold append! filter-map remove any)
     46  (only srfi-13
     47    string-null? string-prefix?) )
     48(require-library
     49  data-structures srfi-1 srfi-13 files posix)
     50
     51(import
     52  (only miscmacros
     53    until)
     54  (only list-utils
     55    not-null? ensure-list)
     56  (only stack
     57    make-stack stack-push! stack-empty? stack-pop!)
     58  (only type-checks
     59    define-check+error-type
     60    check-procedure))
     61(require-library
     62  miscmacros list-utils stack type-checks)
    6063
    6164;;; Helpers
     
    6871
    6972(define (dot-filename-prefix? str)
    70   (and (string-prefix? "." str)
    71        (not (or (string=? "." str) (string=? ".." str)))) )
    72 
    73 (define (pathname-maybe? obj) (string? obj))
     73  (and
     74    (string-prefix? "." str)
     75    (not (or (string=? "." str) (string=? ".." str)))) )
     76
     77(define (pathname-maybe? obj)
     78  (string? obj) )
    7479
    7580;;;
     
    8489
    8590(define (pathname? obj)
    86   (and (pathname-maybe? obj)
    87        (let-values (((dir fil ext) (decompose-pathname obj)))
    88          (or dir fil))) )
     91  (and
     92    (pathname-maybe? obj)
     93    (let-values (((dir fil ext) (decompose-pathname obj)))
     94      (or dir fil))) )
    8995
    9096(define-check+error-type pathname)
     
    9399
    94100(define (filename? obj)
    95   (and (pathname-maybe? obj)
    96        (let-values (((dir fil ext) (decompose-pathname obj)))
    97          (and (not dir) fil))) )
     101  (and
     102    (pathname-maybe? obj)
     103    (let-values (((dir fil ext) (decompose-pathname obj)))
     104      (and (not dir) fil))) )
    98105
    99106(define-check+error-type filename)
     
    102109
    103110(define (dot-filename? obj)
    104   (and (filename? obj)
    105        (dot-filename-prefix? obj)) )
     111  (and
     112    (filename? obj)
     113    (dot-filename-prefix? obj)) )
    106114
    107115;; Any pathname component is a dot-filename?
    108116
    109117(define (dot-pathname? obj)
    110   (and (pathname-maybe? obj)
    111        (let-values (((dir fil ext) (decompose-pathname obj)))
    112          (or (dot-filename-prefix? fil)
    113              (let-values (((org dir elts) (decompose-directory dir)))
    114                (and elts
    115                     (any dot-filename-prefix? elts)))))) )
     118  (and
     119    (pathname-maybe? obj)
     120    (let-values (((dir fil ext) (decompose-pathname obj)))
     121      (or
     122        (dot-filename-prefix? fil)
     123        (let-values (((org dir elts) (decompose-directory dir)))
     124          (and
     125            elts
     126            (any dot-filename-prefix? elts)))))) )
    116127
    117128;; Remove dot files from a directory list
    118129
    119130(define (remove-dotfiles files)
    120         (remove (lambda (pn) (dot-filename? (pathname-file pn))) files) )
     131        (remove
     132          (lambda (pn)
     133            (dot-filename? (pathname-file pn)) )
     134          files) )
    121135
    122136;;
     
    146160      (stack-push! +directory-stack+ (current-directory))
    147161      ; Don't cd unless necessary
    148       (when (and dir
    149                  (not (or (string-null? dir)
    150                           (string=? +dot-directory+ (make-pathname dir #f)))))
     162      (when
     163          (and
     164            dir
     165            (not
     166              (or
     167                (string-null? dir)
     168                (string=? +dot-directory+ (make-pathname dir #f)))))
    151169        (current-directory dir) ) ) )
    152170
     
    184202  (cond-expand
    185203    (windows
    186       (if (pathname-extension bn) bn
    187         (make-pathname #f bn "exe")))
     204      (if (pathname-extension bn)
     205        bn
     206        (make-pathname #f bn "exe") ) )
    188207    (else
    189       bn)) )
     208      bn ) ) )
    190209
    191210(define (make-shell-filename bn)
    192211  (cond-expand
    193212    (windows
    194       (if (pathname-extension bn) bn
    195         (make-pathname #f bn "bat")))
     213      (if (pathname-extension bn)
     214        bn
     215        (make-pathname #f bn "bat") ) )
    196216    (else
    197       (if (pathname-extension bn) bn
    198         (make-pathname #f bn "sh")))) )
     217      (if (pathname-extension bn)
     218        bn
     219        (make-pathname #f bn "sh") ) ) ) )
    199220
    200221;; Pathname if file exists in directory.
     
    202223(define (file-exists/directory? fil #!optional dir)
    203224  (let ((path (make-pathname dir fil)))
    204     (and (file-exists? path)
    205          path) ) )
     225    (and
     226      (file-exists? path)
     227      path ) ) )
    206228
    207229;; List of all found pathnames.
    208230
    209231(define (find-file-pathnames/directory fil dir)
    210   (filter-map (cut file-exists/directory? fil <>) (ensure-list dir)) )
     232  (filter-map
     233    (cut file-exists/directory? fil <>)
     234    (ensure-list dir)) )
    211235
    212236(define (*find-file-pathnames fil dirs)
    213   (let loop ((dirs dirs)
    214              (paths '()))
    215     (if (null? dirs) (not-null? paths)
     237  (let loop ((dirs dirs) (paths '()))
     238    (if (null? dirs)
     239      (not-null? paths)
    216240      (loop
    217241        (cdr dirs)
  • release/4/directory-utils/tags/1.0.5/directory-utils.setup

    r27650 r34127  
    55(verify-extension-name "directory-utils")
    66
    7 (setup-shared-extension-module 'directory-utils (extension-version "1.0.3")
     7(setup-shared-extension-module 'directory-utils (extension-version "1.0.4")
    88  #:compile-options '(
    99    -scrutinize
    1010    -fixnum-arithmetic
    11     -optimize-level 3
    12     -no-procedure-checks -no-bound-checks))
     11    -optimize-level 3 -debug-level 1
     12    -no-procedure-checks))
  • release/4/directory-utils/tags/1.0.5/tests/run.scm

    r20284 r34127  
     1(use test)
     2
    13(use directory-utils)
    2 (use test)
    34
    45(test-assert (pathname? "abc/cbs.foo"))
     
    2425(test '("abc/cbs.foo") (remove-dotfiles '(".hide" "abc/cbs.foo")))
    2526
    26 #;(directory-fold func ident . args)
    27 
    28 #;(push-directory dir)
    29 #;(pop-directory)
    30 #;(pop-toplevel-directory)
    31 
    3227(test-assert (which-command-pathnames "mkdir"))
    3328(test-assert (not (which-command-pathnames "93274030#$%)#)$()")))
     29
     30(test "directory-fold" 1 (directory-fold (lambda (fn ct) (fx+ ct 1) ) 0 "." #:dotfiles? #f))
     31
     32(test-assert (push-directory ".."))
     33(test "directory-fold" 4 (directory-fold (lambda (fn ct) (fx+ ct 1) ) 0 "." #:dotfiles? #f))
     34
     35(test-assert (pop-toplevel-directory)) ;(pop-directory)
     36
     37(test-exit)
  • release/4/directory-utils/trunk/directory-utils.scm

    r20913 r34127  
    88(module directory-utils
    99
    10   (;export
    11     pathname? check-pathname error-pathname
    12     filename? check-filename error-filename
    13     dot-pathname? dot-filename?
    14     #;directory? check-directory error-directory
    15     directory-fold
    16     push-directory
    17     pop-directory
    18     pop-toplevel-directory
    19     create-pathname-directory
    20     make-program-filename
    21     make-shell-filename
    22     file-exists/directory?
    23     find-file-pathnames
    24     find-program-pathnames
    25     which-command-pathnames
    26     which-command-pathname
    27     remove-dotfiles
    28     ; DEPRECATED
    29     create-directory/parents)
    30 
    31   (import
    32     scheme
    33     chicken
    34     (only data-structures
    35       string-split)
    36     (only files
    37       make-pathname
    38       pathname-directory pathname-extension pathname-file
    39       decompose-pathname decompose-directory)
    40     (only posix
    41       directory directory? current-directory create-directory
    42       file-exists?)
    43     (only srfi-1
    44       first fold append! filter-map remove any)
    45     (only srfi-13
    46       string-null? string-prefix?)
    47     (only miscmacros
    48       until)
    49     (only list-utils
    50       not-null? ensure-list)
    51     (only stack
    52       make-stack stack-push! stack-empty? stack-pop!)
    53     (only type-checks
    54       define-check+error-type
    55       check-procedure))
    56 
    57   (require-library
    58     data-structures srfi-1 srfi-13 files posix
    59     miscmacros list-utils stack type-checks)
     10(;export
     11  pathname? check-pathname error-pathname
     12  filename? check-filename error-filename
     13  dot-pathname? dot-filename?
     14  #;directory? check-directory error-directory
     15  directory-fold
     16  push-directory
     17  pop-directory
     18  pop-toplevel-directory
     19  create-pathname-directory
     20  make-program-filename
     21  make-shell-filename
     22  file-exists/directory?
     23  find-file-pathnames
     24  find-program-pathnames
     25  which-command-pathnames
     26  which-command-pathname
     27  remove-dotfiles
     28  ; DEPRECATED
     29  create-directory/parents)
     30
     31(import scheme)
     32
     33(import
     34  chicken
     35  (only data-structures
     36    string-split)
     37  (only files
     38    make-pathname
     39    pathname-directory pathname-extension pathname-file
     40    decompose-pathname decompose-directory)
     41  (only posix
     42    directory directory? current-directory create-directory
     43    file-exists?)
     44  (only srfi-1
     45    first fold append! filter-map remove any)
     46  (only srfi-13
     47    string-null? string-prefix?) )
     48(require-library
     49  data-structures srfi-1 srfi-13 files posix)
     50
     51(import
     52  (only miscmacros
     53    until)
     54  (only list-utils
     55    not-null? ensure-list)
     56  (only stack
     57    make-stack stack-push! stack-empty? stack-pop!)
     58  (only type-checks
     59    define-check+error-type
     60    check-procedure))
     61(require-library
     62  miscmacros list-utils stack type-checks)
    6063
    6164;;; Helpers
     
    6871
    6972(define (dot-filename-prefix? str)
    70   (and (string-prefix? "." str)
    71        (not (or (string=? "." str) (string=? ".." str)))) )
    72 
    73 (define (pathname-maybe? obj) (string? obj))
     73  (and
     74    (string-prefix? "." str)
     75    (not (or (string=? "." str) (string=? ".." str)))) )
     76
     77(define (pathname-maybe? obj)
     78  (string? obj) )
    7479
    7580;;;
     
    8489
    8590(define (pathname? obj)
    86   (and (pathname-maybe? obj)
    87        (let-values (((dir fil ext) (decompose-pathname obj)))
    88          (or dir fil))) )
     91  (and
     92    (pathname-maybe? obj)
     93    (let-values (((dir fil ext) (decompose-pathname obj)))
     94      (or dir fil))) )
    8995
    9096(define-check+error-type pathname)
     
    9399
    94100(define (filename? obj)
    95   (and (pathname-maybe? obj)
    96        (let-values (((dir fil ext) (decompose-pathname obj)))
    97          (and (not dir) fil))) )
     101  (and
     102    (pathname-maybe? obj)
     103    (let-values (((dir fil ext) (decompose-pathname obj)))
     104      (and (not dir) fil))) )
    98105
    99106(define-check+error-type filename)
     
    102109
    103110(define (dot-filename? obj)
    104   (and (filename? obj)
    105        (dot-filename-prefix? obj)) )
     111  (and
     112    (filename? obj)
     113    (dot-filename-prefix? obj)) )
    106114
    107115;; Any pathname component is a dot-filename?
    108116
    109117(define (dot-pathname? obj)
    110   (and (pathname-maybe? obj)
    111        (let-values (((dir fil ext) (decompose-pathname obj)))
    112          (or (dot-filename-prefix? fil)
    113              (let-values (((org dir elts) (decompose-directory dir)))
    114                (and elts
    115                     (any dot-filename-prefix? elts)))))) )
     118  (and
     119    (pathname-maybe? obj)
     120    (let-values (((dir fil ext) (decompose-pathname obj)))
     121      (or
     122        (dot-filename-prefix? fil)
     123        (let-values (((org dir elts) (decompose-directory dir)))
     124          (and
     125            elts
     126            (any dot-filename-prefix? elts)))))) )
    116127
    117128;; Remove dot files from a directory list
    118129
    119130(define (remove-dotfiles files)
    120         (remove (lambda (pn) (dot-filename? (pathname-file pn))) files) )
     131        (remove
     132          (lambda (pn)
     133            (dot-filename? (pathname-file pn)) )
     134          files) )
    121135
    122136;;
     
    146160      (stack-push! +directory-stack+ (current-directory))
    147161      ; Don't cd unless necessary
    148       (when (and dir
    149                  (not (or (string-null? dir)
    150                           (string=? +dot-directory+ (make-pathname dir #f)))))
     162      (when
     163          (and
     164            dir
     165            (not
     166              (or
     167                (string-null? dir)
     168                (string=? +dot-directory+ (make-pathname dir #f)))))
    151169        (current-directory dir) ) ) )
    152170
     
    184202  (cond-expand
    185203    (windows
    186       (if (pathname-extension bn) bn
    187         (make-pathname #f bn "exe")))
     204      (if (pathname-extension bn)
     205        bn
     206        (make-pathname #f bn "exe") ) )
    188207    (else
    189       bn)) )
     208      bn ) ) )
    190209
    191210(define (make-shell-filename bn)
    192211  (cond-expand
    193212    (windows
    194       (if (pathname-extension bn) bn
    195         (make-pathname #f bn "bat")))
     213      (if (pathname-extension bn)
     214        bn
     215        (make-pathname #f bn "bat") ) )
    196216    (else
    197       (if (pathname-extension bn) bn
    198         (make-pathname #f bn "sh")))) )
     217      (if (pathname-extension bn)
     218        bn
     219        (make-pathname #f bn "sh") ) ) ) )
    199220
    200221;; Pathname if file exists in directory.
     
    202223(define (file-exists/directory? fil #!optional dir)
    203224  (let ((path (make-pathname dir fil)))
    204     (and (file-exists? path)
    205          path) ) )
     225    (and
     226      (file-exists? path)
     227      path ) ) )
    206228
    207229;; List of all found pathnames.
    208230
    209231(define (find-file-pathnames/directory fil dir)
    210   (filter-map (cut file-exists/directory? fil <>) (ensure-list dir)) )
     232  (filter-map
     233    (cut file-exists/directory? fil <>)
     234    (ensure-list dir)) )
    211235
    212236(define (*find-file-pathnames fil dirs)
    213   (let loop ((dirs dirs)
    214              (paths '()))
    215     (if (null? dirs) (not-null? paths)
     237  (let loop ((dirs dirs) (paths '()))
     238    (if (null? dirs)
     239      (not-null? paths)
    216240      (loop
    217241        (cdr dirs)
  • release/4/directory-utils/trunk/directory-utils.setup

    r27650 r34127  
    55(verify-extension-name "directory-utils")
    66
    7 (setup-shared-extension-module 'directory-utils (extension-version "1.0.3")
     7(setup-shared-extension-module 'directory-utils (extension-version "1.0.4")
    88  #:compile-options '(
    99    -scrutinize
    1010    -fixnum-arithmetic
    11     -optimize-level 3
    12     -no-procedure-checks -no-bound-checks))
     11    -optimize-level 3 -debug-level 1
     12    -no-procedure-checks))
  • release/4/directory-utils/trunk/tests/run.scm

    r20284 r34127  
     1(use test)
     2
    13(use directory-utils)
    2 (use test)
    34
    45(test-assert (pathname? "abc/cbs.foo"))
     
    2425(test '("abc/cbs.foo") (remove-dotfiles '(".hide" "abc/cbs.foo")))
    2526
    26 #;(directory-fold func ident . args)
    27 
    28 #;(push-directory dir)
    29 #;(pop-directory)
    30 #;(pop-toplevel-directory)
    31 
    3227(test-assert (which-command-pathnames "mkdir"))
    3328(test-assert (not (which-command-pathnames "93274030#$%)#)$()")))
     29
     30(test "directory-fold" 1 (directory-fold (lambda (fn ct) (fx+ ct 1) ) 0 "." #:dotfiles? #f))
     31
     32(test-assert (push-directory ".."))
     33(test "directory-fold" 4 (directory-fold (lambda (fn ct) (fx+ ct 1) ) 0 "." #:dotfiles? #f))
     34
     35(test-assert (pop-toplevel-directory)) ;(pop-directory)
     36
     37(test-exit)
Note: See TracChangeset for help on using the changeset viewer.