# FILE: any2ppm.tcl # # This script converts data in any image format understood by Tk's # (possibly extended) [image photo] command to data representing the # same image in the PPM P3 format. # # This file must be interpreted by the filtersh shell. package require Oc 1.1 package require Tk Oc_ForceStderrDefaultMessage Oc_Main SetAppName any2ppm Oc_Main SetVersion 1.1.1.2 Oc_CommandLine Option console {} {} Oc_CommandLine Option noinfo {} { global noinfo; set noinfo 1 } {Suppress writing of progress info to stderr} set noinfo 0 Oc_CommandLine Option o {outfile} { global outSpec; set outSpec $outfile } {Write output to outfile ("-" for stdout)} set outSpec "" Oc_CommandLine Option f {} { global force_overwrite; set force_overwrite 1 } {Force overwrite of output files} set force_overwrite 0 Oc_CommandLine Option format {fmt} { global outFormat if {[string match jpg [string tolower $fmt]]} {set fmt jpeg} if {[string match p3 [string tolower $fmt]]} {set fmt ppm} if {[string match p6 [string tolower $fmt]]} {set fmt ppm6} if {[string match b24 [string tolower $fmt]]} {set fmt bmp} set outFormat $fmt } {Output file format (default is ppm)} set outFormat ppm Oc_CommandLine Option [Oc_CommandLine Switch] { {{infile list} {} {Input file(s). If none or "", read from stdin.}} } { global inList; set inList $infile } {End of options; next argument is infile} set inList [list] Oc_CommandLine Parse $argv set errcount 0 set BUFSIZ 250000 ;# Size of output write buffer proc make_ppm_name { inname } { global outFormat force_overwrite # If outFormat is JPEG, the use .jpg as the output file # extension. Use .tif for TIFF. Otherwise use the leading # string of alphabetical characters (i.e., [a-z]), cast to # lowercase. This provides the conventional extension for # all the cases I know about. if {[string match jpeg* [string tolower $outFormat]]} { set ext jpg } elseif {[string match tiff* [string tolower $outFormat]]} { set ext tif } else { if {![regexp -nocase -- {^ *([a-z]+)} $outFormat dum ext]} { set ext ppm ;# Safety default } set ext [string tolower $ext] } set outname [file rootname $inname].$ext if {!$force_overwrite && [file exists $outname]} { set basename $outname set outname {} for {set i 1} {$i<100} {incr i} { set testname ${basename}-$i if {![file exists $testname]} { set outname $testname break } } } return $outname } proc write_p3_chan { chanid pic } { # The Tk photo interface does not have a "write to channel" option. set width [image width $pic] ; set height [image height $pic] puts $chanid "P3" puts $chanid "$width $height" puts $chanid "255" set rtop [expr {$height-1}] ; set ctop [expr {$width-1}] for {set r 0} {$r<$height} {incr r} { for {set c 0} {$c<$width} {incr c} { puts $chanid [$pic get $c $r] } } flush $chanid } if {[string match ppm $outFormat]} { set useChanOutput 1 } else { set useChanOutput 0 } switch -exact -- $outSpec { {} {set outmode automatic} {-} { set outmode fixed set outname {} set outchan stdout fconfigure $outchan -translation auto \ -buffering full -buffersize $BUFSIZ } default { set outmode fixed set outname $outSpec if {$useChanOutput} { if {[catch {open $outname "w"} msg]} { puts stderr "Unable to open output file $outname: $msg" incr errcount exit $errcount } else { set outchan $msg fconfigure $outchan -translation auto \ -buffering full -buffersize $BUFSIZ } } } } set loopOpen 0 if {[llength $inList]==0} { set inList [list {}] ;# Use empty string to denote stdin } foreach inname $inList { if {[string match {} $inname]} { # Read from stdin if {!$noinfo} { puts stderr "Processing input from stdin" } fconfigure stdin -translation binary set data [read stdin] if {[catch {set pic [image create photo -data $data]} errmsg]} { # Unable to process data using 'photo -data' option. Try # using the -file option instead Oc_TempFile New temp -stem any2ppm set tempname [$temp AbsoluteName] $temp Claim $temp Delete set tempchan [open $tempname w] fconfigure $tempchan -translation binary if {[catch {puts -nonewline $tempchan $data} msg]} { puts stderr "FATAL ERROR: $msg" catch {close $tempchan} catch {file delete $tempname} exit [incr errcount] } close $tempchan if {[catch {set pic [image create photo -file $tempname]} msg]} { puts stderr "ERROR: $errmsg" puts stderr "ERROR: $msg" incr errcount file delete $tempname continue } file delete $tempname } } else { # Read from file if {![file readable $inname]} { puts stderr "Unable to open input file $inname; Skipping." incr errcount continue } if {!$noinfo} { puts stderr "Processing input file $inname" } if {[catch {set pic [image create photo -file $inname]} errmsg]} { puts stderr "ERROR: $errmsg" incr errcount continue } } if {!$noinfo} { puts stderr "Processing output..." } if {[string match automatic $outmode]} { if {[string match {} $inname]} { set outname {} set outchan stdout } else { set outname [make_ppm_name $inname] if {[string match {} $outname]} { puts stderr "Unable to generate unique output name; Skipping." incr errcount continue } if {$useChanOutput} { if {[catch {open $outname "w"} outchan]} { puts stderr "Unable to open output file $outname;\ Skipping." incr errcount continue } fconfigure $outchan -translation auto \ -buffering full -buffersize $BUFSIZ set loopOpen 1 } } } if {$useChanOutput} { # Use above PPM P3 write proc to write to channel routine rather # than Tk photo write command, which writes to a file rather # than a channel, and apparently doesn't know P3 anyway. if {[catch {write_p3_chan $outchan $pic} errmsg]} { puts stderr " PPM P3 WRITE ERROR: $errmsg" incr errcount } flush $outchan if {$loopOpen} { close $outchan unset outchan } } else { # Use Tk image photo write command. if {[string match {} $outname]} { # Use temporary file to fake stdout output Oc_TempFile New temp -stem any2ppm set tempname [$temp AbsoluteName] $temp Claim $temp Delete } else { set tempname $outname } if {[catch {$pic write $tempname -format $outFormat} errmsg]} { puts stderr " $outFormat WRITE ERROR: $errmsg" incr errcount catch {file delete $tempname} exit [incr errcount] } if {[string match {} $outname]} { # Copy results from $tempname to $outchan # (which *should* be stdout!) set tempchan [open $tempname r] fconfigure $tempchan -translation binary fconfigure $outchan -translation binary if {[catch {fcopy $tempchan $outchan} msg]} { puts stderr "FATAL ERROR: $msg" catch {close $tempchan} catch {file delete $tempname} exit [incr errcount] } close $tempchan file delete $tempname flush $outchan } } if {!$noinfo} { if {[info exists outchan] && [string match stdout $outchan]} { puts stderr "Output written to " } elseif {[info exists outname]} { puts stderr "Output written to $outname" } else { puts stderr "Unknown output (programming error?)" } } } exit $errcount