factor-shell: Initial commit.
Doug Coleman
parent
ffb42c913e
commit
7b7fd6a2e5
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
! Copyright (C) 2018 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test factor-shell ;
|
||||
IN: factor-shell.tests
|
||||
|
||||
! Absolute paths
|
||||
{ "/" } [ "/" canonicalize-path ] unit-test
|
||||
{ "/" } [ "/." canonicalize-path ] unit-test
|
||||
{ "/" } [ "/.." canonicalize-path ] unit-test
|
||||
{ "/" } [ "/Users/.." canonicalize-path ] unit-test
|
||||
{ "/" } [ "/Users/../" canonicalize-path ] unit-test
|
||||
{ "/" } [ "/Users/../." canonicalize-path ] unit-test
|
||||
{ "/" } [ "/Users/.././" canonicalize-path ] unit-test
|
||||
{ "/" } [ "/Users/.././././././" canonicalize-path ] unit-test
|
||||
{ "/" } [ "/Users/../././/////./././/././././//././././././." canonicalize-path ] unit-test
|
||||
{ "/" } [ "/Users/../../../..////.././././././/../" canonicalize-path ] unit-test
|
||||
{ "/Users" } [ "/Users/../../../Users" canonicalize-path ] unit-test
|
||||
|
||||
{ "/Users" } [ "/Users" canonicalize-path ] unit-test
|
||||
{ "/Users" } [ "/Users/." canonicalize-path ] unit-test
|
||||
{ "/Users/foo/bar" } [ "/Users/foo/bar" canonicalize-path ] unit-test
|
||||
|
||||
|
||||
! Relative paths
|
||||
{ "." } [ f canonicalize-path ] unit-test
|
||||
{ "." } [ "" canonicalize-path ] unit-test
|
||||
{ "." } [ "." canonicalize-path ] unit-test
|
||||
{ "." } [ "./" canonicalize-path ] unit-test
|
||||
{ "." } [ "./." canonicalize-path ] unit-test
|
||||
{ ".." } [ ".." canonicalize-path ] unit-test
|
||||
{ ".." } [ "../" canonicalize-path ] unit-test
|
||||
{ ".." } [ "../." canonicalize-path ] unit-test
|
||||
{ ".." } [ ".././././././//." canonicalize-path ] unit-test
|
||||
|
||||
{ "../.." } [ "../.." canonicalize-path ] unit-test
|
||||
{ "../.." } [ "../../" canonicalize-path ] unit-test
|
||||
{ "../.." } [ "../.././././/./././" canonicalize-path ] unit-test
|
||||
|
||||
|
||||
! Root paths
|
||||
{ "/" } [ "/" root-path ] unit-test
|
||||
{ "/" } [ "/Users" root-path ] unit-test
|
||||
{ "/" } [ "//" root-path ] unit-test
|
||||
{ "/" } [ "//Users" root-path ] unit-test
|
||||
{ "/" } [ "/Users/foo/bar////././." root-path ] unit-test
|
||||
{ "/" } [ "/Users/////" root-path ] unit-test
|
||||
|
|
@ -0,0 +1,285 @@
|
|||
! Copyright (C) 2018 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
combinators combinators.extras combinators.short-circuit
|
||||
combinators.smart continuations fry io io.backend
|
||||
io.encodings.utf8 io.files io.files.info io.launcher
|
||||
io.pathnames io.standard-paths kernel lexer libc math math.order
|
||||
multiline multiline.private namespaces parser prettyprint
|
||||
sequences sequences.deep splitting strings system
|
||||
system-info.macosx tools.hexdump unicode unix.signals unix.users
|
||||
words ;
|
||||
IN: factor-shell
|
||||
|
||||
! General utils.
|
||||
: trim-blanks ( string -- string' ) [ blank? ] trim ; inline
|
||||
: trim-head-blanks ( string -- string' ) [ blank? ] trim-head ; inline
|
||||
: trim-tail-blanks ( string -- string' ) [ blank? ] trim-tail ; inline
|
||||
|
||||
GENERIC: find-command-path ( obj -- obj' )
|
||||
|
||||
M: sequence find-command-path
|
||||
0 over [ find-in-standard-login-path ] change-nth ;
|
||||
|
||||
M: process find-command-path
|
||||
[ find-command-path ] change-command ;
|
||||
|
||||
GENERIC#: run-process>string 1 ( command encoding -- string )
|
||||
|
||||
M: array run-process>string ( command encoding -- string )
|
||||
[ <process> swap >>command +new-session+ >>group ] dip
|
||||
|
||||
[ find-command-path ] dip
|
||||
[ contents ] with-process-reader ; inline
|
||||
|
||||
M: string run-process>string
|
||||
[ <process> swap >>command +new-session+ >>group ] dip
|
||||
|
||||
[ contents ] with-process-reader ; inline
|
||||
|
||||
: run-utf8-process>string ( command -- string )
|
||||
utf8 run-process>string ; inline
|
||||
|
||||
|
||||
! Shell things.
|
||||
SYMBOL: factsh-directory-stack
|
||||
factsh-directory-stack [ V{ } clone ] initialize
|
||||
|
||||
SYMBOL: previous-directory
|
||||
SYMBOL: pending-directory
|
||||
|
||||
|
||||
: pushd ( string -- )
|
||||
factsh-directory-stack get push ;
|
||||
|
||||
: popd ( -- string )
|
||||
factsh-directory-stack get pop ;
|
||||
<<
|
||||
: matching-delimiter ( ch -- ch' )
|
||||
H{
|
||||
{ CHAR: ( CHAR: ) }
|
||||
{ CHAR: [ CHAR: ] }
|
||||
{ CHAR: { CHAR: } }
|
||||
{ CHAR: < CHAR: > }
|
||||
{ CHAR: : CHAR: ; }
|
||||
} ?at drop ;
|
||||
|
||||
: matching-delimiter-string ( string -- string' )
|
||||
[ matching-delimiter ] map ;
|
||||
>>
|
||||
|
||||
<<
|
||||
|
||||
SYNTAX: STRING-SYNTAX:
|
||||
scan-token
|
||||
[ create-class-in dup tuple { "payload" } define-tuple-class ]
|
||||
[ ] bi
|
||||
{ "[[" "[=[" "[==[" "[===[" "[====[" } [
|
||||
[ append create-word-in dup reset-generic ]
|
||||
[ nip matching-delimiter-string ] 2bi
|
||||
rot
|
||||
'[ _ parse-multiline-string _ boa suffix! ] define-syntax
|
||||
] with with each ;
|
||||
|
||||
>>
|
||||
|
||||
<<
|
||||
! STRING-SYNTAX: FACTSH
|
||||
STRING-SYNTAX: FACTOR
|
||||
STRING-SYNTAX: PYTHON
|
||||
STRING-SYNTAX: RUBY
|
||||
>>
|
||||
|
||||
GENERIC: execute-string ( obj -- string )
|
||||
M: FACTOR execute-string
|
||||
payload>> "-e=" prepend vm-path swap 2array run-utf8-process>string ;
|
||||
M: PYTHON execute-string
|
||||
payload>> 1array { "python" "-c" } prepend run-utf8-process>string ;
|
||||
M: RUBY execute-string
|
||||
payload>> 1array { "ruby" "-e" } prepend run-utf8-process>string ;
|
||||
|
||||
ERROR: expected-len1 obj ;
|
||||
: len1 ( seq -- obj ) dup length 1 = [ first ] [ expected-len1 ] if ;
|
||||
ERROR: expected-len2 obj ;
|
||||
: len2 ( seq -- obj1 obj2 ) dup length 2 = [ first2 ] [ expected-len2 ] if ;
|
||||
|
||||
: find-binary-name ( string -- string/path ? )
|
||||
dup find-in-standard-login-path [ nip t ] [ f ] if* ;
|
||||
|
||||
: transfer ( var1 var2 -- )
|
||||
[ get ] dip set ; inline
|
||||
|
||||
: swap-vars ( var1 var2 -- )
|
||||
[ [ get ] bi@ ] 2keep [ set ] dip set ; inline
|
||||
|
||||
ERROR: builtin-failed command argument message ;
|
||||
: check-directory-exists ( to -- to )
|
||||
dup { [ exists? ] [ file-info directory? ] } 1&&
|
||||
[ "cd" swap "No such directory" builtin-failed ] unless ;
|
||||
|
||||
: root-path ( path -- path' )
|
||||
dup absolute-path? [
|
||||
dup [ path-separator? ] find
|
||||
drop 1 + head
|
||||
] when ;
|
||||
|
||||
: relative-path ( path -- relative-path )
|
||||
dup absolute-path? [
|
||||
dup [ path-separator? ] find
|
||||
drop 1 + tail
|
||||
] when ;
|
||||
|
||||
: canonicalize-path ( path -- path' )
|
||||
[
|
||||
relative-path
|
||||
[ path-separator? ] split-when
|
||||
[ { "." "" } member? ] reject
|
||||
V{ } clone [
|
||||
dup ".." = [
|
||||
over empty?
|
||||
[ over push ]
|
||||
[ over ?last ".." = [ over push ] [ drop dup pop* ] if ] if
|
||||
] [
|
||||
over push
|
||||
] if
|
||||
] reduce
|
||||
] keep dup absolute-path? [
|
||||
[
|
||||
[ ".." = ] trim-head
|
||||
path-separator join
|
||||
] dip root-path prepend-path
|
||||
] [
|
||||
drop path-separator join [ "." ] when-empty
|
||||
] if ;
|
||||
|
||||
: count-canonical-path-components ( path -- n )
|
||||
canonicalize-path [ CHAR: / = ] count 1 + ;
|
||||
|
||||
: mismatch-tail ( seq1 seq2 -- seq1 seq2 )
|
||||
2dup mismatch [ 2dup [ length ] bi@ min ] unless*
|
||||
'[ _ tail ] bi@ ;
|
||||
|
||||
! c:\ vs d:\ -- no relative path possible. also impossible on unix.
|
||||
: derive-both-absolute ( absolute-path1 absolute-path2 -- path1-relative-to-path2 )
|
||||
[ "/" split ] bi@ mismatch-tail [ "/" join ] bi@
|
||||
count-canonical-path-components
|
||||
[ ".." ] replicate "/" join prepend-path ;
|
||||
|
||||
: derive-relative-path ( path1 path2 -- path1-relative-to-path2 )
|
||||
[ canonicalize-path ] bi@
|
||||
{
|
||||
{ [ 2dup [ absolute-path ] both? ] [ derive-both-absolute ] }
|
||||
[ "unimplemented" throw ]
|
||||
} cond ; inline
|
||||
|
||||
: home-directory? ( path -- ? ) "~" head? ;
|
||||
: current-directory? ( path -- ? ) "./" head? ;
|
||||
|
||||
: fixup-home-directory ( path -- path' )
|
||||
[ path-separator? ] split-when
|
||||
dup first length 1 > [
|
||||
unclip [ "/" join ] [ rest home parent-directory prepend ] bi* append
|
||||
] [
|
||||
"/" join
|
||||
] if ;
|
||||
|
||||
: our-cd ( args -- string/f )
|
||||
'[
|
||||
_ [ trim-blanks ] map
|
||||
current-directory pending-directory transfer
|
||||
[
|
||||
current-directory '[ drop home ] change
|
||||
] [
|
||||
{
|
||||
{ [ dup { "-" } sequence= ] [ drop previous-directory get current-directory set ] }
|
||||
{ [ dup first home-directory? ] [ first fixup-home-directory current-directory set ] }
|
||||
! { { "-L" } [ ] }
|
||||
! { { "-P" } [ ] }
|
||||
[ len1 normalize-path canonicalize-path check-directory-exists current-directory set ]
|
||||
} cond
|
||||
] if-empty
|
||||
pending-directory previous-directory transfer f
|
||||
] [
|
||||
unparse
|
||||
] recover ;
|
||||
|
||||
SYMBOL: exit-shell?
|
||||
|
||||
ERROR: unknown-command cmd args ;
|
||||
: eval-factsh ( string -- string-output )
|
||||
[ blank? ] trim-head " " split harvest [
|
||||
f
|
||||
] [
|
||||
unclip {
|
||||
{ "cd" [ our-cd ] }
|
||||
{ "ls" [ { "ls" } prepend utf8 run-process>string ] }
|
||||
{ "pwd" [ drop current-directory get "\n" append ] }
|
||||
{ "exit" [ [ 0 exit-shell? set ] [ len1 exit-shell? set ] if-empty "logout\n" ] }
|
||||
! { "pushd" [ len1 current-directory get ] }
|
||||
! { "popd" [ current-directory get ] }
|
||||
[
|
||||
dup current-directory? [
|
||||
dup current-directory get prepend-path
|
||||
dup exists? [
|
||||
2nip run-utf8-process>string
|
||||
] [
|
||||
swap unknown-command
|
||||
] if
|
||||
] [
|
||||
find-binary-name [ prefix run-utf8-process>string ]
|
||||
[ swap unknown-command ] if
|
||||
] if
|
||||
]
|
||||
} case
|
||||
] if-empty ;
|
||||
|
||||
: computer-name ( -- string ) { 1 10 } sysctl-query-string "." split1 drop ;
|
||||
|
||||
: osx-bash-prompt ( -- string )
|
||||
[
|
||||
computer-name ":"
|
||||
current-directory get
|
||||
dup home = [ drop "~" ] [ file-name ] if
|
||||
" " real-user-name "$ >> "
|
||||
] "" append-outputs-as ;
|
||||
|
||||
: echo-prompt ( -- )
|
||||
osx-bash-prompt write flush ;
|
||||
|
||||
SYMBOL: shell-last-exit
|
||||
|
||||
GENERIC: handle-repl-error ( obj -- )
|
||||
M: unknown-command handle-repl-error
|
||||
cmd>> ": command not found" append print ;
|
||||
|
||||
M: process-failed handle-repl-error
|
||||
process>> status>> shell-last-exit set ;
|
||||
|
||||
: factsh-repl ( -- )
|
||||
! [ "hello SIGUSR1" print flush ] SIGUSR1 add-signal-handler
|
||||
[ "hello SIGINT" print flush ] SIGINT add-signal-handler
|
||||
[ "hello SIGSTOP" print flush ] SIGSTOP add-signal-handler
|
||||
[ "hello SIGQUIT" print flush ] SIGQUIT add-signal-handler
|
||||
[ "hello SIGHUP" print flush ] SIGHUP add-signal-handler
|
||||
[ "hello SIGTERM" print flush ] SIGTERM add-signal-handler
|
||||
[ "hello SIGHUP" print flush ] SIGHUP add-signal-handler
|
||||
|
||||
f exit-shell? [
|
||||
current-directory previous-directory transfer
|
||||
[
|
||||
[ echo-prompt readln [ eval-factsh [ write ] when* ] [ nl t exit-shell? set ] if* ]
|
||||
[ handle-repl-error ] recover
|
||||
exit-shell? get not
|
||||
] loop
|
||||
] with-variable ;
|
||||
|
||||
MAIN: factsh-repl
|
||||
! PYTHON[[ print("hi")]] execute-string
|
||||
! RUBY[[ printf('hello')]] execute-string
|
||||
! FACTOR[[ USE: io "hi" print ]] execute-string
|
||||
|
||||
|
||||
! stty -a
|
||||
! ps ax -O tpgid
|
||||
! http://unix.stackexchange.com/questions/149741/why-is-sigint-not-propagated-to-child-process-when-sent-to-its-parent-process
|
||||
|
||||
Loading…
Reference in New Issue