[REBOL] Some console functions (user_console.r)
From: d4marcus::dtek::chalmers::se at: 10-Apr-2001 19:25
Here's some various functions included in my startup, that perhaps someone
else will find useful. A few of them are modified versions of functions
found in other people's scripts, but some are written from scratch by me.
You may find that 'tree-builder and 'recurse share some ideas. However,
'tree-builder builds the entire directory tree down to a level (if given),
using 'filter-contents to apply pattern-matching. Whereas 'recurse checks
for matches directly, and only include files at the end of the pattern
(or the contents if it's a dir, same behaviour as ls -l in Unix).
See 'tree and 'll respectivly for examples of 'tree-builder and 'recurse.
Both use 'tree-parser, 'tree with default actions, 'll with custom ones.
Oops, almost forgot examples for ll and tree:
ll Doc*/*/*.html
Tree/match %Docs *.html
REBOL [
Title: "User Console Functions"
Date: 09-Apr-2001
Author: "Marcus Petersson"
]
Cls: func ["Clear screen"] [prin "^(page)"]
;----------------------------------------------------------------
history-size: 40
history: func [
"Show history."
nr [any-type!] "Any other arg but an integer is ignored" /local hist
] [
if not all [value? 'nr integer? nr] [nr: history-size]
hist: copy/part system/console/history nr
foreach empty (head reverse hist) [print empty]]
;----------------------------------------------------------------
echo-char: func [
"Repeats the characters you press. End with Ctrl-D."
/local cons char
] [
cons: open/binary [scheme: 'console]
while [
wait cons
char: to-char first cons
char <> #"^D"
] [
print [mold char "Value:" to-integer char]
]
close cons
]
;----------------------------------------------------------------
; shell aliases
ls: :list-dir
rm: :delete
mv: :rename
wd: pwd: :what-dir
docstring: func [
"Returns the documentation string (if any) of a function"
'f [any-word!]] [f: first third get to-lit-word f all [string? f f]]
md: func compose [(docstring make-dir) path [file! url!]] [
make-dir/deep to-file path]
dir-previous: reduce [what-dir]
if not value? 'dir-home [dir-home: system/options/home]
cd: func compose [(docstring change-dir)
dir [file! string! word! unset!] "New directory path (home if unset)"
] [
dir-previous: union reduce [what-dir] dir-previous
change-dir either value? 'dir [to-file dir] [dir-home]]
p: func [
"Goto previous dir."
nr [any-type!] "Any other arg but an integer is ignored"
] [
if not all [value? 'nr integer? nr (nr <= length? dir-previous)] [nr: 1]
cd dir-previous/:nr]
..: func [] [cd %..]
;----------------------------------------------------------------
timer: function ["Requires Core 2.4" funcs [block!]] [start] [
start: now/time/precise do funcs now/time/precise - start]
;----------------------------------------------------------------
;; Example: print pad/with "Not Unix" -2000 "GNU's "
;; pad/with 33 33 33
pad: func ["Pad some value."
value "Value to pad"
length [integer!] {Final length of string.
positive => pad after value (left justify)
negative => pad before value (right justify)}
/with char [char! string! integer!] "Character to pad with"
/local l2
] [
any [string? char char: either with [to-string to-char char] [" "]]
with: negative? length ; reusing 'with
value: copy/part to-string value length: abs length
either positive? l2: length - length? value [
head insert do either with [:tail] [:head] (copy/part (to-string
array/initial 1 + to-integer (length / length? char)char)
l2) value] [value]
]
;----------------------------------------------------------------
wildcards: function [
"Translates ? and * wildcard expression to REBOL parse rule."
'pattern] [fpt ar rule p question star] [
rule: copy []
ar: func [p] [any [None? p append rule p]]
fpt: func [val /local bt] [all [not empty? bt: back tail rule
('thru = bt/1) insert remove back tail rule val]]
question: [copy p to "?" (ar p fpt [] ar [skip]) skip]
star: [copy p to "*" (ar p fpt [] ar [thru]) skip]
parse to-string pattern [any [star | question] copy p to end (ar p)]
fpt [to end] rule
]
filter-contents: func [
{Filters a multi-level block of to-stringable series or words
through either ?*-style patterns or REBOL parse rules.}
block [block!] "Block to filter"
'pattern "Pattern to match"
/except "Except..." 'nopat "Pattern to not match"
/tree "To filter a dir-tree-block"
'dirpattern "Dir pattern to match"
'dirnopat [any-type!] "Dir pattern to not match"
] [
any [dirpattern dirpattern: '*]
any [value? 'dirnopat dirnopat: None]
filter-contents! block reduce [tree :pattern :nopat :dirpattern :dirnopat]
]
filter-contents!: function [
"Main function of filter-contents"
block [block!] "Block to filter"
_p [block!] {Five items: 1. Are we matching a dir-tree-block? /
2. Pattern to match / 3. not match /
4. Dir pattern to match / 5. not match}
] [
matching filter nr
] [
nr: next _p
forall nr [any [block? nr/1 nr/1: wildcards nr/1]]
nr: either _p/1 [2] [1]
matching: copy/deep block
filter: function [f] [parsef1 match-dir] [
parsef1: func [_pat] [parse/case to-string f/1 _pat]
match-dir: does [either all [_p/1
any [not parsef1 _p/4 parsef1 _p/5]] [
remove/part f 2] [filter f/:nr f: skip f nr]]
until [either block? f/:nr [match-dir] [
either any [not parsef1 _p/2 parsef1 _p/3] [
remove f] [f: next f]] empty? f]]
filter matching
head matching
]
;----------------------------------------------------------------
Tree!: make object! [
set 'tree-builder function [
"Builds a directory tree, returns a nested block"
dir [file!] level [integer! none!]] [path build] [
build: function [dir] [
files result
] [
result: copy []
if any [None? level level > 0] [
files: sort/case read path
foreach file files [
either dir? join path file [
append result file
append path file
all [level level: level - 1]
append/only result build file
all [level level: level + 1]
clear find/last path file
] [
append result file]]]
result]
any [value? 'level level: None]
either dir? dir [path: dirize dir
append/only reduce [path] build path] [
reduce [dir]]
]
; variables that tree-parser use
stack!: make object! [
stack: make block! 32
push: func [item] [insert/only stack item]
pop: func [/local item] [item: pick stack 1 remove stack item]
depth: does [length? stack]
see1: does [pick stack 1]
check: does [probe stack]
]
intstack!: make stack! [
inc1: does [stack/1: stack/1 + 1]
dec1: does [stack/1: stack/1 - 1]
dec2: does [stack/1: stack/1 - 2]
indent: func [_branch _space _node _end /local result] [
either depth < 2 [[]] [
result: copy either (0 < stack/1) [_node] [_end]
foreach int copy/part at stack 2 (length? stack) - 2 [
insert result either (0 < int) [_branch] [_space]]
result]]
default-indent: does [indent "| " " " "|-- " "`-- "]
]
path: branch: block: node: counter: None
branchaction-default: [print rejoin ["dir: " counter/default-indent branch]]
nodeaction-default: [print rejoin ["file: " counter/default-indent node]]
branchaction: branchaction-default
nodeaction: nodeaction-default
type-branch: [file! | string!]
type-node: type-branch
set 'tree-count-items func [b [block!] /local c] [
c: length? b parse b [any [[block! (c: c - 1)] | skip]] c]
branchrule: [set branch type-branch set block block!
(counter/dec2
path: either all [path path <> %./] [join path branch] [branch]
do branchaction
counter/push length? block
parse block rule
counter/pop
path: first split-path path)]
noderule: [set node type-node
(counter/dec1
do nodeaction)]
rule: [any [branchrule | noderule]]
set 'tree-init func [/branch action1 /node action2] [
branchaction: either branch [bind action1 in self 'self] [branchaction-default]
nodeaction: either node [bind action2 in self 'self] [nodeaction-default] ()]
set 'tree-parser func [treeblock [block!]] [
;any [block? pick treeblock 2 path: %./]
counter: make intstack! []
counter/push length? treeblock
parse treeblock rule]
set 'Tree func ["Print directory tree"
dir [file! unset!] "Directory to list"
/level nr [integer!] "Levels to recurse" ()
/match 'pattern [any-word! string! file!] "Pattern to match"
'nopat [any-word! string! file! unset!] "Optional pattern to not match"
] [
any [value? 'dir dir: %.]
any [pattern pattern: '*]
any [value? 'nopat nopat: none]
tree-parser filter-contents! (tree-builder dir nr) reduce [
true :pattern :nopat '* '.xvpics*] ()]
]
;----------------------------------------------------------------
recurse: function ['pattern] [dir dots] [
pattern: either any [any-word? :pattern path? :pattern] [
to-block :pattern] [parse :pattern "/"]
parse pattern [copy dots [any ['.. | ".."]] copy pattern to end]
any [pattern pattern: copy []]
dir: either dots [to-file dots] [%.]
forall pattern [pattern/1: wildcards pattern/1]
recurse! (clean-path dirize dir) head pattern
]
recurse!: function [dir [file!] pattern [block!]] [
match-file result files block dirs dirnext
] [
match-file: func [file] [
remove back tail file: dirize to-string file
parse/case file pattern/1]
result: copy []
dirs: copy []
files: sort/case read dir
foreach file files [
if match-file file [
dirnext: to-file reduce [dir file]
either all [dir? dirnext not empty? pattern] [append dirs dirnext] [
if empty? next pattern [append result file]]]]
foreach dir dirs [
if not empty? block: recurse! dir next pattern [
append result last split-path dir
append/only result block]]
result
]
ll: function [
"Display a directory listing"
'pattern [any-type!] "Optional pattern for selective list. Use wildcards * and ?"
/silent
][
branchact nodeact filepath file-size file-mod file-time file-date buffer
][
branchact: [if not block? block/2 [
append buffer rejoin ["^/" path " (" tree-count-items block " files):^/"]]]
nodeact: [filepath: either path [to-file reduce [path node]] [node]
file-size: pad (either dir? filepath [length? read filepath] [size? filepath]) -8
if file-mod: modified? filepath [
parse (to-string file-mod/time) [copy file-time [thru ":" to ":"]
(file-time: pad file-time -5)]
file-date: rejoin [pad file-mod/date -11]]
append buffer rejoin [file-size " " file-date " " file-time " " node "^/"]]
any [value? 'pattern pattern: ""]
buffer: make string! 1000
tree-init/branch/node branchact nodeact
tree-parser recurse :pattern
either silent [buffer] [prin buffer]
]
() ; end of script
Marcus
------------------------------------
If you find that life spits on you
calm down and pretend it's raining
