Richard Suchenwirth 2002-10-01 - COBOL (COmmon Business-Oriented Language) is another of the ancient programming languages (FORTRAN and LISP were slightly earlier), first defined in 1960 [
1]. It still lives, though - legacy apps seem to be too expensive to rewrite... Reading a 25-year old book on COBOL, I mostly felt pity for the folks back then. Things are so much easier today, especially with Tcl ;-) Compare their
ADD 1 TO I
against our
incr i
Hmm.. Somehow Tcl has some COBOL heritage, in being wordier than C's
i++, and closer to English (but not as close as COBOL was)..
There's one feature I noticed in PICTURE clauses in the DATA DIVISION that Tcl's
format doesn't offer: leading asterisks for numbers, to prevent fraud e.g. on checks. This prompted me to try a partial reimplementation of PICTURE constraints, which in contrast to COBOL's organization just puts a string in a "picture" if possible, and otherwise raises an error. Like so often, I'm not sure how useful this is - but it was a nice little evening challenge (especially the beastly
regsub/
subst combination to resolve multipliers like X(5) to XXXXX, which I thought of when I awoke the next morning)... See the cases in the
test suite below for how far I got in this emulation. Again, I put the tests before the implementation, as a reminder that tests should be defined early.
proc test:picture {} {
set failed 0
foreach {input expected} {
{picture ****9.99 12.34} ***12.34
{picture ****9.99 .12} ****0.12
{picture ****9.99 12345.67} 12345.67
{picture 9999.99 12.34} 0012.34
{picture 9(4).9(2) 12.34} 0012.34
{picture ZZZ9.99 0012.34} " 12.34"
{picture 9.99 12.34} error
{picture 9.99 .34} 0.34
{picture 99AA99 12CD56} 12CD56
{picture 99AA99 1234EF} error
{picture XXXXXX 12CD56} 12CD56
{picture X(6) 12CD56} 12CD56
{picture AAAA BCDE} BCDE
{picture AAAA AB34} error
} {
set err [catch $input res]
if {[string compare $res $expected] && !$err && $expected!="error"} {
append res " - expected: $expected"
incr failed
}
puts [list $input -> $res]
}
puts [expr {$failed? "failed $failed test(s)" : "passed all tests"}]
}
proc picture {picture value} {
set re {((.)\(([0-9]+)\))}
if [regsub -all $re $picture {[string repeat \2 \3]} t] {
set picture [subst $t] ;# turn e.g. A(3)X(2) to AAAXX
}
set length [string length $picture]
set fvalue [format %${length}s $value]
if {[string length $fvalue]>$length} {
error [list value $value does not fit in picture $picture]
}
set res ""
foreach p [split $picture ""] v [split $fvalue ""] {
append sofar $v
set error 0
switch -regexp -- $v {
" " {
if {$p=="*" && ![llength $sofar]} {set v *}
if {$p=="9" && ![llength $sofar] && $sofar!=0} {set v 0}
}
0 {if {$p=="Z" && !$sofar} {set v " "}}
[1-9] {if {$p!="X" && $p!="9" && $p!="*"} {incr error}}
[^0-9.] {if {$p!="X" && $p!="A"} {incr error}}
{[^A-Z .]} {if {$p!="X"} {incr error}}
}
if $error {error [list $v in $value doesn't match $p in $picture]}
append res $v
}
set res
}
test:picture
# But the task of left-padding a string can also be had in a one-liner:
proc padchars {s char n} {
return [string repeat $char [expr {$n-[string length $s]}]]$s
}
puts [padchars 12.34 * 8] ;#-> ***12.34This has the added advantage that you can freely choose the pad character - and is another example for how the same task can be done with considerable effort, or just a one-liner ;-) The other features of
picture above can mostly be solved with a good
regexp or two.
