Subversion Repositories or1k

# print.tcl -- some procedures for dealing with printing.  To print

# PostScript on Windows, tkmswin.dll will need to be present.

proc send_printer { args } {

    global tcl_platform

    parse_args {

        {printer {}}

        {outfile {}}

        {parent {}}

        ascii

        file

    }

    if {[llength $args] == 0} {

        error "No filename or data provided."

    }

    if {$ascii == 1} {

        if {$tcl_platform(platform) == "windows"} then {

            PRINT_windows_ascii -file $file -parent $parent [lindex $args 0]

        } else {

            send_printer_ascii -printer $printer -file $file \

                    -outfile $outfile [lindex $args 0]

        }

        return

    }

    if {$outfile != ""} {

        if {$file} {

            file copy [lindex 0 $args] $outfile

        } else {

            set F [open $outfile w]

            puts $F [lindex 0 $args]

            close $F

        }

        return

    }

    if {$tcl_platform(platform) == "windows"} then {

        load tkmswin.dll

        set cmd {tkmswin print -postscript}

        if {$printer != ""} {

            lappend cmd -printer $printer

        }

        if {$file} {

            lappend cmd -file

        }

        lappend cmd [lindex $args 0]

        eval $cmd

    } else {

        # Unix box, assume lpr, but if it fails try lp.

        foreach prog {lpr lp} {

            set cmd [list exec $prog]

            if {$printer != ""} {

                if {$prog == "lpr"} {

                    lappend cmd "-P$printer"

                } else {

                    lappend cmd "-d$printer"

                }

            }

            if {$file} {

                lappend cmd "<"

            } else {

                lappend cmd "<<"

            }

            # tack on data or filename

            lappend cmd [lindex $args 0]

            # attempt to run the command, and exit if successful

            if ![catch {eval $cmd} ret] {

                return

            }

        }

        error "Couldn't run either `lpr' or `lp' to print"

    }

}

proc send_printer_ascii { args } {

    global tcl_platform

    parse_args {

        {printer {}}

        {outfile {}}

        {file 0}

        {font Courier}

        {fontsize 10}

        {pageheight 11}

        {pagewidth 8.5}

        {margin .5}

    }

    if {[llength $args] == 0} {

        error "No filename or data provided."

    }

    if {$tcl_platform(platform) == "windows"} then {

        PRINT_windows_ascii -file $file [lindex $args 0]

        return

    }

    # convert the filename or data to ascii, and then send to the printer.

    set inch 72

    set pageheight [expr $pageheight*$inch]

    set pagewidth [expr $pagewidth*$inch]

    set margin [expr $margin*$inch]

    set output "%!PS-Adobe-1.0\n"

    append output "%%Creator: libgui ASCII-to-PS converter\n"

    append output "%%DocumentFonts: $font\n"

    append output "%%Pages: (atend)\n"

    append output "/$font findfont $fontsize scalefont setfont\n"

    append output "/M{moveto}def\n"

    append output "/S{show}def\n"

    set pages 1

    set y [expr $pageheight-$margin-$fontsize]

    if {$file == 1} {

        set G [open [lindex $args 0] r]

        set strlen [gets $G str]

    } else {

        # make sure that we end with a newline

        set args [lindex $args 0]

        append args "\n"

        set strlen [string first "\n" $args]

        if {$strlen != -1} {

            set str [string range $args 0 [expr $strlen-1]]

            set args [string range $args [expr $strlen+1] end]

        }

    }

    while {$strlen != -1} {

        if {$y < $margin} {

            append output "showpage\n"

            incr pages

            set y [expr $pageheight-$margin-$fontsize]

        }

        regsub -all {[()\\]} $str {\\&} str

        append output "$margin $y M ($str) S\n"

        set y [expr $y-($fontsize+1)]

        if {$file == 1} {

            set strlen [gets $G str]

        } else {

            set strlen [string first "\n" $args]

            if {$strlen != -1} {

                set str [string range $args 0 [expr $strlen-1]]

                set args [string range $args [expr $strlen+1] end]

            }

        }

    }

    append output "showpage\n"

    append output "%%Pages: $pages\n"

    if {$file == 1} {

        close $G

    }

    send_printer -printer $printer -outfile $outfile $output

}

# Print ASCII text on Windows.

proc PRINT_windows_ascii { args } {

    global tcl_platform errorInfo

    global PRINT_state

    parse_args {

        {file 0}

        {parent {}}

    }

    if {[llength $args] == 0} {

        error "No filename or data provided."

    }

    if {$tcl_platform(platform) != "windows"} then {

        error "Only works on Windows"

    }

    # Copied from tk_dialog, except that it returns.

    catch {destroy .cancelprint}

    toplevel .cancelprint -class Dialog

    wm withdraw .cancelprint

    wm title .cancelprint [gettext "Printing"]

    frame .cancelprint.bot

    frame .cancelprint.top

    pack .cancelprint.bot -side bottom -fill both

    pack .cancelprint.top -side top -fill both -expand 1

    set PRINT_state(pageno) [format [gettext "Now printing page %d"] 0]

    label .cancelprint.msg -justify left -textvariable PRINT_state(pageno)

    pack .cancelprint.msg -in .cancelprint.top -side right -expand 1 \

            -fill both -padx 1i -pady 5

    button .cancelprint.button -text [gettext "Cancel"] \

            -command { ide_winprint abort } -default active

    grid .cancelprint.button -in .cancelprint.bot -column 0 -row 0 \

            -sticky ew -padx 10

    grid columnconfigure .cancelprint.bot 0

    update idletasks

    set x [expr [winfo screenwidth .cancelprint]/2 \

            - [winfo reqwidth .cancelprint]/2 \

            - [winfo vrootx [winfo parent .cancelprint]]]

    set y [expr [winfo screenheight .cancelprint]/2 \

            - [winfo reqheight .cancelprint]/2 \

            - [winfo vrooty [winfo parent .cancelprint]]]

    wm geom .cancelprint +$x+$y

    update

    # We're going to change the focus and the grab as soon as we start

    # printing, so remember them now.

    set oldFocus [focus]

    set oldGrab [grab current .cancelprint]

    if {$oldGrab != ""} then {

        set grabStatus [grab status $oldGrab]

    }

    focus .cancelprint.button

    set PRINT_state(start) 1

    set PRINT_state(file) $file

    if {$file == 1} then {

        set PRINT_state(fp) [open [lindex $args 0] r]

    } else {

        set PRINT_state(text) [lindex $args 0]

    }

    set cmd [list ide_winprint print_text PRINT_query PRINT_text \

               -pageproc PRINT_page]

    if {$parent != {}} then {

        lappend cmd -parent $parent

    }

    set code [catch $cmd errmsg]

    set errinfo $errorInfo

    catch { focus $oldFocus }

    catch { destroy .cancelprint }

    if {$oldGrab != ""} then {

        if {$grabStatus == "global"} then {

            grab -global $oldGrab

        } else {

            grab $oldGrab

        }

    }

    if {$code == 1} then {

        error $errmsg $errinfo

    }

}

# The query procedure passed to ide_winprint print_text.  This should

# return one of "continue", "done", or "newpage".

proc PRINT_query { } {

    global PRINT_state

    # Fetch the next line into PRINT_state(str).

    if {$PRINT_state(file) == 1} then {

        set strlen [gets $PRINT_state(fp) PRINT_state(str)]

    } else {

        set strlen [string first "\n" $PRINT_state(text)]

        if {$strlen != -1} then {

            set PRINT_state(str) \

                    [string range $PRINT_state(text) 0 [expr $strlen-1]]

            set PRINT_state(text) \

                    [string range $PRINT_state(text) [expr $strlen+1] end]

        } else {

            if {$PRINT_state(text) != ""} then {

                set strlen 0

                set PRINT_state(str) $PRINT_state(text)

                set PRINT_state(text) ""

            }

        }

    }

    if {$strlen != -1} then {

        # Expand tabs assuming tabstops every 8 spaces and a fixed

        # pitch font.  Text written to other assumptions will have to

        # be handled by the caller.

        set str $PRINT_state(str)

        while {[set i [string first "\t" $str]] >= 0} {

            set c [expr 8 - ($i % 8)]

            set spaces ""

            while {$c > 0} {

                set spaces "$spaces "

                incr c -1

            }

            set str "[string range $str 0 [expr $i - 1]]$spaces[string range $str [expr $i + 1] end]"

        }

        set PRINT_state(str) $str

        return "continue"

    } else {

        return "done"

    }

}

# The text procedure passed to ide_winprint print_text.  This should

# return the next line to print.

proc PRINT_text { } {

    global PRINT_state

    return $PRINT_state(str)

}

# This page procedure passed to ide_winprint print_text.  This is

# called at the start of each page.

proc PRINT_page { pageno } {

    global PRINT_state

    set PRINT_state(pageno) [format [gettext "Now printing page %d"] $pageno]

    if {$PRINT_state(start)} then {

        wm deiconify .cancelprint

        grab .cancelprint

        focus .cancelprint.button

        set PRINT_state(start) 0

    }

    update

    return "continue"

}