Changeset 1042
- Timestamp:
- Jun 10, 2008, 6:52:04 PM (16 years ago)
- Location:
- trunk/lang/tcl
- Files:
-
- 13 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/lang/tcl/scripts/library.tcl
r1018 r1042 347 347 } 348 348 set node [$node parentNode] 349 if {$node == ""} { 350 return "" 351 } 349 352 350 353 switch -- $params(-as) { … … 453 456 } 454 457 default { 455 error "bad flavor \"$params(-as)\": should be component, id, object, type"458 error "bad flavor \"$params(-as)\": should be component, id, object, path, type" 456 459 } 457 460 } … … 502 505 } 503 506 if {$params(-decode) == "yes"} { 504 return [Rappture::encoding::decode [string trim [$node text]]]507 return [Rappture::encoding::decode -- [string trim [$node text]]] 505 508 } else { 506 509 return [string trim [$node text]] … … 543 546 } 544 547 } 545 if {[llength $args] > 2} {548 if {[llength $args] < 1 || [llength $args] > 2} { 546 549 error "wrong # args: should be \"put ?-append bval? ?-id num? ?-type string|file? ?-compress bval? ?path? string\"" 547 550 } … … 563 566 564 567 if {$params(-compress) || [Rappture::encoding::is binary $str]} { 565 set str [Rappture::encoding::encode $str]568 set str [Rappture::encoding::encode -- $str] 566 569 } 567 570 -
trunk/lang/tcl/src/RpEncodeTclInterface.cc
r1018 r1042 137 137 138 138 // parse through command line options 139 if ( (objc <= 2) && (objc >= 5)) {139 if (objc < 1) { 140 140 Tcl_AppendResult(interp, 141 141 "wrong # args: should be \"", cmdName, 142 " ?-as z|b64|zb64? ?-no-header? <string>\"", (char*)NULL);142 " ?-as z|b64|zb64? ?-no-header? ?--? <string>\"", (char*)NULL); 143 143 return TCL_ERROR; 144 144 } … … 185 185 addHeader = 0; 186 186 } 187 else if ( strcmp(option,"--") == 0 ) { 188 nextarg++; 189 break; 190 } 187 191 else { 188 break; 192 Tcl_AppendResult(interp, 193 "bad option \"", option, 194 "\": should be -as, -no-header, --", (char*)NULL); 195 return TCL_ERROR; 189 196 } 190 197 } … … 197 204 Tcl_AppendResult(interp, 198 205 "wrong # args: should be \"", cmdName, 199 " ?-as z|b64|zb64? ?-no-header? <string>\"", (char*)NULL);206 " ?-as z|b64|zb64? ?-no-header? ?--? <string>\"", (char*)NULL); 200 207 return TCL_ERROR; 201 208 } … … 269 276 270 277 // parse through command line options 271 if ( (objc != 2) && (objc != 4)) {278 if (objc < 1) { 272 279 Tcl_AppendResult(interp, 273 280 "wrong # args: should be \"", cmdName, 274 " ?-as z|b64|zb64? <string>\"", (char*)NULL); 275 return TCL_ERROR; 276 } 277 278 option = Tcl_GetStringFromObj(objv[nextarg], &optionLen); 279 if (*option == '-') { 280 if ( strncmp(option,"-as",optionLen) == 0 ) { 281 nextarg++; 282 typeLen = 0; 283 if (nextarg < objc) { 284 encodeType = Tcl_GetStringFromObj(objv[nextarg],&typeLen); 285 nextarg++; 286 } 287 if ( (typeLen == 1) && 288 (strncmp(encodeType,"z",typeLen) == 0) ) { 289 decompress = 1; 290 base64 = 0; 291 } 292 else if ( (typeLen == 3) && 293 (strncmp(encodeType,"b64",typeLen) == 0) ) { 294 decompress = 0; 295 base64 = 1; 296 } 297 else if ( (typeLen == 4) && 298 (strncmp(encodeType,"zb64",typeLen) == 0) ) { 299 decompress = 1; 300 base64 = 1; 301 } 302 else { 303 // user did not specify recognized wishes for this option, 304 Tcl_AppendResult(interp, "bad value \"",(char*)NULL); 305 if (encodeType != NULL) { 306 Tcl_AppendResult(interp, encodeType,(char*)NULL); 307 } 281 " ?-as z|b64|zb64? ?--? <string>\"", (char*)NULL); 282 return TCL_ERROR; 283 } 284 285 while ((objc - nextarg) > 0) { 286 option = Tcl_GetStringFromObj(objv[nextarg], &optionLen); 287 if (*option == '-') { 288 if ( strncmp(option,"-as",optionLen) == 0 ) { 289 nextarg++; 290 typeLen = 0; 291 if (nextarg < objc) { 292 encodeType = Tcl_GetStringFromObj(objv[nextarg],&typeLen); 293 nextarg++; 294 } 295 if ( (typeLen == 1) && 296 (strncmp(encodeType,"z",typeLen) == 0) ) { 297 decompress = 1; 298 base64 = 0; 299 } 300 else if ( (typeLen == 3) && 301 (strncmp(encodeType,"b64",typeLen) == 0) ) { 302 decompress = 0; 303 base64 = 1; 304 } 305 else if ( (typeLen == 4) && 306 (strncmp(encodeType,"zb64",typeLen) == 0) ) { 307 decompress = 1; 308 base64 = 1; 309 } 310 else { 311 // user did not specify recognized wishes for this option, 312 Tcl_AppendResult(interp, "bad value \"",(char*)NULL); 313 if (encodeType != NULL) { 314 Tcl_AppendResult(interp, encodeType,(char*)NULL); 315 } 316 Tcl_AppendResult(interp, 317 "\": should be one of z, b64, zb64", 318 (char*)NULL); 319 return TCL_ERROR; 320 } 321 } else if ( strcmp(option,"--") == 0 ) { 322 nextarg++; 323 break; 324 } else { 308 325 Tcl_AppendResult(interp, 309 "\": should be one of z, b64, zb64",310 326 "bad option \"", option, 327 "\": should be -as, --", (char*)NULL); 311 328 return TCL_ERROR; 312 329 } 330 } else { 331 break; 313 332 } 314 333 } … … 317 336 Tcl_AppendResult(interp, 318 337 "wrong # args: should be \"", cmdName, 319 " ?-as z|b64|zb64? <string>\"", (char*)NULL);338 " ?-as z|b64|zb64? ?--? <string>\"", (char*)NULL); 320 339 return TCL_ERROR; 321 340 } -
trunk/lang/tcl/tests/children.test
r424 r1042 41 41 list [catch {$lib children "input.number(min)" "wreew"} msg] $msg 42 42 } {1 {wrong # args: should be "children ?-as fval? ?-type name? ?path?"}} 43 # this test works for tcl version of rappture, different error message 44 #test library-8.3.1.1 {children command path -as flag no option} { 45 # list [catch {$lib children -as} msg] $msg 46 #} {1 {bad path component "-as"}} 47 test library-8.3.1.2 {children command path -as flag no option} { 43 test library-8.3.1 {children command path -as flag no option} { 48 44 list [catch {$lib children -as} msg] $msg 49 } {1 {bad flavor "" for -as: should be component, id, object, path, type}}45 } {1 {bad path component "-as"}} 50 46 test library-8.3.2 {children command path -as flag component path} { 51 47 $lib children -as component "input" … … 63 59 $lib children -as object "input" 64 60 } {::libraryObj1 ::libraryObj2 ::libraryObj3 ::libraryObj4} 65 # this test works for old tcl bindings, different error message66 #test library-8.3.7 {children command path -as junk type path} {67 # list [catch {$lib children -as junk "input"} msg] $msg68 #} {1 {bad flavor "junk": should be component, id, object, path, type}}69 # this test works for new tcl bindings, different error message70 61 test library-8.3.7 {children command path -as junk type path} { 71 62 list [catch {$lib children -as junk "input"} msg] $msg 72 } {1 {bad flavor "junk" for -as: should be component, id, object, path, type}}63 } {1 {bad flavor "junk": should be component, id, object, path, type}} 73 64 test library-8.4.1 {children command path -type number path} { 74 65 $lib children -type "number" "input" -
trunk/lang/tcl/tests/copy.test
r424 r1042 26 26 catch {unset lib} 27 27 set lib [Rappture::library rplib_test.xml] 28 # this test works for old tcl bindings, different error message 29 #test library-9.0.1.1 {copy command, 0 args} { 30 # list [catch {$lib copy} msg] $msg 31 #} {1 {wrong # args: should be "libraryObj0 copy path from ?arg arg ...?"}} 32 # this test works for new tcl bindings, different error message 33 test library-9.0.1.2 {copy command, 0 args} { 28 test library-9.0.1.1 {copy command, 0 args} { 34 29 list [catch {$lib copy} msg] $msg 35 } {1 {wrong # args: should be "::libraryObj0 copy path from ?xmlobj? path"}} 36 # this test works for old tcl bindings, different error message 37 #test library-9.0.2.1 {copy command, 0 args} { 38 # list [catch {$lib copy "input.number(min)"} msg] $msg 39 #} {1 {wrong # args: should be "libraryObj0 copy path from ?arg arg ...?"}} 40 # this test works for new tcl bindings, different error message 41 test library-9.0.2.2 {copy command, 0 args} { 30 } {1 {wrong # args: should be "libraryObj0 copy path from ?arg arg ...?"}} 31 test library-9.0.2.1 {copy command, 0 args} { 42 32 list [catch {$lib copy "input.number(min)"} msg] $msg 43 } {1 {wrong # args: should be "::libraryObj0 copy path from ?xmlobj? path"}} 44 # this test works for old tcl bindings, different error message 45 #test library-9.0.3.1 {copy command, 1 arg} { 46 # list [catch {$lib copy "input.number(min)" from } msg] $msg 47 #} {1 {wrong # args: should be "copy path from ?xmlobj? path"}} 48 # this test works for new tcl bindings, different error message 49 test library-9.0.3.2 {copy command, 1 arg} { 33 } {1 {wrong # args: should be "libraryObj0 copy path from ?arg arg ...?"}} 34 test library-9.0.3.1 {copy command, 1 arg} { 50 35 list [catch {$lib copy "input.number(min)" from } msg] $msg 51 } {1 {wrong # args: should be "::libraryObj0 copy path from ?xmlobj? path"}} 52 # this test works for old tcl bindings 53 # does not work for new tcl bindings because the bad paths are not 54 # discovered in the binding, but in the core copy function and 55 # currently errors from the core functions are not relayed to 56 # the bindings. 57 #test library-9.0.4 {copy command not enough arg} { 58 # list [catch {$lib copy "input.number(min)" from $lib} msg] $msg 59 #} {1 {bad path component "::libraryObj0"}} 60 # this test works for old tcl bindings, different error message 61 #test library-9.0.5.1 {copy command not enough arg} { 62 # list [catch {$lib copy "input.number(min)" from } msg] $msg 63 #} {1 {wrong # args: should be "copy path from ?xmlobj? path"}} 64 test library-9.0.5.2 {copy command not enough arg} { 36 } {1 {wrong # args: should be "copy path from ?xmlobj? path"}} 37 test library-9.0.4 {copy command not enough arg} { 38 list [catch {$lib copy "input.number(min)" from $lib} msg] $msg 39 } {1 {bad path component "::libraryObj0"}} 40 test library-9.0.5.1 {copy command not enough arg} { 65 41 list [catch {$lib copy "input.number(min)" from } msg] $msg 66 } {1 {wrong # args: should be " ::libraryObj0copy path from ?xmlobj? path"}}42 } {1 {wrong # args: should be "copy path from ?xmlobj? path"}} 67 43 test library-9.1.1 {copy command, bad syntax, switched from -> junk} { 68 44 list [catch {$lib copy "input.number(blah)" junk "input.number(min)"} msg] $msg -
trunk/lang/tcl/tests/diff.test
r444 r1042 34 34 set libFromGet [$libDefault element -as object "input.number(max)"] 35 35 36 # this test works for old tcl bindings, different error message 37 #test library-10.0.1.1 {diff command, no arguments} { 38 # list [catch {$lib diff} msg] $msg 39 #} {1 {wrong # args: should be "libraryObj0 diff libobj"}} 40 # this test works for new tcl bindings, different error message 41 test library-10.0.1.2 {diff command, no arguments} { 36 test library-10.0.1.1 {diff command, no arguments} { 42 37 list [catch {$lib diff} msg] $msg 43 } {1 {wrong # args: should be " ::libraryObj0 diff xmlobj"}}38 } {1 {wrong # args: should be "libraryObj0 diff libobj"}} 44 39 test library-10.1.1 {diff command, one argument, no difference} { 45 40 $lib diff $libnew … … 67 62 test library-10.3.1 {diff command, two arguments, returns error} { 68 63 list [catch {$lib diff $libnew $libnew} msg] $msg 69 } {1 {wrong # args: should be " ::libraryObj0 diff xmlobj"}}64 } {1 {wrong # args: should be "libraryObj0 diff libobj"}} 70 65 test library-10.3.2 {diff command, bad second arg, returns error} { 71 66 list [catch {$lib diff slfd} msg] $msg -
trunk/lang/tcl/tests/element.test
r424 r1042 41 41 list [catch {$lib element "input.number(min)" "wreew"} msg] $msg 42 42 } {1 {wrong # args: should be "element ?-as fval? ?path?"}} 43 # this test works for old tcl bindings, different error message 44 #test library-5.3.1.1 {element command path -as flag no option} { 45 # list [catch {$lib element -as} msg] $msg 46 #} {1 {bad path component "-as"}} 47 # this test works for new tcl bindings, different error message 48 test library-5.3.1.2 {element command path -as flag no option} { 43 test library-5.3.1.1 {element command path -as flag no option} { 49 44 list [catch {$lib element -as} msg] $msg 50 } {1 {bad flavor "" for -as: should be component, id, object, path, type}}45 } {1 {bad path component "-as"}} 51 46 test library-5.3.2 {element command path -as component, path with id} { 52 47 $lib element -as component "input.number(max)" … … 65 60 list [catch {$ele isa ::Rappture::LibraryObj} msg] $msg 66 61 } {0 1} 67 # this test works for old tcl bindings, different error message 68 #test library-5.3.7.1 {element command path -as junk, path with id} { 69 # list [catch {$lib element -as junk "input.number(max)"} msg] $msg 70 #} {1 {bad flavor "junk": should be component, id, object, path, type}} 71 # this test works for new tcl bindings, different error message 72 test library-5.3.7.2 {element command path -as junk, path with id} { 62 test library-5.3.7.1 {element command path -as junk, path with id} { 73 63 list [catch {$lib element -as junk "input.number(max)"} msg] $msg 74 } {1 {bad flavor "junk" for -as: should be component, id, object, path, type}}64 } {1 {bad flavor "junk": should be component, id, object, path, type}} 75 65 test library-5.3.8 {element command path -as component, path does not exist} { 76 66 $lib element -as component "input.test(we)" -
trunk/lang/tcl/tests/encode.test
r725 r1042 65 65 test encode-2.0.0 {Rappture::encoding::encode, 0 arguments} { 66 66 list [catch {Rappture::encoding::encode} msg] $msg 67 } {1 {wrong # args: should be "Rappture::encoding::encode ?-as z|b64|zb64? ?-no-header? <string>"}}67 } {1 {wrong # args: should be "Rappture::encoding::encode ?-as z|b64|zb64? ?-no-header? ?--? <string>"}} 68 68 69 69 test encode-2.1.0 {Rappture::encoding::encode, ascii string argument} { … … 91 91 test encode-2.2.2 {Rappture::encoding::encode, -as flag correct value z} { 92 92 list [catch {Rappture::encoding::encode -as z} msg] $msg 93 } {1 {wrong # args: should be "Rappture::encoding::encode ?-as z|b64|zb64? ?-no-header? <string>"}}93 } {1 {wrong # args: should be "Rappture::encoding::encode ?-as z|b64|zb64? ?-no-header? ?--? <string>"}} 94 94 95 95 test encode-2.2.3 {Rappture::encoding::encode, -as z w/ string} { … … 103 103 }} 104 104 105 test encode-2.2.5 {Rappture::encoding::encode with --} { 106 list [catch {Rappture::encoding::encode -hi} msg] $msg 107 } {1 {bad option "-hi": should be -as, -no-header, --}} 108 109 test encode-2.2.6 {Rappture::encoding::encode with --} { 110 list [catch {Rappture::encoding::encode -- -hi} msg] $msg 111 } {0 {@@RP-ENC:zb64 112 H4sIAAAAAAAAA9PNyAQA8jSeVgMAAAA= 113 }} 114 105 115 #---------------------------------------------------------- 106 116 #---------------------------------------------------------- … … 111 121 test decode-3.0.0 {Rappture::encoding::decode, 0 arguments} { 112 122 list [catch {Rappture::encoding::decode} msg] $msg 113 } {1 {wrong # args: should be "Rappture::encoding::decode ?-as z|b64|zb64? <string>"}}123 } {1 {wrong # args: should be "Rappture::encoding::decode ?-as z|b64|zb64? ?--? <string>"}} 114 124 115 125 test decode-3.1.0 {Rappture::encoding::decode, 1 arg, b64 encoded} { … … 125 135 test decode-3.1.2 {Rappture::encoding::decode, 2 args} { 126 136 list [catch {Rappture::encoding::decode "hi" "bye"} msg] $msg 127 } {1 {wrong # args: should be "Rappture::encoding::decode ?-as z|b64|zb64? <string>"}}137 } {1 {wrong # args: should be "Rappture::encoding::decode ?-as z|b64|zb64? ?--? <string>"}} 128 138 129 139 test decode-3.2.0 {Rappture::encoding::decode, -as flag, no value} { … … 133 143 test decode-3.2.1 {Rappture::encoding::decode, -as flag, bad value} { 134 144 list [catch {Rappture::encoding::decode -as zz} msg] $msg 135 } {1 { wrong # args: should be "Rappture::encoding::decode ?-as z|b64|zb64? <string>"}}145 } {1 {bad value "zz": should be one of z, b64, zb64}} 136 146 137 147 test decode-3.2.2 {Rappture::encoding::decode, -as flag, zb64 w/ string} { … … 151 161 } {This is a test} 152 162 163 test encode-3.2.5 {Rappture::encoding::decode with --} { 164 list [catch {Rappture::encoding::decode -hi} msg] $msg 165 } {1 {bad option "-hi": should be -as, --}} 166 167 test encode-3.2.6 {Rappture::encoding::decode with --} { 168 list [catch {Rappture::encoding::decode -- -hi} msg] $msg 169 } {0 -hi} 170 153 171 154 172 ::tcltest::cleanupTests -
trunk/lang/tcl/tests/get.test
r424 r1042 31 31 test get-1.0.2 {get command, two arguments } { 32 32 list [ catch {$lib get "input.number(min).default" "ggg"} msg] $msg 33 } {1 {wrong # args: should be " ::libraryObj0 get?path?"}}33 } {1 {wrong # args: should be "get ?-decode yes? ?path?"}} 34 34 #---------------------------------------------------------- 35 35 test get-1.1 {get command valid path} { -
trunk/lang/tcl/tests/isa.test
r424 r1042 21 21 set lib [Rappture::library rplib_test.xml] 22 22 23 itcl::class foo { # used for tests below } 24 23 25 #---------------------------------------------------------- 24 26 # isa command … … 27 29 test library-7.0.1 {isa command 0 arg} { 28 30 list [catch {$lib isa} msg] $msg 29 } {1 {wrong # args: should be " ::libraryObj0 isa objType"}}31 } {1 {wrong # args: should be "object isa className"}} 30 32 test library-7.1.1 {isa command 1 valid arg} { 31 33 $lib isa ::Rappture::LibraryObj 32 34 } {1} 33 35 test library-7.1.2 {isa command 1 invalid arg} { 34 $lib isa :: Rappture::Curve36 $lib isa ::foo 35 37 } {0} 36 38 test library-7.1.3 {isa command 1 invalid arg} { 37 $lib isa sdfsdf38 } { 0}39 list [catch {$lib isa sdfsdf} result] $result 40 } {1 {class "sdfsdf" not found in context "::Rappture::LibraryObj"}} 39 41 test library-7.2.1 {isa command 2 args} { 40 42 list [catch {$lib isa ::Rappture::LibraryObj ::Rappture::LibraryObj} msg] $msg 41 } {1 {wrong # args: should be " ::libraryObj0 isa objType"}}43 } {1 {wrong # args: should be "object isa className"}} 42 44 43 45 -
trunk/lang/tcl/tests/parent.test
r424 r1042 40 40 test library-6.2.1 {parent command path 2 arg} { 41 41 list [catch {$lib parent "input.number(min)" "wreew"} msg] $msg 42 } {1 {wrong # args: should be "parent ?-as <fval>? ?<path>?"}}42 } {1 {wrong # args: should be "parent ?-as fval? ?path?"}} 43 43 test library-6.3.1 {parent command path -as flag no option} { 44 44 list [catch {$lib parent -as} msg] $msg 45 } {1 {bad flavor "" for -as: should be component, id, object, path, type}}45 } {1 {bad path component "-as"}} 46 46 test library-6.3.2 {parent command path -as flag component path with id} { 47 47 $lib parent -as component "input.number(max).default" -
trunk/lang/tcl/tests/put.test
r424 r1042 36 36 set libPut [Rappture::library rplib_test.xml] 37 37 list [catch {$libPut put} msg] $msg 38 } {1 {wrong # args: should be "put ?-append yes? ?-id num? ?<path>? <string>"}}38 } {1 {wrong # args: should be "put ?-append bval? ?-id num? ?-type string|file? ?-compress bval? ?path? string"}} 39 39 test library-4.1.1 {put command valid path 1 arg} { 40 40 catch {unset libPut} … … 95 95 # $libPut xml 96 96 } {1 {expected boolean value but got "input.test(withId)"}} 97 test library-4.2.4 {put command test append blank} {98 # catch {unset libPut}99 # set libPut [Rappture::library rplib_test.xml]100 list [catch {$libPut put -append} msg] $msg101 } {1 {expected boolean value but got ""}}102 97 test library-4.2.5 {put command test append junk} { 103 98 catch {unset libPut} … … 155 150 set libPut [Rappture::library rplib_test.xml] 156 151 list [catch {$libPut put "input.test" "val1" "val2"} msg] $msg 157 } {1 {wrong # args: should be "put ?-append yes? ?-id num? ?<path>? <string>"}}152 } {1 {wrong # args: should be "put ?-append bval? ?-id num? ?-type string|file? ?-compress bval? ?path? string"}} 158 153 159 154 -
trunk/lang/tcl/tests/remove.test
r403 r1042 28 28 test library-11.0.1 {remove command, 2 arguments} { 29 29 list [catch {$lib remove output junk} msg] $msg 30 } {1 {wrong # args: should be " ::libraryObj0 remove ?<path>?"}}30 } {1 {wrong # args: should be "libraryObj0 remove ?path?"}} 31 31 test library-11.1.1 {remove command, 1 argument, valid path} { 32 32 $lib remove output 33 33 $lib xml 34 } {<?xml version="1.0"?> 35 <run> 34 } {<run> 36 35 <tool> 37 36 <title>Graphing Calculator</title> -
trunk/lang/tcl/tests/xml.test
r403 r1042 30 30 set lib [Rappture::library rplib_test.xml] 31 31 set xmltext [$lib xml] 32 } {<?xml version="1.0"?> 33 <run> 32 } {<run> 34 33 <tool> 35 34 <title>Graphing Calculator</title> … … 83 82 set lib [Rappture::library rplib_test.xml] 84 83 list [catch {$lib xml "1moreArg"} msg] $msg 85 } {1 {wrong # args: should be " ::libraryObj1 xml"}}84 } {1 {wrong # args: should be "libraryObj1 xml"}} 86 85 87 86
Note: See TracChangeset
for help on using the changeset viewer.