Playing COBOL

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 [L1 ]. 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


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
# 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.34

This 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.