512 lines
12 KiB
Tcl
512 lines
12 KiB
Tcl
#!/usr/local/bin/tclsh
|
||
#
|
||
# Report Generator for TinyCobol
|
||
#
|
||
|
||
set tex(fontsdef) {
|
||
\font\RomanEight=cmr8 scaled\magstep0
|
||
\font\RomanNine=cmr9 scaled\magstep0
|
||
\font\RomanTen=cmr10 scaled\magstep0
|
||
\font\RomanEleven=cmr10 scaled\magstep1
|
||
\font\RomanTwelve=cmr12 scaled\magstep0
|
||
\font\RomanThirteen=cmr12 scaled\magstep1
|
||
|
||
\font\RomanEightBold=cmbx8 scaled\magstep0
|
||
\font\RomanNineBold=cmbx9 scaled\magstep0
|
||
\font\RomanTenBold=cmbx10 scaled\magstep0
|
||
\font\RomanTwelveBold=cmbx12 scaled\magstep0
|
||
|
||
\font\TypewriterEight=cmtt8 scaled\magstep0
|
||
\font\TypewriterNine=cmtt9 scaled\magstep0
|
||
\font\TypewriterTen=cmtt10 scaled\magstep0
|
||
\font\TypewriterTwelve=cmtt12 scaled\magstep0
|
||
\font\TypewriterXL=cmtt12 scaled\magstep2
|
||
|
||
\font\SansserifEight=cmss8 scaled\magstep0
|
||
\font\SansserifNine=cmss9 scaled\magstep0
|
||
\font\SansserifTen=cmss10 scaled\magstep0
|
||
\font\SansserifTwelve=cmss12 scaled\magstep0
|
||
\font\SansserifSeventeen=cmss12 scaled\magstep2
|
||
|
||
\font\SansserifTenBold=cmssbx10 scaled\magstep0
|
||
|
||
\font\UltraCondL=cmssu30 scaled\magstep0
|
||
|
||
\font\RomanFibEight=cmfib8 scaled\magstep0
|
||
}
|
||
|
||
set tex(plainoutput) {
|
||
\setbox0=\vbox{\makeheadline}
|
||
%%Debug info: ht0: \number\ht0 vsize: \number\vsize
|
||
\advance\vsize by -\ht0
|
||
\def\plainoutput{\shipout\vbox{\makeheadline\pagebody}\advancepageno
|
||
\ifnum\outputpenalty >-20000\else\dosupereject\fi}
|
||
\def\pagebody{\vbox to\vsize{\boxmaxdepth=\maxdepth \pagecontents}}
|
||
}
|
||
|
||
set tex(prologue) {\
|
||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
%
|
||
% Report generated by reportGen.tcl
|
||
% Date: [clock format [clock seconds]]
|
||
%
|
||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
\\nopagenumbers
|
||
\\raggedbottom
|
||
\\overfullrule=0pt
|
||
\\parindent=0pt
|
||
|
||
%% Paper: portrait A4 no margins
|
||
%\\hsize=210mm
|
||
%\\vsize=297mm
|
||
\\hoffset=-1in
|
||
\\voffset=-1in
|
||
\\hsize=$rep(-page_width)$rep(unit)
|
||
\\vsize=$rep(-page_height)$rep(unit)
|
||
|
||
\\input epsf
|
||
\\input colordvi
|
||
\\input trans.tex
|
||
|
||
%\\def\\jumpsetbox{\\aftergroup\\aftersetbox}
|
||
%\\def\\rotate#1\{
|
||
% \\hbox\{
|
||
% \\def\\aftersetbox\{
|
||
% \\setbox\\boxtmp\\hbox\{\\box\\boxtmp\}
|
||
% \\wd\\boxtmp 0pt \\ht\\boxtmp 0pt \\dp\\boxtmp 0pt
|
||
% \\special\{ps: gsave currentpoint currentpoint
|
||
% translate #1 rotate neg exch neg exch translate\}
|
||
% \\box\\boxtmp
|
||
% \\special\{ps: grestore\}
|
||
% \}\}
|
||
% \\afterassignment\\jumpsetbox\\setbox\\boxtmp =
|
||
%\}
|
||
|
||
$tex(fontsdef)
|
||
\\def\\makeheadline{[dumphdr $rep(hdr,PAGE)]}
|
||
$tex(plainoutput)
|
||
}
|
||
|
||
# alternate comment (cobol-compatible)
|
||
proc * {args} {
|
||
uplevel #0 # $args
|
||
}
|
||
|
||
# read lines from layout file, separating copybook definitions
|
||
# and execute other statements as regular tcl commands
|
||
proc Copy {layout} {
|
||
set fldre {^[ \t]*([0-9]+)[ \t]+([a-zA-Z0-9-]*)[ \t]+pic[ \t]+(.*)\.}
|
||
set f [open $layout r]
|
||
while {![eof $f]} {
|
||
set line ""
|
||
while {1} {
|
||
gets $f ln
|
||
if {[string index $ln end] == "\\"} {
|
||
append line $ln\n
|
||
} else {
|
||
append line $ln
|
||
}
|
||
if {[info complete $line]} {
|
||
break
|
||
}
|
||
}
|
||
if {[regexp -nocase $fldre $line m level name pic]} {
|
||
definefield $level $name $pic
|
||
} else {
|
||
uplevel #0 $line
|
||
}
|
||
}
|
||
}
|
||
|
||
proc definefield {level name pic} {
|
||
global rep
|
||
### compute size of field from picture given
|
||
set n 0
|
||
set pic [string trim $pic]
|
||
while {$pic != ""} {
|
||
if {[string index $pic 1] == "("} {
|
||
set n1 [string first ")" $pic]
|
||
incr n [string range $pic 2 [expr $n1-1]]
|
||
set pic [string range $pic [expr $n1+1] end]
|
||
} else {
|
||
incr n
|
||
set pic [string range $pic 1 end]
|
||
}
|
||
}
|
||
lappend rep(fields) $name
|
||
set rep(size,$name) $n
|
||
set rep(offset,$name) $rep(offset)
|
||
incr rep(offset) $n
|
||
}
|
||
|
||
proc Header {item args} {
|
||
global rep
|
||
if {[lsearch $rep(break) $item] < 0} {
|
||
if {![regexp {PAGE[1-9]?} $item]} {
|
||
lappend rep(break) $item
|
||
}
|
||
}
|
||
array set hdr [list -line 0 -font SansserifTwelve -width $rep(-page_width) \
|
||
-before 0 -after 0 -align center -color Black -offset 0 -eject 0 \
|
||
-image {} -hrule 0 -rotate 0]
|
||
array set hdr $args
|
||
lappend rep(hdr,$item) [array get hdr]
|
||
set rep(hdrinsert,$item) 1
|
||
set rep(value,$item) ""
|
||
}
|
||
|
||
proc Footer {item args} {
|
||
global rep
|
||
if {[lsearch $rep(break) $item] < 0} {
|
||
if {![regexp {PAGE[1-9]?} $item]} {
|
||
lappend rep(break) $item
|
||
}
|
||
}
|
||
array set ftr [list -line 0 -font SansserifTwelve -width $rep(-page_width) \
|
||
-before 0 -after 0 -align center -color Black -offset 0 -eject 0 \
|
||
-image {} -hrule 0 -rotate 0]
|
||
array set ftr $args
|
||
lappend rep(ftr,$item) [array get ftr]
|
||
set rep(value,$item) ""
|
||
}
|
||
|
||
proc Detail {args} {
|
||
global rep
|
||
array set v {-line 0 -font RomanTen -width 1.0 -align left \
|
||
-height 0.2 -color Black -offset 0 -barcode {} -nextline 0}
|
||
array set v $args
|
||
lappend rep(detail) [array get v]
|
||
}
|
||
|
||
proc Unit {u} {
|
||
global rep
|
||
set rep(unit) $u
|
||
}
|
||
|
||
proc Config {args} {
|
||
global rep
|
||
array set rep {-test_only 0 -web 0 -page_height 11.2 -page_widht 8 }
|
||
array set rep $args
|
||
}
|
||
|
||
proc Initiate {output layout} {
|
||
global rep tex nbreaks reclength
|
||
array set rep {break {} offset 0 may_eject 0
|
||
-test_only 0 -web 0 -barcode_n 0}
|
||
set rep(output_file) $output
|
||
set texfn [file rootname $output].tex
|
||
set rep(outf) [open $texfn w]
|
||
Copy $layout
|
||
|
||
### Start with the TeX prologue
|
||
puts $rep(outf) [subst $tex(prologue)]
|
||
set nbreaks [llength $rep(break)]
|
||
set reclength 0
|
||
foreach name $rep(fields) {
|
||
incr reclength $rep(size,$name)
|
||
}
|
||
|
||
#### output detail column definitions
|
||
set coln 0
|
||
set position 0
|
||
foreach it $rep(detail) {
|
||
array set v $it
|
||
if {$v(-nextline)} {
|
||
set position 0
|
||
}
|
||
puts $rep(outf) \
|
||
"\\def\\Col[format %c [expr [incr coln]+0x40]]#1\{"
|
||
puts $rep(outf) \
|
||
"\\hskip[expr $v(-offset)-$position]$rep(unit)"
|
||
set position [expr $v(-offset)+$v(-width)]
|
||
#puts $rep(outf) "% position = $position"
|
||
if {$v(-barcode) != {}} {
|
||
puts $rep(outf) \
|
||
"\\lower[expr $v(-height)*0.4]$rep(unit)"
|
||
}
|
||
puts -nonewline $rep(outf) \
|
||
"\t\\vtop\{\\parindent=0pt\\hsize=$v(-width)$rep(unit)"
|
||
puts -nonewline $rep(outf) \
|
||
"\\tolerance=10000\\strut"
|
||
set a $v(-align)
|
||
if {$a == "right" || $a == "center"} {
|
||
puts -nonewline $rep(outf) \
|
||
{\hfill}
|
||
}
|
||
set sl ""
|
||
set sr ""
|
||
if {$v(-font) != "RomanTen"} {
|
||
if {$v(-barcode) == {}} {
|
||
append sl "\\$v(-font)\{"
|
||
append sr \}
|
||
}
|
||
}
|
||
if {$v(-color) != "Black"} {
|
||
if {$v(-barcode) == {}} {
|
||
append sl "\\$v(-color)\{"
|
||
append sr \}
|
||
}
|
||
}
|
||
set sm "#1"
|
||
puts -nonewline $rep(outf) \
|
||
"$sl $sm $sr"
|
||
if {$a == "left" || $a == "center"} {
|
||
puts -nonewline $rep(outf) \
|
||
{\hfill}
|
||
}
|
||
puts $rep(outf) \
|
||
"\}\n\}"
|
||
}
|
||
}
|
||
|
||
proc Generate {record args} {
|
||
global rep
|
||
# we substitute \x01 for backslashes while processing
|
||
regsub {\\} $record \01 rep(record)
|
||
|
||
### check break fields for header requested
|
||
for {set itn [expr [llength $rep(break)]-1]} {$itn>=0} {incr itn -1} {
|
||
set item [lindex $rep(break) $itn]
|
||
if {[info exists rep(hdrinsert,$item)]} {
|
||
if {$rep(hdrinsert,$item)} {
|
||
set rep(hdrinsert,$item) 0
|
||
puts -nonewline $rep(outf) [dumphdr $rep(hdr,$item)]
|
||
}
|
||
}
|
||
}
|
||
incr rep(may_eject)
|
||
### check break fields for content change
|
||
set brkfound 0
|
||
foreach item $rep(break) {
|
||
if {$item == "FINAL"} break
|
||
if {$rep(value,$item) == ""} {
|
||
set rep(value,$item) [getvar $item]
|
||
continue
|
||
}
|
||
if {$rep(value,$item) != [getvar $item]} {
|
||
puts -nonewline $rep(outf) [dumphdr $rep(ftr,$item)]
|
||
set rep(value,$item) [getvar $item]
|
||
set_register [lindex $args [lsearch $rep(break) $item]] 0
|
||
if {[info exists rep(hdrinsert,$item)]} {
|
||
incr rep(hdrinsert,$item)
|
||
}
|
||
incr brkfound
|
||
}
|
||
}
|
||
### check break fields for header requested (again!)
|
||
for {set itn [expr [llength $rep(break)]-1]} {$itn>=0} {incr itn -1} {
|
||
set item [lindex $rep(break) $itn]
|
||
if {[info exists rep(hdrinsert,$item)]} {
|
||
if {$rep(hdrinsert,$item)} {
|
||
set rep(hdrinsert,$item) 0
|
||
puts -nonewline $rep(outf) [dumphdr $rep(hdr,$item)]
|
||
}
|
||
}
|
||
}
|
||
puts $rep(outf) "[dumpdetail]"
|
||
}
|
||
|
||
proc Terminate {} {
|
||
global rep tex run
|
||
### check break fields for content change
|
||
foreach item $rep(break) {
|
||
puts -nonewline $rep(outf) [dumphdr $rep(ftr,$item)]
|
||
}
|
||
#tkwait variable run
|
||
puts $rep(outf) "\\bye"
|
||
close $rep(outf)
|
||
set fname [file rootname $rep(output_file)]
|
||
set previousdir [pwd]
|
||
cd [file dirname $fname]
|
||
exec tex $fname
|
||
catch {exec dvips -o $fname.ps $fname.dvi}
|
||
catch {eval file delete [glob bar*.eps]}
|
||
if {$rep(-test_only)} {
|
||
return
|
||
}
|
||
# converte para pdf
|
||
exec ps2pdf ${fname}.ps
|
||
#file delete ${fname}.dvi ${fname}.ps ${fname}.tex ${fname}.log
|
||
if {$rep(-web)} {
|
||
puts "Content-type: application/pdf\n"
|
||
set f [open ${fname}.pdf r]
|
||
fconfigure $f -encoding binary -translation binary
|
||
fconfigure stdout -encoding binary -translation binary
|
||
while {![eof $f]} {
|
||
set data [read $f 500000]
|
||
puts -nonewline $data
|
||
}
|
||
close $f
|
||
file delete ${fname}.pdf
|
||
}
|
||
cd $previousdir
|
||
}
|
||
|
||
proc encodeName {s} {
|
||
global rep tex
|
||
set s [string tolower $s]
|
||
regsub -all -- {-} $s H s1
|
||
return $s1
|
||
}
|
||
|
||
set texEncodeMatrix {
|
||
\\$ \\\$ # \\# % \\% \\^ \\char94\
|
||
<EFBFBD> \\'a <EFBFBD> \\'e <EFBFBD> \\'\\i\{\} <EFBFBD> \\'o <EFBFBD> \\'u
|
||
<EFBFBD> \\'A <EFBFBD> \\'E <EFBFBD> \\'I <EFBFBD> \\'O <EFBFBD> \\'U
|
||
<EFBFBD> \\~a <EFBFBD> \\~A <EFBFBD> \\`a <EFBFBD> \\`A <EFBFBD> \\^a <EFBFBD> \\^A
|
||
<EFBFBD> \\^e <EFBFBD> \\^E <EFBFBD> \\~o <EFBFBD> \\~O <EFBFBD> \\^o <EFBFBD> \\^<EFBFBD>
|
||
<EFBFBD> \\c\ c <EFBFBD> \\c\ C
|
||
< \$<\$\ > \$>\$\
|
||
}
|
||
|
||
proc subs_registers {s} {
|
||
global rep
|
||
# substitute page number counter
|
||
regsub -all {@@pageno@@} $s {\\number\\pageno} s
|
||
|
||
# substitute all variable for their contents before encoding
|
||
#regsub -all {@@(.*)@@} $s \1 s
|
||
while {[set n1 [string first @@ $s]] >= 0} {
|
||
set s1 [string range $s 0 [expr $n1-1]]
|
||
set n2 [string first @@ [string range $s [expr $n1+2] end]]
|
||
set n2 [expr $n2+$n1+2]
|
||
set s3 [string range $s [expr $n2+2] end]
|
||
set v [string range $s [expr $n1+2] [expr $n2-1]]
|
||
set s2 [getvar $v]
|
||
set s "$s1$s2$s3"
|
||
}
|
||
return $s
|
||
}
|
||
|
||
proc texencode {s} {
|
||
global texEncodeMatrix rep tex
|
||
|
||
set s [string trim [subs_registers $s]]
|
||
#regsub {\\} $s \01 s <-- this was already done in Generate
|
||
foreach {it sub} $texEncodeMatrix {
|
||
regsub -all -- $it $s $sub s
|
||
}
|
||
regsub -all -- {&} $s {\\&} s
|
||
regsub -all -- {"} $s {''} s
|
||
# "
|
||
regsub -all -- {\|} $s {$|$} s
|
||
regsub -all -- {\-} $s {--} s
|
||
regsub -all -- {\x01} $s {$\backslash$} s
|
||
return $s
|
||
}
|
||
|
||
proc getvar {v} {
|
||
global rep
|
||
set n1 $rep(offset,$v)
|
||
set n2 [expr $n1+$rep(size,$v)-1]
|
||
return [string range $rep(record) $n1 $n2]
|
||
}
|
||
|
||
proc dumpdetail {} {
|
||
global rep
|
||
set first 0
|
||
set s ""
|
||
set coln 0
|
||
foreach it $rep(detail) {
|
||
array set v $it
|
||
if {$v(-nextline)} {
|
||
append s "\\par"
|
||
}
|
||
append s "\\Col[format %c [expr [incr coln]+0x40]]\{"
|
||
if {$v(-barcode) != {}} {
|
||
set barcodefile [make_barcode [subs_registers $v(-barcode)] \
|
||
$v(-width) $v(-height)]
|
||
append s "\\epsffile\{$barcodefile\}"
|
||
} else {
|
||
append s [texencode $v(-text)]
|
||
}
|
||
append s "\}"
|
||
}
|
||
append s "\\par"
|
||
return $s
|
||
}
|
||
|
||
proc dumphdr {f} {
|
||
global rep tex
|
||
set s ""
|
||
set position 0
|
||
foreach it $f {
|
||
array set v $it
|
||
if {$v(-eject) && $rep(may_eject)} {
|
||
if {$s != ""} {
|
||
append s "\\hss\}\n"
|
||
}
|
||
append s "\\vfill\\eject\\vskip $v(-before)$rep(unit)\\line\{"
|
||
} elseif {$v(-before)} {
|
||
if {$s != ""} {
|
||
append s "\\hss\}\n"
|
||
}
|
||
append s "\\vskip $v(-before)$rep(unit)\\line\{"
|
||
set position 0
|
||
}
|
||
if {$s == ""} {
|
||
append s "\\line\{"
|
||
}
|
||
if {$v(-offset)} {
|
||
append s "\\hskip[expr $v(-offset)-$position]$rep(unit)"
|
||
set position [expr $v(-offset)+$v(-width)]
|
||
}
|
||
if {$v(-rotate)} {
|
||
append s "\\rotate\{$v(-rotate)\}"
|
||
}
|
||
append s "\\hbox to$v(-width)$rep(unit)\{"
|
||
set a $v(-align)
|
||
set sl ""
|
||
set sr ""
|
||
if {!$v(-hrule)} {
|
||
if {$a == "right" || $a == "center"} {
|
||
append s {\hfill{}}
|
||
}
|
||
if {$v(-font) != "RomanTen"} {
|
||
append sl "\\$v(-font)\{"
|
||
append sr \}
|
||
}
|
||
}
|
||
if {$v(-color) != "Black"} {
|
||
append sl "\\$v(-color)\{"
|
||
append sr \}
|
||
}
|
||
if {$v(-hrule)} {
|
||
set sm "\\xleaders\\hrule height$v(-hrule)$rep(unit)\\hss"
|
||
} elseif {$v(-image) != {}} {
|
||
set sm "\\hbox\{\\epsffile\{$v(-image)\}\}"
|
||
} else {
|
||
set sm [texencode $v(-text)]
|
||
}
|
||
append s $sl $sm $sr
|
||
if {!$v(-hrule)} {
|
||
if {$a == "left" || $a == "center"} {
|
||
append s {\hfill}
|
||
}
|
||
}
|
||
append s "\}\n"
|
||
if {$v(-after)} {
|
||
append s "\\hss\}\n\\vskip $v(-after)$rep(unit)\\line\{"
|
||
set position 0
|
||
}
|
||
}
|
||
append s "\\hss\}\n"
|
||
return $s
|
||
}
|
||
|
||
proc make_barcode {s width height} {
|
||
global rep
|
||
set bfname barf[format %07d [incr rep(-barcode_n)]].eps
|
||
set width [expr $width - 0.1]
|
||
set height [expr $height - 0.1]
|
||
if {[string length $s] == 13} {
|
||
set s [string range $s 0 11]
|
||
}
|
||
exec barcode -o $bfname -b $s -E -u $rep(unit) \
|
||
-m 0,0 -g ${width}x${height}+0+0
|
||
return $bfname
|
||
}
|
||
|
||
set run 0
|
||
|