Author: smash
Date: Mon Feb 12 07:02:53 2007
New Revision: 16950
Modified:
trunk/languages/tcl/runtime/builtin/file.pir
trunk/languages/tcl/runtime/tcllib.pir
trunk/languages/tcl/t/cmd_file.t
Log:
[tcl]
* added PMC with directory separator (from parrot config) into _tcl namespace
* implement [file rootname], closes RT#40728
+ added simple tests for [file rootname]
* pull directory separator from parrot config in [file join], closes RT#40730
Modified: trunk/languages/tcl/runtime/builtin/file.pir
==============================================================================
--- trunk/languages/tcl/runtime/builtin/file.pir (original)
+++ trunk/languages/tcl/runtime/builtin/file.pir Mon Feb 12 07:02:53 2007
@@ -85,7 +85,8 @@
if argc == 0 goto bad_args
.local string dirsep
- dirsep = '/' # RT#40730: should pull from parrot config.
+ $P1 = get_root_global ['_tcl'], 'slash'
+ dirsep = $P1
.local string result
result = ''
@@ -463,10 +464,36 @@
.return(0)
.end
-# RT#40728: Stub for test parsing
.sub 'rootname'
- .param pmc argv
- .return(0)
+ .param pmc argv
+ .local int argc
+
+ argc = elements argv
+ if argc != 1 goto bad_args
+
+ .local string filename
+ filename = argv[0]
+
+ $P0 = split '.', filename
+ $I0 = elements $P0
+ if $I0 == 1 goto done
+ $S0 = pop $P0
+
+ .local string separator
+ $P1 = get_root_global ['_tcl'], 'slash'
+ separator = $P1
+
+ $I0 = index $S0, separator
+ if $I0 != -1 goto done
+
+ join $S0, '.', $P0
+ .return($S0)
+
+done:
+ .return(filename)
+
+ bad_args:
+ tcl_error 'wrong # args: should be "file rootname name"'
.end
.sub 'extension'
Modified: trunk/languages/tcl/runtime/tcllib.pir
==============================================================================
--- trunk/languages/tcl/runtime/tcllib.pir (original)
+++ trunk/languages/tcl/runtime/tcllib.pir Mon Feb 12 07:02:53 2007
@@ -274,6 +274,8 @@
.local string slash
slash = $P1['slash']
+ $P2 = $P1['slash']
+ set_root_global ['_tcl'], 'slash', $P2
.local pmc tcl_library
tcl_library = get_global '$tcl_library'
Modified: trunk/languages/tcl/t/cmd_file.t
==============================================================================
--- trunk/languages/tcl/t/cmd_file.t (original)
+++ trunk/languages/tcl/t/cmd_file.t Mon Feb 12 07:02:53 2007
@@ -8,20 +8,38 @@
source lib/test_more.tcl
-plan 4
+plan 9
# [file exists]
eval_is {file exists} \
{wrong # args: should be "file exists name"} \
- {too few args}
+ {[file exists] too few args}
eval_is {file exists foo bar} \
{wrong # args: should be "file exists name"} \
- {too many args}
+ {[file exists] too many args}
# this should fail everywhere
-is [file exists :%:/bar] 0 {does not exist}
+is [file exists :%:/bar] 0 {[file exists] does not exist}
# we really should create a file to test this, but since our "source" line
# above means we have to have that path to this file..
-is [file exists lib/test_more.tcl] 1 {does exist}
+is [file exists lib/test_more.tcl] 1 {[file exists] does exist}
+
+# [file rootname]
+eval_is {file rootname} \
+ {wrong # args: should be "file rootname name"} \
+ {[file rootname] too few args}
+eval_is {file rootname foo bar} \
+ {wrong # args: should be "file rootname name"} \
+ {[file rootname] too many args}
+eval_is {file rootname file} \
+ {file} \
+ {[file rootname] filename only}
+eval_is {file rootname file.ext} \
+ {file} \
+ {[file rootname] filename with extension}
+eval_is {file rootname f..i.le.ext} \
+ {f..i.le} \
+ {[file rootname] filename with dots and extension}
+
