summaryrefslogtreecommitdiffstats
path: root/glob.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /glob.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'glob.scm')
-rw-r--r--glob.scm136
1 files changed, 115 insertions, 21 deletions
diff --git a/glob.scm b/glob.scm
index d6e993b..382bbf3 100644
--- a/glob.scm
+++ b/glob.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,6 +17,10 @@
;promotional, or sales literature without prior written consent in
;each case.
+;;@code{(require 'filename)} or @code{(require 'glob)}
+;;@ftindex filename
+;;@ftindex glob
+
(define (glob:pattern->tokens pat)
(cond
((string? pat)
@@ -187,31 +191,87 @@
(else
(loop (cdr inds) (cdr wild?) lits res)))))))))
+;;@body
+;;Returns a predicate which returns a non-false value if its string argument
+;;matches (the string) @var{pattern}, false otherwise. Filename matching
+;;is like
+;;@cindex glob
+;;@dfn{glob} expansion described the bash manpage, except that names
+;;beginning with @samp{.} are matched and @samp{/} characters are not
+;;treated specially.
+;;
+;;These functions interpret the following characters specially in
+;;@var{pattern} strings:
+;;@table @samp
+;;@item *
+;;Matches any string, including the null string.
+;;@item ?
+;;Matches any single character.
+;;@item [@dots{}]
+;;Matches any one of the enclosed characters. A pair of characters
+;;separated by a minus sign (-) denotes a range; any character lexically
+;;between those two characters, inclusive, is matched. If the first
+;;character following the @samp{[} is a @samp{!} or a @samp{^} then any
+;;character not enclosed is matched. A @samp{-} or @samp{]} may be
+;;matched by including it as the first or last character in the set.
+;;@end table
+(define (filename:match?? pattern)
+ (glob:make-matcher pattern char=? char<=?))
+(define (filename:match-ci?? pattern)
+ (glob:make-matcher pattern char-ci=? char-ci<=?))
-(define (glob:match?? pat)
- (glob:make-matcher pat char=? char<=?))
-(define (glob:match-ci?? pat)
- (glob:make-matcher pat char-ci=? char-ci<=?))
-(define filename:match?? glob:match??)
-(define filename:match-ci?? glob:match-ci??)
-(define (glob:substitute?? pat templ)
- (cond ((procedure? templ)
- (glob:caller-with-matches pat templ char=? char<=?))
- ((string? templ)
- (glob:make-substituter pat templ char=? char<=?))
+;;@args pattern template
+;;Returns a function transforming a single string argument according to
+;;glob patterns @var{pattern} and @var{template}. @var{pattern} and
+;;@var{template} must have the same number of wildcard specifications,
+;;which need not be identical. @var{pattern} and @var{template} may have
+;;a different number of literal sections. If an argument to the function
+;;matches @var{pattern} in the sense of @code{filename:match??} then it
+;;returns a copy of @var{template} in which each wildcard specification is
+;;replaced by the part of the argument matched by the corresponding
+;;wildcard specification in @var{pattern}. A @code{*} wildcard matches
+;;the longest leftmost string possible. If the argument does not match
+;;@var{pattern} then false is returned.
+;;
+;;@var{template} may be a function accepting the same number of string
+;;arguments as there are wildcard specifications in @var{pattern}. In
+;;the case of a match the result of applying @var{template} to a list
+;;of the substrings matched by wildcard specifications will be returned,
+;;otherwise @var{template} will not be called and @code{#f} will be returned.
+(define (filename:substitute?? pattern template)
+ (cond ((procedure? template)
+ (glob:caller-with-matches pattern template char=? char<=?))
+ ((string? template)
+ (glob:make-substituter pattern template char=? char<=?))
(else
- (slib:error 'glob:substitute "bad second argument" templ))))
-(define (glob:substitute-ci?? pat templ)
- (cond ((procedure? templ)
- (glob:caller-with-matches pat templ char-ci=? char-ci<=?))
- ((string? templ)
- (glob:make-substituter pat templ char-ci=? char-ci<=?))
+ (slib:error 'filename:substitute?? "bad second argument" template))))
+(define (filename:substitute-ci?? pattern template)
+ (cond ((procedure? template)
+ (glob:caller-with-matches pattern template char-ci=? char-ci<=?))
+ ((string? template)
+ (glob:make-substituter pattern template char-ci=? char-ci<=?))
(else
- (slib:error 'glob:substitute "bad second argument" templ))))
-(define filename:substitute?? glob:substitute??)
-(define filename:substitute-ci?? glob:substitute-ci??)
+ (slib:error 'filename:substitute-ci?? "bad second argument" template))))
+
+;;@example
+;;((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm")
+;; "scm_10.html")
+;;@result{} "scm5c4_10.htm"
+;;((filename:substitute?? "??" "beg?mid?end") "AZ")
+;;@result{} "begAmidZend"
+;;((filename:substitute?? "*na*" "?NA?") "banana")
+;;@result{} "banaNA"
+;;((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1)))
+;; "ABZ")
+;;@result{} "ZA"
+;;@end example
+;;@body
+;;@var{str} can be a string or a list of strings. Returns a new string
+;;(or strings) similar to @code{str} but with the suffix string @var{old}
+;;removed and the suffix string @var{new} appended. If the end of
+;;@var{str} does not match @var{old}, an error is signaled.
(define (replace-suffix str old new)
(let* ((f (glob:make-substituter (list "*" old) (list "*" new)
char=? char<=?))
@@ -222,3 +282,37 @@
(if (pair? str)
(map g str)
(g str))))
+
+;;@example
+;;(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c")
+;;@result{} "/usr/local/lib/slib/batch.c"
+;;@end example
+
+;;@args proc k
+;;@args proc
+;;Calls @1 with @2 arguments, strings returned by successive calls to
+;;@code{tmpnam}.
+;;If @1 returns, then any files named by the arguments to @1 are
+;;deleted automatically and the value(s) yielded by the @1 is(are)
+;;returned. @2 may be ommited, in which case it defaults to @code{1}.
+;;
+;;@args proc suffix1 ...
+;;Calls @1 with strings returned by successive calls to @code{tmpnam},
+;;each with the corresponding @var{suffix} string appended.
+;;If @1 returns, then any files named by the arguments to @1 are
+;;deleted automatically and the value(s) yielded by the @1 is(are)
+;;returned.
+(define (call-with-tmpnam proc . suffi)
+ (define (do-call paths)
+ (let ((ans (apply proc paths)))
+ (for-each (lambda (path) (if (file-exists? path) (delete-file path)))
+ paths)
+ ans))
+ (cond ((null? suffi) (do-call (list (tmpnam))))
+ ((and (= 1 (length suffi)) (number? (car suffi)))
+ (do ((cnt (if (null? suffi) 0 (+ -1 (car suffi))) (+ -1 cnt))
+ (paths '() (cons (tmpnam) paths)))
+ ((negative? cnt)
+ (do-call paths))))
+ (else (do-call (map (lambda (suffix) (string-append (tmpnam) suffix))
+ suffi)))))