Version 6 of snitbrowser

Updated 2003-11-18 11:14:56

A Snit based wrapper for the tkhtml library

DDG 13 Nov 2003 This is slightly longer as a oneliner but it is inspired by code on Simple Tkhtml web page displayer (thx). A Snit wrapper widget created as a one afternoon hack. It's named snitBrowser because the TclPlugin contains already a package named browser! May be it is long but as a result the widget is fully reuseable. So easy is Snit's Not Incr Tcl ....:

 #!/usr/bin/wish
 ##############################################################################
 #
 #                          Copyright 2003 MPIMG Berlin, Germany.
 #                              All Rights Reserved
 #  Created By    : Dr. Detlef Groth [email protected], [email protected]
 #                    delete nocat to answer
 #  Created       : Mon Mar 10 16:41:10 2003
 #  Last Modified : <031114.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://mini.net/tcl/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
 #  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.7  2003-11-19 09:01:16  jcw
 #  10368-1069154096-147.83.143.107
 #
 #
 ##############################################################################
 #    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.2
 package require Tk
 package require http
 lappend auto_path [file dirname [info script]] 
 package require snit 0.9
 package require Tkhtml 

 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
     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 "MoveBigImage $b"
         }
         set Images($fn) $img
         return $img
     }
     method refresh {args} {
         if {![info exists LastFile]} return
         $self browse $LastFile
     }
     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://mini.net/tcl/snitbrowser"
     # installing the popup
     .browser popup .popup
 }

 lets_test_it

Where is MoveBigImage?


Category Application, Tkhtml, Snit