# print.tcl --

# This file defines the 'tk print' command for printing of the canvas
# widget and text on X11, Windows, and macOS. It implements an abstraction
# layer that presents a consistent API across the three platforms.

# Copyright © 2009 Michael I. Schwartz.
# Copyright © 2021 Kevin Walzer/WordTech Communications LLC.
# Copyright © 2021 Harald Oehlmann, Elmicron GmbH
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.


namespace eval ::tk::print {

    if {[tk windowingsystem] eq "win32"} {

	variable ::tk::print::printer_name
	variable ::tk::print::copies
	variable ::tk::print::dpi_x
	variable ::tk::print::dpi_y
	variable ::tk::print::paper_width
	variable ::tk::print::paper_height
	variable ::tk::print::margin_left
	variable ::tk::print::margin_top
	variable printargs
	array set printargs {}

	# Multiple utility procedures for printing text based on the
	# C printer primitives. 

	# _set_dc: 
	# Select printer and set device context and other parameters
	# for print job. 
	# 
	proc _set_dc {} {
	    variable printargs

	    #First, we select the printer.
	    ::tk::print::_selectprinter

	    if {$::tk::print::printer_name == ""} {
		#they pressed cancel
		return
	    }

	    #Next, set values. Some are taken from the printer, 
	    #some are sane defaults.
	    
	    set printargs(hDC) [list $::tk::print::printer_name]
	    set printargs(pw) $::tk::print::paper_width
	    set printargs(pl) $::tk::print::paper_height
	    set printargs(lm) 1000
	    set printargs(tm) 1000 
	    set printargs(rm) 1000
	    set printargs(bm) 1000
	    set printargs(resx) $::tk::print::dpi_x
	    set printargs(resy) $::tk::print::dpi_y
	    set printargs(copies) $::tk::print::copies
	    set printargs(resolution) [list  $::tk::print::dpi_x $::tk::print::dpi_y]

	}

	# _print_data
	# This function prints multiple-page files, using a line-oriented
	# function, taking advantage of knowing the character widths.
	# Arguments: 
	# data -       Text data for printing
	# breaklines - If non-zero, keep newlines in the string as
	#              newlines in the output.
	# font -       Font for printing

	proc _print_data { data {breaklines 1 } {font {}} } {
	    
	    variable printargs

	    _set_dc
	    
	    if { [string length $font] == 0 } {
		eval ::tk::print::_gdi characters  $printargs(hDC) -array printcharwid
	    } else {
		eval ::tk::print::_gdi characters $printargs(hDC) -font $font -array printcharwid
	    }
	    set pagewid  [ expr ( $printargs(pw) - $printargs(rm) ) / 1000 * $printargs(resx) ]
	    set pagehgt  [ expr ( $printargs(pl) - $printargs(bm) ) / 1000 * $printargs(resy) ]
	    set totallen [ string length $data ]
	    set curlen 0
	    set curhgt [ expr $printargs(tm) * $printargs(resy) / 1000 ]

	    ::tk::print::_opendoc 
	    ::tk::print::_openpage
	    
	    while { $curlen < $totallen } {		
		set linestring [ string range $data $curlen end ]
		if { $breaklines } {
		    set endind [ string first "\n" $linestring ]
		    if { $endind != -1 } {
			set linestring [ string range $linestring 0 $endind ] 
			# handle blank lines....
			if { $linestring == "" } { 
			    set linestring " " 
			}
		    } 
		} 

		set result [_print_page_nextline $linestring \
				printcharwid printargs $curhgt $font]
		incr curlen [lindex $result 0]
		incr curhgt [lindex $result 1]
		if { [expr $curhgt + [lindex $result 1] ] > $pagehgt } {
		    ::tk::print::_closepage
		    ::tk::print::_openpage
		    set curhgt [ expr $printargs(tm) * $printargs(resy) / 1000 ]
		}
	    }

	    ::tk::print::_closepage
	    ::tk::print::_closedoc
	}

	
	# _print_file
	# This function prints multiple-page files
	# It will either break lines or just let them run over the 
	# margins (and thus truncate).
	# The font argument is JUST the font name, not any additional
	# arguments.
	# Arguments:
	#   filename -   File to open for printing
	#   breaklines - 1 to break lines as done on input, 0 to ignore newlines
	#   font -       Optional arguments to supply to the text command
	
	proc _print_file { filename {breaklines 1 } { font {}} } {
	    
	    variable printargs
	    array get printargs
	    
	    set fn [open $filename r]
	    set data [ read $fn ]
	    close $fn
	    _print_data $data $breaklines $font
	}

	# _print_page_nextline
	# Returns the pair "chars y"
	# where chars is the number of characters printed on the line
	# and y is the height of the line printed
	# Arguments:
	#   string -         Data to print
	#   pdata -         Array of values for printer characteristics
	#   cdata -         Array of values for character widths
	#   y -              Y value to begin printing at
	#   font -           if non-empty specifies a font to draw the line in

	proc _print_page_nextline { string carray parray y font } {
	    
	    
	    upvar #0 $carray charwidths
	    upvar #0 $parray printargs
	    
	    variable printargs

	    set endindex 0
	    set totwidth 0
	    set maxwidth [ expr ( ( $printargs(pw) - $printargs(rm) ) / 1000 ) * $printargs(resx) ]
	    set maxstring [ string length $string ]
	    set lm [ expr $printargs(lm) * $printargs(resx) / 1000 ]

	    for { set i 0 } { ( $i < $maxstring ) && ( $totwidth < $maxwidth ) } { incr i } {
		incr totwidth $charwidths([string index $string $i])
		# set width($i) $totwidth
	    }
	    
	    set endindex $i
	    set startindex $endindex

	    if { $i < $maxstring } {
		# In this case, the whole data string is not used up, and we wish
		# to break on a  word. Since we have all the partial widths calculated,
		# this should be easy.
		
		set endindex [ expr [string wordstart $string $endindex] - 1 ]
		set startindex [ expr $endindex + 1 ]

		# If the line is just too long (no word breaks), print as much as you can....
		if { $endindex <= 1 } {
		    set endindex $i
		    set startindex $i
		}
	    }

	    if { [string length $font] > 0 } {
		set result [ ::tk::print::_gdi text $printargs(hDC) $lm $y \
				 -anchor nw -justify left \
				 -text [ string trim [ string range $string 0 $endindex ] "\r\n" ] \
				 -font $font ]
	    } else {
		set result [ ::tk::print::_gdi text $printargs(hDC) $lm $y \
				 -anchor nw -justify left \
				 -text [string trim [ string range $string 0 $endindex ] "\r\n" ] ]
	    }
	    return "$startindex $result"
	}


	
	# These procedures read in the canvas widget, and write all of 
	# its contents out to the Windows printer.      
	
	variable option
	variable vtgPrint

	proc _init_print_canvas { } {
	    variable option
	    variable vtgPrint
	    variable printargs
	    
	    array get printargs

	    set option(use_copybits) 1
	    set vtgPrint(printer.bg) white
	}

	proc _is_win {} {
	    variable printargs
	    
	    array get printargs
	    
	    return [ info exist tk_patchLevel ]
	}

	
	# _print_widget
	# Main procedure for printing a widget.  Currently supports
	# canvas widgets.  Handles opening and closing of printer.
	# Arguments:
	#   wid -              The widget to be printed. 
	#   printer -          Flag whether to use the default printer. 
	#   name  -            App name to pass to printer.

	proc _print_widget { wid {printer default} {name "Tk Print Output"} } {
	    
	    variable printargs
	    
	    _set_dc 
	    
	    array get printargs

	    ::tk::print::_opendoc
	    ::tk::print::_openpage

	    # Here is where any scaling/gdi mapping should take place
	    # For now, scale so the dimensions of the window are sized to the
	    # width of the page. Scale evenly.

	    # For normal windows, this may be fine--but for a canvas, one wants the 
	    # canvas dimensions, and not the WINDOW dimensions.
	    if { [winfo class $wid] == "Canvas" } {
		set sc [ lindex [ $wid configure -scrollregion ] 4 ]
		# if there is no scrollregion, use width and height.
		if { "$sc" == "" } {
		    set window_x [ lindex [ $wid configure -width ] 4 ]
		    set window_y [ lindex [ $wid configure -height ] 4 ]
		} else {
		    set window_x [ lindex $sc 2 ]
		    set window_y [ lindex $sc 3 ]
		}
	    } else {
		set window_x [ winfo width $wid ]
		set window_y [ winfo height $wid ]
	    }

	    set printer_x [ expr ( $printargs(pw) - \
				       $printargs(lm) - \
				       $printargs(rm) \
				       ) * \
				$printargs(resx)  / 1000.0 ]
	    set printer_y [ expr ( $printargs(pl) - \
				       $printargs(tm) - \
				       $printargs(bm) \
				       ) * \
				$printargs(resy) / 1000.0 ]
	    set factor_x [ expr $window_x / $printer_x ]
	    set factor_y [ expr $window_y / $printer_y ]
	    
	    if { $factor_x < $factor_y } {
		set lo $window_y
		set ph $printer_y
	    } else {
		set lo $window_x
		set ph $printer_x
	    }

	    ::tk::print::_gdi map $printargs(hDC) -logical $lo -physical $ph -offset $printargs(resolution)
	    
	    # Handling of canvas widgets.
	    switch [winfo class $wid] {
		Canvas {
		    _print_canvas $printargs(hDC) $wid
		}
		default {
		    puts "Can't print items of type [winfo class $wid]. No handler registered"
		}
	    }

	    # End printing process.
	    ::tk::print::_closepage
	    ::tk::print::_closedoc
	}


	
	#  _print_canvas
	# Main procedure for writing canvas widget items to printer.
	# Arguments: 
	#    hdc -              The printer handle.
	#    cw  -              The canvas widget.
	

	proc _print_canvas {hdc cw} {
	    variable  vtgPrint
	    
	    variable printargs
	    array get printargs

	    # Get information about page being printed to
	    # print_canvas.CalcSizing $cw
	    set vtgPrint(canvas.bg) [string tolower [$cw cget -background]]

	    # Re-write each widget from cw to printer
	    foreach id [$cw find all] {
		set type [$cw type $id]
		if { [ info commands _print_canvas.$type ] == "_print_canvas.$type" } {
		    _print_canvas.[$cw type $id] $printargs(hDC) $cw $id
		} else {
		    puts "Omitting canvas item of type $type since there is no handler registered for it"
		}
	    }
	}
	
	# These procedures support the various canvas item types,     
	# reading the information about the item on the real canvas   
	# and then writing a similar item to the printer.           
	
	# _print_canvas.line
	# Description:
	#   Prints a line item.
	# Arguments: 
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	

	proc _print_canvas.line {hdc cw id} {
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs

	    set color [_print_canvas.TransColor [$cw itemcget $id -fill]]
	    if {[string match $vtgPrint(printer.bg) $color]} {return}
	    
	    set coords  [$cw coords $id]
	    set wdth    [$cw itemcget $id -width]
	    set arrow   [$cw itemcget $id -arrow]
	    set arwshp  [$cw itemcget $id -arrowshape]
	    set dash    [$cw itemcget $id -dash]
	    set smooth  [$cw itemcget $id -smooth ]
	    set splinesteps [ $cw itemcget $id -splinesteps ]
	    
	    set cmmd  "::tk::print::_gdi line $printargs(hDC) $coords -fill $color -arrow $arrow -arrowshape [list $arwshp]"
	    
	    if { $wdth > 1 } {
		set cmmd "$cmmd -width $wdth"
	    }
	    
	    if { $dash != "" } {
		set cmmd "$cmmd -dash [list $dash]"
	    }
	    
	    if { $smooth != "" } {
		set cmmd "$cmmd -smooth $smooth"
	    }
	    
	    if { $splinesteps != "" } {
		set cmmd "$cmmd -splinesteps $splinesteps"
	    }
	    
	    set result [eval $cmmd]
	    if { $result != "" } {
		puts $result
	    }
	}


	
	# _print_canvas.arc
	#   Prints a arc item.
	# Args:
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	

	proc _print_canvas.arc {hdc cw id} {
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs

	    set color [_print_canvas.TransColor [$cw itemcget $id -outline]]
	    if { [string match $vtgPrint(printer.bg) $color] } {
		return
	    }
	    set coords  [$cw coords $id]
	    set wdth    [$cw itemcget $id -width]
	    set style   [ $cw itemcget $id -style ]
	    set start   [ $cw itemcget $id -start ]
	    set extent  [ $cw itemcget $id -extent ]
	    set fill    [ $cw itemcget $id -fill ]
	    
	    set cmmd  "::tk::print::_gdi arc $printargs(hDC) $coords -outline $color -style $style -start $start -extent $extent"
	    if { $wdth > 1 } {
		set cmmd "$cmmd -width $wdth"
	    }
	    if { $fill != "" } {
		set cmmd "$cmmd -fill $fill"
	    }
	    
	    eval $cmmd
	}
	
	
	# _print_canvas.polygon
	#   Prints a polygon item.
	# Arguments:
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	

	proc _print_canvas.polygon {hdc cw id} {
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs

	    set fcolor [_print_canvas.TransColor [$cw itemcget $id -fill]]
	    if { ![string length $fcolor] } {
		set fcolor $vtgPrint(printer.bg)
	    }
	    set ocolor [_print_canvas.TransColor [$cw itemcget $id -outline]]
	    if { ![string length $ocolor] } {
		set ocolor $vtgPrint(printer.bg)
	    }
	    set coords  [$cw coords $id]
	    set wdth [$cw itemcget $id -width]
	    set smooth  [$cw itemcget $id -smooth ]
	    set splinesteps [ $cw itemcget $id -splinesteps ]
	    

	    set cmmd "::tk::print::_gdi polygon $printargs(hDC) $coords -width $wdth \
		-fill $fcolor -outline $ocolor"
	    if { $smooth != "" } {
		set cmmd "$cmmd -smooth $smooth"
	    }
	    
	    if { $splinesteps != "" } {
		set cmmd "$cmmd -splinesteps $splinesteps"
	    }
	    
	    eval $cmmd
	}


	
	# _print_canvas.oval
	#   Prints an oval item.
	# Arguments:
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	
	proc _print_canvas.oval { hdc cw id } {
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs

	    set fcolor [_print_canvas.TransColor [$cw itemcget $id -fill]]
	    if {![string length $fcolor]} {set fcolor $vtgPrint(printer.bg)}
	    set ocolor [_print_canvas.TransColor [$cw itemcget $id -outline]]
	    if {![string length $ocolor]} {set ocolor $vtgPrint(printer.bg)}
	    set coords  [$cw coords $id]
	    set wdth [$cw itemcget $id -width]

	    set cmmd "::tk::print::_gdi oval $printargs(hDC) $coords -width $wdth \
		-fill $fcolor -outline $ocolor"

	    eval $cmmd
	}

	
	# _print_canvas.rectangle
	#   Prints a rectangle item.
	# Arguments:
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	

	proc _print_canvas.rectangle {hdc cw id} {
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs

	    set fcolor [_print_canvas.TransColor [$cw itemcget $id -fill]]
	    if {![string length $fcolor]} {set fcolor $vtgPrint(printer.bg)}
	    set ocolor [_print_canvas.TransColor [$cw itemcget $id -outline]]
	    if {![string length $ocolor]} {set ocolor $vtgPrint(printer.bg)}
	    set coords  [$cw coords $id]
	    set wdth [$cw itemcget $id -width]

	    set cmmd "::tk::print::_gdi rectangle $printargs(hDC) $coords -width $wdth \
		-fill $fcolor -outline $ocolor"

	    eval $cmmd
	}
	
	# _print_canvas.text
	#   Prints a text item.
	# Arguments:
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	

	proc _print_canvas.text {hdc cw id} {
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs
	    
	    set color [_print_canvas.TransColor [$cw itemcget $id -fill]]
	    #    if {[string match white [string tolower $color]]} {return}
	    #    set color black
	    set txt [$cw itemcget $id -text]
	    if {![string length $txt]} {return}
	    set coords [$cw coords $id]
	    set anchr [$cw itemcget $id -anchor]
	    
	    set bbox [$cw bbox $id]
	    set wdth [expr [lindex $bbox 2] - [lindex $bbox 0]]

	    set just [$cw itemcget $id -justify]
	    
	    # Get the canvas font info.
	    set font [ $cw itemcget $id -font ]
	    
	    # Find the real font info.
	    set font [font actual $font]
	    
	    # Create a compatible font, suitable for printer name extraction.
	    set font [ eval font create $font ]
	    
	    # Just get the name and family, or some of the ::tk::print::_gdi
	    # commands will fail.
	    set font [list [font configure $font -family]  -[font configure $font -size] ]

	    set cmmd "::tk::print::_gdi text $printargs(hDC) $coords -fill $color -text [list $txt] \
		-anchor $anchr -font [ list $font ] \
		-width $wdth -justify $just"
	    eval $cmmd
	} 


	# _print_canvas.image
	# Prints an image item.
	# Arguments:
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	

	proc _print_canvas.image {hdc cw id} {

	    variable vtgPrint
	    variable option
	    
	    variable printargs
	    array get printargs

	    # First, we have to get the image name.
	    set imagename [ $cw itemcget $id -image]
	    
	    # Now we get the size.
	    set wid [ image width $imagename]
	    set hgt [ image height $imagename ]
	    
	    # Next, we get the location and anchor
	    set anchor [ $cw itemcget $id -anchor ]
	    set coords [ $cw coords $id ]
	    

	    # Since the GDI commands don't yet support images and bitmaps,
	    # and since this represents a rendered bitmap, we CAN use
	    # copybits IF we create a new temporary toplevel to hold the beast.
	    # If this is too ugly, change the option!
	    
	    if { [ info exist option(use_copybits) ] } {
		set firstcase $option(use_copybits)
	    } else {
		set firstcase 0
	    }

	    if { $firstcase > 0 } {
		set tl [toplevel .tmptop[expr int( rand() * 65535 ) ] -height $hgt -width $wid -background $vtgPrint(printer.bg) ]
		canvas $tl.canvas -width $wid -height $hgt
		$tl.canvas create image 0 0 -image $imagename -anchor nw
		pack $tl.canvas -side left -expand false -fill none 
		tkwait visibility $tl.canvas
		update
		#set srccoords [list "0 0 [ expr $wid - 1] [expr  $hgt - 1 ]" ]
		#set dstcoords [ list "[lindex $coords 0] [lindex $coords 1] [expr $wid - 1] [expr $hgt - 1]" ]
		set srccoords  [ list "0 0 $wid $hgt" ]
		set dstcoords [ list "[lindex $coords 0] [lindex $coords 1] $wid $hgt" ]
		set cmmd "::tk::print::_gdi copybits $printargs(hDC) -window $tl -client -source $srccoords -destination $dstcoords "
		eval $cmmd
		destroy $tl      
	    } else {
		set cmmd "::tk::print::_gdi image $printargs(hDC) $coords -anchor $anchor -image $imagename "
		eval $cmmd
	    }
	}

	
	# _print_canvas.bitmap
	#   Prints a bitmap item.
	# Arguments:
	#   hdc -              The printer handle.
	#   cw  -              The canvas widget.
	#   id  -              The id of the canvas item.
	

	proc _print_canvas.bitmap {hdc cw id} {
	    variable option
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs

	    # First, we have to get the bitmap name.
	    set imagename [ $cw itemcget $id -image]
	    
	    # Now we get the size.
	    set wid [ image width $imagename]
	    set hgt [ image height $imagename ]
	    
	    #Next, we get the location and anchor.
	    set anchor [ $cw itemcget $id -anchor ]
	    set coords [ $cw coords $id ]
	    
	    # Since the GDI commands don't yet support images and bitmaps,
	    # and since this represents a rendered bitmap, we CAN use
	    # copybits IF we create a new temporary toplevel to hold the beast.
	    # If this is too ugly, change the option!
	    
	    if { [ info exist option(use_copybits) ] } {
		set firstcase $option(use_copybits)
	    } else {
		set firstcase 0
	    }
	    if { $firstcase > 0 } {
		set tl [toplevel .tmptop[expr int( rand() * 65535 ) ] -height $hgt -width $wid -background $vtgPrint(canvas.bg) ]
		canvas $tl.canvas -width $wid -height $hgt
		$tl.canvas create image 0 0 -image $imagename -anchor nw
		pack $tl.canvas -side left -expand false -fill none 
		tkwait visibility $tl.canvas
		update
		set srccoords [list "0 0 [ expr $wid - 1] [expr  $hgt - 1 ]" ]
		set dstcoords [ list "[lindex $coords 0] [lindex $coords 1] [expr $wid - 1] [expr $hgt - 1]" ]
		set cmmd "::tk::print::_gdi copybits $printargs(hDC) -window $tl -client -source $srccoords -destination $dstcoords "
		eval $cmmd
		destroy $tl      
	    } else {
		set cmmd "::tk::print::_gdi bitmap $printargs(hDC) $coords -anchor $anchor -bitmap $imagename"
		eval $cmmd
	    }
	}

	
	# These procedures transform attribute setting from the real  
	# canvas to the appropriate setting for printing to paper. 
	
	# _print_canvas.TransColor
	#   Does the actual transformation of colors from the
	#   canvas widget to paper.
	# Arguments:
	#   color -            The color value to be transformed.
	

	proc _print_canvas.TransColor {color} {
	    variable vtgPrint
	    
	    variable printargs
	    array get printargs

	    switch [string toupper $color] {
		$vtgPrint(canvas.bg)       {return $vtgPrint(printer.bg)} 
	    }
	    return $color
	}

	# Initialize all the variables once.
	_init_print_canvas
    }
    #end win32 procedures

    namespace export canvas text
    namespace ensemble create
}


# tk print --
# This procedure prints the canvas and text widgets using platform-
# native API's.
#
# Subcommands:
#
#     canvas - Print the display of a canvas widget.
#         Arguments:
#             w: Widget to print.
#
#     text - Print the display of a text widget.
#         Arguments:
#             w: Widget to print.


proc ::tk::print::canvas {w} {

    if {[tk windowingsystem] eq "win32"} {
	::tk::print::_print_widget $w 0 "Tk Print Output"
    }
}


proc ::tk::print::text {w} {

    if {[tk windowingsystem] eq "win32"} {
	set txt [$w get 1.0 end]
	set x [file join $::env(TEMP) tk_output.txt]
	set print_txt [open $x  w]
	puts $print_txt $txt
	close $print_txt
	::tk::print::_print_file $x 1 {Arial 12}
    }
}

#Add this command to the tk command ensemble: tk print
#Thanks to Christian Gollwitzer for the guidance here
namespace ensemble configure tk -map \
    [dict merge [namespace ensemble configure tk -map] \
	 {print ::tk::print}]
	    

	
