#!/usr/bin/tclsh
 ##############################################################################
 #
 #                      
 #  Created By    : Dr. Detlef Groth  [email protected]
 #                    delete nocat to answer
 #  Created       : Mon Mar 10 16:41:10 2003
 #  Last Modified : <120220.0949>
 #
 #  Description A simple htmlwidget providing the methods
 #               load:  popups a dialog for local file selection
 #               browse: loads either a local file or a webpage
 #               back, forward, home, Refresh: just like a normal browser behaves
 #               popup : installs a popup with access to back, forward, home, refresh
 #  SYNOPSIS     
 #              pack [snitbrowser .browser] -side left -fill both -expand yes
 #              # WEB
 #             .browser browse "http://wiki.tcl.tk/2993"
 #             # LOCALFILES
 #             .browser load 
 #             # installing the popup
 #             .browser popup .popup
 #  Notes
 #
 #  History:  V0.1 13/11/03: First Release a three hours hack
 #            V0.2 14/11/03: Code Refactoring:
 #                           - Following William H. Duquette suggestions naming public methods
 #                             lowercase
 #                           - implementing public variables as options, like -showimages
 #                           - resorting loading of packages
 #                           - renaming LoadFile to the more appropiate 'browse' method
 #                           - removing lonly global var popupvar
 #            V0.3 02/20/12: Bugfixes and png image support:
 #                           - snit package load without version
 #                           - try to load png package (starkit at: https://bitbucket.org/mittelmark/tcl-code/downloads )
 #                           - variable BigImages and method_MoveBigImages introduced
 #                           - wiki example link fixed
 #
 #  Bugs:     - I would like to change some coderefs from self to mymethod as 
 #              suggested by William but this fails (try inside method home)
 #  $Log: 10368,v $
 #  Revision 1.16  2005/01/23 07:00:45  jcw
 #  10368-1106460530-lwv,134.243.6.109
 #
 #
 ##############################################################################
 #    License:
 #    Copyright (c) Dr. Detlef Groth, 2003 MPIMG Berlin, Germany.
 #
 #    The authors hereby grant permission to use, copy, modify, distribute,
 #    and license this software and its documentation for any purpose,
 #    provided that existing copyright notices are retained in all copies and
 #    that this notice is included verbatim in any distributions. No written
 #    agreement, license, or royalty fee is required for any of the
 #    authorized uses.  Modifications to this software may be copyrighted by
 #    their authors and need not follow the licensing terms described here,
 #    provided that the new terms are clearly indicated on the first page of
 #    each file where they apply.
 #    
 #    IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
 #    FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
 #    ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
 #    DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
 #    POSSIBILITY OF SUCH DAMAGE.
 #    
 #    THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
 #    INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
 #    FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
 #    IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
 #    NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
 #    MODIFICATIONS.
 #    
 #    GOVERNMENT USE: If you are acquiring this software on behalf of the
 #    U.S. government, the Government shall have only "Restricted Rights"
 #    in the software and related documentation as defined in the Federal 
 #    Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
 #    are acquiring the software on behalf of the Department of Defense, the
 #    software shall be classified as "Commercial Computer Software" and the
 #    Government shall have only "Restricted Rights" as defined in Clause
 #    252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
 #    authors grant the U.S. Government and others acting in its behalf
 #    permission to use and distribute the software in accordance with the
 #    terms specified in this license.
 ################################################################################
 package provide snitbrowser 0.3
 package require Tk
 package require http
 lappend auto_path [file dirname [info script]] 
 package require snit
 package require Tkhtml 
 catch {
   # should check for Tcl8.6
   package require tkpng
 }
 
 snit::widget snitbrowser {
     # methods starting with underlines/Uppercases are private 
     # and should not be used externally
     variable htmlwidget
     variable lastDir
     variable Images 
     variable OldImages 
     variable hotkey
     variable LastFile
     variable PrevFiles 
     variable NextFiles
     variable Priv
     variable Popupvar
     variable popup
     variable BigImages
     option -showimages 1
     option -padx 5
     option -pady 5
     option -underlinehyperlinks 0
     option -bg beige
     option -tablerelief raised
     delegate option * to htmlwidget
     delegate method * to htmlwidget
     constructor {args} {
         set lastDir [pwd]
         set LastFile {}
         set PrevFiles {}
         set NextFiles {}
         pack [frame $win.f] -side top -fill both -expand yes
         html $win.f.html \
                   -yscrollcommand "$win.f.vsb set" \
                   -xscrollcommand "$win.hsb set" \
                   -imagecommand [mymethod _ImageCmd] \
                   -formcommand [mymethod _FormCmd] \
                   -unvisitedcolor blue \
                   -bg $options(-bg) \
                   -underlinehyperlinks $options(-underlinehyperlinks) \
                   -pady $options(-pady) -padx $options(-padx) \
                   -tablerelief $options(-tablerelief)
         pack $win.f.html -side left -fill both -expand 1
         scrollbar $win.f.vsb -orient vertical -command "$win.f.html yview"
         pack $win.f.vsb -side right -fill y
         bind $win.f.html.x <1> [mymethod _HrefBinding %x %y]
         bind $win.f.html.x <B1-Motion> [mymethod _SelectionBinding %W %x %y]
         scrollbar $win.hsb -orient horizontal -command "$win.f.html xview"
         pack $win.hsb -side bottom -fill x
         set htmlwidget $win.f.html
         image create photo smgray -data {
             R0lGODdhOAAYAPAAALi4uAAAACwAAAAAOAAYAAACI4SPqcvtD6OctNqLs968+w+G4kiW5omm
             6sq27gvH8kzX9m0VADv/
         }
         bind HtmlClip <Motion> {
             set parent [winfo parent %W]
             set url [$parent href %x %y] 
             if {[string length $url] > 0} {
                 $parent configure -cursor hand2
             } else {
                 $parent configure -cursor {}
             }
         }
         $self configurelist $args
     }
     method home {} {
         $self browse [lindex $PrevFiles 0]  
     }
     method back {} {
         $self browse [lindex $PrevFiles end]  
     }
     method forward {} {
         $self browse [lindex $NextFiles end]  
     }
     method _Popup {} {
         if {[winfo exists $Popupvar] } {
             set x [winfo pointerx .]
             set y [winfo pointery .]
             tk_popup $Popupvar $x $y 
         }
     }
     method popup {path} {
         set Popupvar $path
         menu $Popupvar -tearoff 0
         $Popupvar add command -label Refresh -underline 0 -accelerator Ctrl-r -command [mymethod refresh]
         $Popupvar add separator 
         $Popupvar add command -label Home -accelerator Alt+Home -underline 1 -command [mymethod home]
         $Popupvar add command -label Back -accelerator Alt+Left -underline 1 -command [mymethod back]
         $Popupvar add command -label Forward -accelerator Alt+Right -underline 1 -command [mymethod forward]
         bind $htmlwidget.x <ButtonPress-3> [mymethod _Popup]
         bind all <Alt-Left> [ mymethod back ]
         bind all <Alt-Right> [ mymethod forward ]
         bind all <Alt-Home> [mymethod home]
     }
     method _FetchImage {src w h args} {
         # Fetch the image
         if {[catch {
              http::geturl $src -timeout 10000
         } token]} {
              return smgray
         }
         set data [http::data $token]
         http::cleanup $token
         # Hack needed to make sure the data is binary:
         binary scan $data {}
         set name [image create photo]
         if {[catch {$name put $data} ret]} {
             return smgray
         }
         return $name
     }
     # anyone interested in implementing the _FormCmd ?
     method _FormCmd {args} {
         puts $args
     }
     method _ImageCmd {args} {
         if {!$options(-showimages)} {
             return smgray
         }
         set fn [lindex $args 0]
         if {[string match {http:*} $fn]} {
             set dat [$self _FetchImage $fn 1 1]
             return $dat
         }
         if {[info exists OldImages($fn)]} {
             set Images($fn) $OldImages($fn)
             unset OldImages($fn)
             return $Images($fn)
         }
      
         if {[catch {image create photo -file $fn} img]} {
             return $img(smgray)
         }
        
         if {[image width $img]*[image height $img]>20000} {
             set b [image create photo -width [image width $img] \
                    -height [image height $img]]
             set BigImages($b) $img
             set img $b
             after idle "[mymethod _MoveBigImage $b]"
         }
         set Images($fn) $img
         return $img
     }
     method refresh {args} {
         if {![info exists LastFile]} return
         $self browse $LastFile
     }
     method _MoveBigImage b {
      if {![info exists BigImages($b)]} return
      $b copy $BigImages($b)
      image delete $BigImages($b)
      unset BigImages($b)
      update
    }

     method _SelectionBinding {w x y} {
         $htmlwidget selection set @$Priv(mark) @$x,$y
         clipboard clear
         # avoid tkhtml0.0 errors 
         # anyone can fix this for tkhtml0.0
         catch {
             clipboard append [selection get]
         }
     }
     method _HrefBinding {x y} {
         set Priv(mark) $x,$y
         set list [$htmlwidget href $x $y]
         if {![llength $list]} {return}
         foreach {new target} $list break
         if {$new!=""} {
             set pattern $LastFile#
             set len [string length $pattern]
             incr len -1
             if {[string range $new 0 $len]==$pattern} {
                 incr len
                 $htmlwidget yview [string range $new $len end]
             } else {
                 $self browse $new
             }
         }
     }
     method _Clear {} {
         $htmlwidget clear
         catch {unset hotkey}
         $self _ClearBigImages
         $self _ClearOldImages
         foreach fn [array names Images] {
             set OldImages($fn) $Images($fn)
         }
         catch {unset Images}
     }
     method _ClearOldImages {} {
         foreach fn [array names OldImages] {
             image delete $OldImages($fn)
         }
         catch {unset OldImages}
     }
     method _ClearBigImages {} {
         foreach b [array names BigImages] {
             image delete $BigImages($b)
         }
         catch {unset BigImages}
     }
     method browse {name} {
         # dgroth fix
         
         if {$name eq ""} { return }
    
         # jcw 06/10/2000 - drop "#tag", if present
         set basename [lindex [split $name #] 0]
                            
         set htmltxt [$self _ReadFile $basename]
                           
         if {$htmltxt==""} return          
         $self _Clear
         if {$name != $LastFile && $LastFile != ""} {
             if {$name == [lindex $PrevFiles end]} {
                 set NextFiles [linsert $NextFiles 0 $LastFile]
                 set PrevFiles [lreplace $PrevFiles end end]
             } else {
                 lappend PrevFiles $LastFile
                 
                 if {$name == [lindex $NextFiles 0]} {
                     set NextFiles [lrange $NextFiles 1 end]
                 } else {
                     set NextFiles {}
                 }
             }
         }
         set LastFile $name
         $htmlwidget config -base $name
         # jcw 06/10/2000 - deal with text files (as suggested by Uwe Koloska)
         if {![regexp -nocase {<html>|<!doctype|<body} [string range $htmltxt 0 200]]} {
             set htmltxt "<pre>$htmltxt</pre>\n"
         }
         # jcw: end of changed code
         $htmlwidget parse $htmltxt
         $self _ClearOldImages
         
         # dgroth 13/11/2003 add jimping to internal name
         if {[regexp {(.+)#(.+)} $LastFile match file anchor]} {
              #tk_messageBox -title "Info!" -icon info -message "message jumping to $anchor" -type ok
              $htmlwidget yview $anchor
          }
 
                               
     }
     method _ReadFile {name} {
        
         # dgroth fix for files containing anchors
         regexp {(.+)#} $name match name  
         # fix for enabling web browsing    
         if {[string match {http:*} $name]} {
             set t [http::geturl $name];
             set r [http::data $t]
             http::cleanup $t;
             return $r
         }
         if {[catch {open $name r} fp]} {
             tk_messageBox -icon error -message $fp -type ok
             return {}
         } else {
          
             fconfigure $fp -translation binary
             set r [read $fp [file size $name]]
             close $fp
             return $r
         }
     }
     method load {} {
         set filetypes {
             {{Html Files} {.html .htm}}
             {{All Files} *}
         }
         set f [tk_getOpenFile -initialdir $lastDir -filetypes $filetypes]
         if {$f!=""} {
             $self browse $f
             set lastDir [file dirname $f]
         }
     }
 }
 proc lets_test_it {} {
     wm title . "Sample Snitbrowser by Dr. Detlef Groth, 2003"
     menu .menubar
     . config -menu .menubar
     set mnu(file) [menu .menubar.file -tearoff 0]
     .menubar add cascade -label File -underline 0 -menu $mnu(file) 
     set mnu(help) [menu .menubar.help -tearoff 0]
     .menubar add cascade -label Help -underline 0 -menu $mnu(help) 
     $mnu(help) add command -label "About ... " -underline 0 -command \
              { tk_messageBox -title "About!" -icon info \
               -message "Sample Snitbrowser by Dr. Detlef Groth\n\n     2003\n\n   [email protected]\n   Delete nocat to answer!" -type ok}
     $mnu(file) add command -label Exit -underline 1 -command  {exit 0}
     pack [snitbrowser .browser] -side left -fill both -expand yes
     #.browser browse d:/docs/tcl7.6/contents.html
     .browser browse "http://wiki.tcl.tk/10368"
     # installing the popup
     .browser popup .popup
 }
 
 lets_test_it

• Snit's Not Incr Tcl
• Tkhtml

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References