forked from pmichaud/pmtcl
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Have a single file for each tcl builtin.
(splits up control.pm, list.pm, and main.pm in the commands dir)
- Loading branch information
Showing
60 changed files
with
1,275 additions
and
418 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,7 @@ | ||
| our sub after(*@args) { | ||
| if +@args < 1 { | ||
| error('wrong # args: should be "after option ?arg arg ...?"') | ||
| } | ||
| pir::sleep__vN(+@args[0] / 1000); | ||
| ''; | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,30 @@ | ||
| our sub append(*@args) { | ||
| if +@args < 1 { | ||
| error('wrong # args: should be "append varName ?value value ...?"'); | ||
| } | ||
|
|
||
| my $varName := @args.shift; | ||
|
|
||
| my $var; | ||
|
|
||
| # XXX bug compatibility - tcl errors if the var doesn't exist and there | ||
| # is nothing to append. See test file for ticket #. | ||
|
|
||
| if !+@args { | ||
| $var := set($varName); | ||
| } else { | ||
| $var := Q:PIR { | ||
| .local pmc varname, lexpad | ||
| varname = find_lex '$varName' | ||
| lexpad = find_dynamic_lex '%LEXPAD' | ||
| %r = vivify lexpad, varname, ['TclString'] | ||
| }; | ||
| } | ||
| my $result := set($varName); | ||
| while @args { | ||
| $result := ~$result ~ @args.shift; | ||
| } | ||
|
|
||
| set($varName, $result); | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,6 @@ | ||
| our sub apply(*@args) { | ||
| if +@args == 0 { | ||
| error('wrong # args: should be "apply lambdaExpr ?arg1 arg2 ...?"'); | ||
| } | ||
| ''; | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,23 @@ | ||
| our sub binary(*@args) { | ||
| error('wrong # args: should be "binary option ?arg arg ...?"') | ||
| if !+@args; | ||
|
|
||
| my $subcommand := @args.shift(); | ||
| if $subcommand eq 'format' { | ||
| if +@args < 1 { | ||
| error('wrong # args: should be "binary format formatString ?arg arg ...?"'); | ||
| } | ||
| } elsif $subcommand eq 'scan' { | ||
| if +@args < 2 { | ||
| error('wrong # args: should be "binary scan value formatString ?varName varName ...?"'); | ||
| } | ||
| my $value := @args.shift(); | ||
| my $formatString := @args.shift(); | ||
| for @args -> $varName { | ||
| set($varName, ''); # XXX placeholder | ||
| } | ||
| } else { | ||
| error("bad option \"$subcommand\": must be format or scan"); | ||
| } | ||
| ''; | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,14 @@ | ||
| ## use bare block to avoid catching control exceptions | ||
|
|
||
| INIT { | ||
| GLOBAL::break := -> *@args { | ||
| if +@args { | ||
| error('wrong # args: should be "break"'); | ||
| } | ||
| my $exception := pir::new__ps('Exception'); | ||
| $exception<type> := 65; # TCL_BREAK / CONTROL_LOOP_LAST | ||
| pir::throw($exception); | ||
| } | ||
| } | ||
|
|
||
| # vim: filetype=perl6: |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,36 @@ | ||
| our sub catch(*@args) { | ||
| if +@args < 1 || +@args > 2 { | ||
| error('wrong # args: should be "catch script ?resultVarName? ?optionVarName?"'); | ||
| } | ||
| my $code := @args[0]; | ||
|
|
||
| my $retval := 0; # TCL_OK | ||
| my $result; | ||
| try { | ||
| $result := Partcl::Compiler.eval($code); | ||
| CATCH { | ||
| $retval := 1; # TCL_ERROR | ||
| $result := $!<message>; | ||
| } | ||
| CONTROL { | ||
| my $parrot_type := $!<type>; | ||
|
|
||
| # XXX using numeric type ids is fragile. | ||
| if $parrot_type == 57 { # CONTROL_RETURN | ||
| $retval := 2; # TCL_RETURN | ||
| } elsif $parrot_type == 65 { # CONTROL_LOOP_LAST | ||
| $retval := 3; # TCL_BREAK | ||
| } elsif $parrot_type == 64 { # CONTROL_LOOP_NEXT | ||
| $retval := 4; # TCL_CONTINUE | ||
| } else { | ||
| # This isn't a standard tcl control type. Give up. | ||
| pir::rethrow($!); | ||
| } | ||
| $result := $!<message>; | ||
| } | ||
| }; | ||
| if +@args == 2 { | ||
| set(@args[1], $result); | ||
| } | ||
| $retval; | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,14 @@ | ||
| # TODO: implement ~user syntax | ||
| our sub cd(*@args) { | ||
| if +@args > 1 { | ||
| error('wrong # args: should be "cd ?dirName?"'); | ||
| } | ||
| my $dir; | ||
| if @args == 1 { | ||
| $dir := @args[0]; | ||
| } else { | ||
| $dir := pir::new__ps('Env')<HOME>; | ||
| } | ||
| my $OS := pir::new__ps('OS'); | ||
| $OS.chdir($dir); | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,7 @@ | ||
| our sub concat(*@args) { | ||
| my $result := @args ?? String::trim(@args.shift) !! ''; | ||
| while @args { | ||
| $result := $result ~ ' ' ~ String::trim(@args.shift); | ||
| } | ||
| $result; | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,11 @@ | ||
| ## use bare block to avoid catching control exceptions | ||
|
|
||
| INIT { | ||
| GLOBAL::continue := -> $message = '' { | ||
| my $exception := pir::new__ps('Exception'); | ||
| $exception<type> := 64; # TCL_CONTINUE / CONTROL_LOOP_NEXT | ||
| pir::throw($exception); | ||
| } | ||
| } | ||
|
|
||
| # vim: filetype=perl6: |
This file was deleted.
Oops, something went wrong.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,7 @@ | ||
| our sub eof(*@args) { | ||
| if +@args != 1 { | ||
| error('wrong # args: should be "eof channelId"') | ||
| } | ||
| my $chan := _getChannel(@args[0]); | ||
| 0; | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,27 @@ | ||
| ## use bare block to avoid catching control exceptions | ||
|
|
||
| INIT { | ||
| GLOBAL::error := -> *@args { | ||
| my $message := ''; | ||
| if +@args < 1 || +@args > 3 { | ||
| $message := 'wrong # args: should be "error message ?errorInfo? ?errorCode?"'; | ||
| } else { | ||
| $message := @args[0]; | ||
| } | ||
|
|
||
| if +@args >= 2 { | ||
| our %GLOBALS; | ||
| %GLOBALS<errorInfo> := @args[1]; | ||
| my $errorCode := @args[2] // 'NONE'; | ||
| %GLOBALS<errorCode> := $errorCode; | ||
| } | ||
|
|
||
| my $exception := pir::new__ps('Exception'); | ||
| # use EXCEPTION_SYNTAX_ERROR - just a generic type | ||
| $exception<type> := 55; | ||
| $exception<message> := $message; | ||
| pir::throw($exception); | ||
| } | ||
| } | ||
|
|
||
| # vim: filetype=perl6: |
Oops, something went wrong.