cbklib

#+##########################################################################
#
# Hypertext HelpSystem.tcl -- A help system based on wiki 1194 and tile
# by Keith Vetter, May 2007
#
# with support for images and launching external clients for URL by Kevin Walzer
# 

pacakge require xplat
if {[tk windowingsystem] eq "aqua"} {
    package require cocoaprint
}

package rqeuire xplat

namespace eval ::Help {
    variable W                                  ;# Various widgets
    variable pages                              ;# All the help pages
    variable alias                              ;# Alias to help pages
    variable state
    variable font TkTextFont
    
    array unset pages
    array unset alias
    array unset state
    array set state {history {} seen {} current {} all {} allTOC {} haveTOC 0}
    array set W {top .helpSystem main "" tree ""}
    array set alias {index Index previous Previous back Back search Search
        history History next Next}

    if {![info exists library]} {
	variable library [file dirname [info script]]
    }
}



## BON HELP
##+##########################################################################
#
# Help Section
#
# Based on http://wiki.tcl.tk/1194
#
#  AddPage title aliases text  -- register a hypertext page
#  Help ?title?                -- bring up a toplevel showing the specified page
#                                 or a index of titles, if not specified
#
# Hypertext pages are in a subset of Wiki format:
#   indented lines come in fixed font without evaluation;
#   blank lines break paragraphs
#   a line starting with "   * " gets a bullet
#   a line starting with "   - " gets a dash
#   a line starting with "   1. " will be a numbered list
#    repeating the initial *,- or "1" will indent the list
#
#   text enclosed by '''<text>''' is embolden
#   text enclosed by ''<text>'' is italics
#   all lines without leading blanks are displayed without explicit
#      linebreak (but possibly word-wrapped)
#   a link is the title of another page in brackets (see examples at
#      end). Links are displayed underlined and blue (or purple if they
#      have been visited before), and change the cursor to a pointing
#      hand. Clicking on a link of course brings up that page.
#
# In addition, you get "Index", "Search" (case-insensitive regexp in
# titles and full text), "History", and "Back" links at the bottom of
# pages.


##+##########################################################################
#
# ::Help::Help -- initializes and creates the help dialog
#
proc ::Help::Help {{title ""}} {
    variable W
    
    if {![winfo exists $W(top)]} {
        ::Help::DoDisplay $W(top)
    }
    
    raise $W(top)
    ::Help::Show $title
}
##+##########################################################################
#
# ::Help::ReadHelpFiles -- reads "help.txt" in the packages directory
# and creates all the help pages.
#
proc ::Help::ReadHelpFiles {dir} {

    set fname [file join $dir help.txt]
    set fin [open $fname r]
    set data [read $fin] ; list
    close $fin
    
    regsub -all -line {^-+$} $data \x01 data
    regsub -all -line {^\#.*$\n} $data {} data
    foreach section [split $data \x01] {
        set n [regexp -line {^title:\s*(.*)$} $section => title]
        if {! $n} {
            puts "Bad help section\n'[string range $section 0 400]'"
            continue
        }
        set aliases {}
        foreach {. alias} [regexp -all -line -inline {^alias:\s*(.*)$} $section] {
            lappend aliases $alias
        }
	
        regsub -all -line {^(title:|alias:).*$\n} $section {} section
        ::Help::AddPage $title $aliases $section
    }
    ::Help::BuildTOC
}

##+##########################################################################
#
# ::Help::Read Images -- reads "images.tcl" in the packages directory
# and creates all images for the help pages.
##+##########################################################################

proc ::Help::ReadImages {dir} {

    variable library

    source [file join $library images.tcl]
    
}


#
# ::Help::AddPage -- Adds another page to the help system
#
proc ::Help::AddPage {title aliases body} {
    variable pages
    variable state
    variable alias
    
    set title [string trim $title]
    set body [string trim $body "\n"]
    regsub -all {\\\n} $body {} body            ;# Remove escaped lines
    regsub -all {[ \t]+\n} $body "\n" body      ;# Remove trailing spaces
    regsub -all {([^\n])\n([^\s])} $body {\1 \2} body ;# Unwrap paragraphs
    
    set pages($title) $body
    
    lappend aliases [string tolower $title]
    foreach name $aliases { set alias([string tolower $name]) $title }
    
    if {[lsearch $state(all) $title] == -1} {
        set state(all) [lsort [lappend state(all) $title]]
    }
}
##+##########################################################################
#
# ::Help::DoDisplay -- Creates our help display. If we have tile 0.7.8 then
# we will also have a TOC pane.
#
proc ::Help::DoDisplay {TOP} {
    variable state
    
    catch {destroy $TOP}
    toplevel $TOP
    wm title $TOP "Help"

    frame $TOP.bottom -bd 2 -relief ridge
    button $TOP.b -text "Print" -command [list ::Help::PrintHelp $TOP]
    pack $TOP.bottom -side bottom -fill both
    pack $TOP.b -side bottom -expand 1 -pady 10 -in $TOP.bottom
    
    set P $TOP.p
    if {1} {                       ;# Need tags on treeview
        set state(haveTOC) 1
        ::ttk::panedwindow $P -orient horizontal
	
        pack $P -side top -fill both -expand 1
        frame $P.toc -relief ridge
        frame $P.help -bd 2 -relief ridge
	
        $P add $P.toc
        $P add $P.help
        ::Help::CreateTOC $P.toc
        ::Help::CreateHelp $P.help
    } else {
        set state(haveTOC) 0
        frame $P
        pack $P -side top -fill both -expand 1
        ::Help::CreateHelp $P
    }

    bind $TOP <Command-W> [list wm withdraw $TOP]
    bind $TOP <Command-w> [list wm withdraw $TOP]

}
##+##########################################################################
#
# ::Help::CreateTOC -- Creates a TOC display from tile's treeview widget
#
proc ::Help::CreateTOC {TOC} {
    variable W
    
    set W(tree) $TOC.tree
    scrollbar $TOC.sby -orient vert -command "$W(tree) yview"
    #scrollbar $TOC.sbx -orient hori -command "$W(tree) xview"
    
    ::ttk::treeview $W(tree) -padding {0 0 0 0} -selectmode browse \
        -yscrollcommand "$TOC.sby set"  ;#$ -xscrollcommand "$TOC.sbx set" 
    
    grid $W(tree) $TOC.sby -sticky news
    #grid $TOC.sbx -sticky ew
    grid rowconfigure $TOC 0 -weight 1
    grid columnconfigure $TOC 0 -weight 1
    
    $W(tree) heading #0 -text "Table of Contents"
    $W(tree) tag configure link -foreground blue
    # NB. binding to buttonpress sometimes "misses" clicks
    #$W(tree) tag bind link <ButtonPress> ::Help::ButtonPress
    bind $W(tree) <<TreeviewSelect>> ::Help::TreeviewSelection
    ::Help::BuildTOC
}
##+##########################################################################
#
# ::Help::CreateHelp -- Creates our main help widget
#
proc ::Help::CreateHelp {w} {
    variable W
    variable font
    
    set W(main) $w.t
    text $w.t -border 5 -relief flat -wrap word -state disabled -width 60 \
        -yscrollcommand "$w.s set" -padx 5 -font $font
    scrollbar $w.s -orient vert -command "$w.t yview"
    pack $w.s -fill y -side right
    pack $w.t -fill both -expand 1 -side left
    
    $w.t tag config link -foreground blue -underline 1
    $w.t tag config seen -foreground purple4 -underline 1
    $w.t tag bind link <Enter> "$w.t config -cursor pointinghand"
    $w.t tag bind link <Leave> "$w.t config -cursor {}"
    $w.t tag bind link <1> "::Help::Click $w.t %x %y"
    $w.t tag config hdr -font {-size 18}
    $w.t tag config fix -font \
        "[font actual [$w.t cget -font]] -family Courier"
    $w.t tag config bold -font \
        "[font actual [$w.t cget -font]] -weight bold"
    $w.t tag config italic -font \
        "[font actual [$w.t cget -font]] -slant italic"
    
    set l1 [font measure $font "   "]
    set l2 [font measure $font "   \u2022   "]
    set l3 [font measure $font "       \u2013   "]
    set l3 [expr {$l2 + ($l2 - $l1)}]
    $w.t tag config bullet -lmargin1 $l1 -lmargin2 $l2
    $w.t tag config number -lmargin1 $l1 -lmargin2 $l2
    $w.t tag config dash -lmargin1 $l1 -lmargin2 $l2
    
    bind $w.t <n> [list ::Help::Next $w.t 1]
    bind $w.t <p> [list ::Help::Next $w.t -1]
    bind $w.t <b> [list ::Help::Back $w.t]
    bind $w.t <Key-space> [bind Text <Key-Next>]
    
    # Create the bitmap for our bullet
    if {0 && [lsearch [image names] ::img::bullet] == -1} {
        image create bitmap ::img::bullet -data {
            #define bullet_width  11
            #define bullet_height 9
            static char bullet_bits[] = {
                0x00,0x00, 0x00,0x00, 0x70,0x00, 0xf8,0x00, 0xf8,0x00,
                0xf8,0x00, 0x70,0x00, 0x00,0x00, 0x00,0x00
            };
        }
    }
}
##+##########################################################################
#
# ::Help::Click -- Handles clicking a link on the help page
#
proc ::Help::Click {w x y} {
    set range [$w tag prevrange link "[$w index @$x,$y] + 1 char"]

    if {[tk windowingsystem] eq "aqua"} {
	package require launcher
    	if {[llength $range] && [regexp "http*" [eval $w get $range]]} { 
    	    launcher::launchurl [eval $w get $range]
    	    return
    	}
    	if {[llength $range] &&  [regexp "@" [eval $w get $range]]} {

    	    set mail [eval $w get $range]
    	    launcher::launchurl "mailto:$mail"
    	    return
    	}
    }

    if {[llength $range]} {::Help::Show [eval $w get $range]}
    
}
##+##########################################################################
#
# ::Help::Back -- Goes back in help history
#
proc ::Help::Back {w} {
    variable state
    
    set l [llength $state(history)]
    if {$l <= 1} return
    set last [lindex $state(history) [expr {$l-2}]]
    set history [lrange $state(history) 0 [expr {$l-3}]]
    ::Help::Show $last
    
}
##+##########################################################################
#
# ::Help::Next -- Goes to next help page
#
proc ::Help::Next {w dir} {
    variable state
    
    set what $state(all)
    if {$state(allTOC) ne {}} {set what $state(allTOC)} ;# TOC order if we can
    
    set n [lsearch -exact $what $state(current)]
    set n [expr {($n + $dir) % [llength $what]}]
    set next [lindex $what $n]
    ::Help::Show $next
    
}
##+##########################################################################
#
# ::Help::Listpage -- Puts up a help page with a bunch of links (all or history)
#
proc ::Help::Listpage {w llist} {
    foreach i $llist {$w insert end \n; ::Help::Showlink $w $i}
}
##+##########################################################################
#
# ::Help::Search -- Creates search help page
#
proc ::Help::Search {w} {
    $w insert end "\nSearch phrase:      "
    entry $w.e -textvar ::Help::state(search)
    $w window create end -window $w.e
    focus $w.e
    $w.e select range 0 end
    bind $w.e <Return> "::Help::DoSearch $w"
    button $w.b -text "Search Help" -command "::Help::DoSearch $w"
    $w window create end -window $w.b
}
##+##########################################################################
#
# ::Help::DoSearch -- Does actual help search
#
proc ::Help::DoSearch {w} {
    variable pages
    variable state
    
    $w config -state normal
    $w insert end "\n\nSearch results for '$state(search)':\n"
    foreach i $state(all) {
        if {[regexp -nocase $state(search) $i]} { ;# Found in title
            $w insert end \n
            ::Help::Showlink $w $i
        } elseif {[regexp -nocase -indices -- $state(search) $pages($i) pos]} {
            set p1 [expr {[lindex $pos 0]-20}]
            set p2 [expr {[lindex $pos 1]+20}]
            regsub -all \n [string range $pages($i) $p1 $p2] " " context
            $w insert end \n
            ::Help::Showlink $w $i
            $w insert end " - ...$context..."
        }
    }
    $w config -state disabled
}
##+##########################################################################
#
# ::Help::Showlink -- Displays link specially
#
proc ::Help::Showlink {w link {tag {}}} {
    variable state
    
    set tag [concat $tag link]
    set title [::Help::FindPage $link]
    if {[lsearch -exact $state(seen) $title] > -1} {
        lappend tag seen
    }

    if {[lsearch [image names] $link] >= 0} {
	set end0 [$w index end]
        $w insert end "\n"
        $w image create end -image $link
        $w insert end "\n"
	return
    }
    
    $w insert end $link $tag
}


##+##########################################################################
#
# ::Help::FindPage -- Finds actual pages given a possible alias
#
proc ::Help::FindPage {title} {
    variable pages
    variable alias
    
    if {[info exists pages($title)]} { return $title }
    set title2 [string tolower $title]
    if {[info exists alias($title2)]} { return $alias($title2) }
    return "ERROR!"
}
##+##########################################################################
#
# ::Help::Show -- Shows help or meta-help page
#
proc ::Help::Show {title} {
    variable pages
    variable alias
    variable state
    variable W
    
    set w $W(main)
    set title [::Help::FindPage $title]
    
    if {[lsearch -exact $state(seen) $title] == -1} {lappend state(seen) $title}
    $w config -state normal
    $w delete 1.0 end
    $w insert end $title hdr "\n"
    set next 0                                  ;# Some pages have no next page
    switch -- $title {
        Back    { ::Help::Back $w; return}
        History { ::Help::Listpage $w $state(history)}
        Next    { ::Help::Next $w 1; return}
        Previous { ::Help::Next $w -1; return}
        Index   { ::Help::Listpage $w $state(all)}
        Search  { ::Help::Search $w}
        default { ::Help::ShowPage $w $title ; set next 1 }
    }
    
    # Add bottom of the page links
    $w insert end \n------\n {}
    if {! $state(haveTOC) && [info exists alias(toc)]} {
        $w insert end TOC link " - " {}
    }
    $w insert end Index link " - " {} Search link
    if {$next} {
        $w insert end " - " {} Previous link " - " {} Next link
    }
    if {[llength $state(history)]} {
        $w insert end " - " {} History link " - " {} Back link
    }
    
    $w insert end \n
    lappend state(history) $title
    $w config -state disabled
    
    set state(current) $title
    
}
##+##########################################################################
#
# ::Help::ShowPage -- Shows a text help page, doing wiki type transforms
#
proc ::Help::ShowPage {w title} {

    variable pages
    
    set endash \u2013
    set emdash \u2014
    set bullet \u2022
    
    $w insert end \n                            ;# Space down from the title
    if {! [info exists pages($title)]} {
        set lines [list "This help page is missing."]
    } else {
        set lines [split $pages($title) \n]
    }
    
    foreach line $lines {
        set tag {}
        set op1 ""
        if {[regexp {^ +([1*-]+)\s*(.*)} $line -> op txt]} {
            set op1 [string index $op 0]
            set lvl [expr {[string length $op] - 1}]
            set indent [string repeat "     " $lvl]
            if {$op1 eq "1"} {                  ;# Number
                if {! [info exists number($lvl)]} { set number($lvl) 0 }
                set tag number
                incr number($lvl)
                $w insert end "$indent $number($lvl)" $tag
            } elseif {$op1 eq "*"} {            ;# Bullet
                set tag bullet
                $w insert end "$indent $bullet " $tag
            } elseif {$op1 eq "-"} {            ;# Dash
                set tag dash
                $w insert end "$indent $endash " $tag
            }
            set line $txt
        } elseif {[string match " *" $line]} {  ;# Line beginning w/ a space
            $w insert end $line\n fix
            unset -nocomplain number
            continue
        }
        if {$op1 ne "1"} {unset -nocomplain number}
	
        while {1} {                             ;# Look for markups
            set link0 [set bold0 [set ital0 $line]]
            set n1 [regexp {^(.*?)[[](.*?)[]](.*$)} $line -> link0 link link1]
            set n2 [regexp {^(.*?)'''(.*?)'''(\s*.*$)} $line -> bold0 bold bold1]
            set n3 [regexp {^(.*?)''(.*?)''(\s*.*$)} $line -> ital0 ital ital1]
            if {$n1 == 0 && $n2 == 0 && $n3 == 0} break
	    
            set len1 [expr {$n1 ? [string length $link0] : 9999}]
            set len2 [expr {$n2 ? [string length $bold0] : 9999}]
            set len3 [expr {$n3 ? [string length $ital0] : 9999}]
	    
            if {$len1 < $len3} {
                $w insert end $link0 $tag
                ::Help::Showlink $w $link $tag
                set line $link1
            } elseif {$len2 <= $len3} {
                $w insert end $bold0 $tag $bold [concat $tag bold]
                set line $bold1
            } else {
                $w insert end $ital0 $tag $ital [concat $tag italic]
                set line $ital1
            }
        }
        $w insert end "$line\n" $tag
    }

}


##+##########################################################################
#
# ::Help::BuildTOC -- Fills in our TOC widget based on a TOC page
#
proc ::Help::BuildTOC {} {
    variable W
    variable pages
    variable state
    
    set state(allTOC) {}                        ;# All pages in TOC ordering
    if {! [winfo exists $W(tree)]} return
    set tocData $pages([::Help::FindPage toc])
    
    $W(tree) delete [$W(tree) child {}]
    unset -nocomplain parent
    set parent() {}
    
    regsub -all {'{2,}} $tocData {} tocData
    foreach line [split $tocData \n] {
        set n [regexp {^\s*(-+)\s*(.*)} $line => dashes txt]
        if {! $n} continue
	
        set isLink [regexp {^\[(.*)\]$} $txt => txt]
        set pDashes [string range $dashes 1 end]
        set parent($dashes) [$W(tree) insert $parent($pDashes) end -text $txt]
        if {$isLink} {
            $W(tree) item $parent($dashes) -tag link
	    
            set ptitle [::Help::FindPage $txt]
            if {[lsearch $state(allTOC) $ptitle] == -1} {
                lappend state(allTOC) $ptitle
            }
        }
    }
}
##+##########################################################################
#
# ::Help::ButtonPress -- Handles clicking on a TOC link
# !!! Sometimes misses clicks, so we're using TreeviewSelection instead
#
proc ::Help::ButtonPress {} {
    variable W
    
    set id [$W(tree) selection]
    set title [$W(tree) item $id -text]
    ::Help::Show $title
}
##+##########################################################################
#
# ::Help::TreeviewSelection -- Handles clicking on any item in the TOC
#
proc ::Help::TreeviewSelection {} {
    variable W
    
    set id [$W(tree) selection]
    set title [$W(tree) item $id -text]
    set tag [$W(tree) item $id -tag]
    if {$tag eq "link"} {
        ::Help::Show $title
    } else {                                    ;# Make all children visible
        set last [lindex [$W(tree) children $id] end]
        if {$last ne {} && [$W(tree) item $id -open]} {
            $W(tree) see $last
        }
    }
}
proc CenterWindow {w} {
    wm withdraw $w
    set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
               - [winfo vrootx [winfo parent $w]]]
    set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
               - [winfo vrooty [winfo parent $w]]]
    wm geom $w +$x+$y
    wm deiconify $w
}


proc ::Help::PrintHelp {w} {

    set printfile [open [file join $::env(TMPDIR) help.txt] w+]
    puts $printfile [$w.p.help.t get 1.0 end]
    close $printfile
    
    switch [tk windowingsystem] {
	"aqua" {

	    exec /usr/bin/textutil -convert html  [file join $::env(TMPDIR) help.txt] -output  [file join $::env(TMPDIR) help.html] 2>[file join $::env(TMPDIR) converterr] 
	    catch {exec /usr/sbin/cupsfilter -i "text/html" [file join $::env(TMPDIR) help.html] > [file join $::env(TMPDIR) help.pdf] 2>[file join $::env(TMPDIR) printerr]} 
	    after 100
	    cocoaprint::print [file join $::env(TMPDIR) help.pdf] $w
	}
	
	"x11" {

	    xplat::print [file join $::env(TMPDIR) help.txt]
	}
	"win32" {
	    xplat::print [file join $::env(TMPDIR) help.txt]
	}
    }
}



proc ::Help::Startup {appname} {

    variable library
    
    ::Help::ReadHelpFiles $library
    ::Help::ReadImages $library
    ::Help::Help "appname User Help"


}

package provide machelp 1.0 

package require xplat

namespace eval machelp {


    if {![info exists library]} {
	variable library [file dirname [info script]]
    }


    #set app name and version to parse help url correctly
    proc setAppName {app version} {

	variable appname
	variable appversion
	
	set appname $app
	set appversion $version

    }
    

    #open help url online
    proc userhelp {} {

	variable appname
	variable appversion
	variable library

	source [file join $machelp::library help.tcl]

    }

    #e-mail developer for assistance
    proc usermail {} { 

	variable appname
	variable appversion

	xplat::launch mailto:kw@codebykevin.com?subject=$appname
    }



    #e-mail developer for assistance
    proc appweb {} { 

	variable appname
	variable appversion

	xplat::launch http://www.codebykevin.com/$appname.html

    }

    namespace export *

}

package ifneeded machelp 1.0 [list source [file join $dir machelp.tcl]]



    

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded regproc 1.3 [list source [file join $dir regproc.tcl]]

#regproc.tcl  routines to register serial numbers

#  Copyright (C) 2015 WordTech Communications LLC

#MIT license.

package provide regproc 1.3
package require http

image create photo _unlock -data  {
    R0lGODlhGAAgAIABAAAAAP///yH+GkNyZWF0ZWQgd2l0aCBHSU1QIG9uIGEgTWFj
    ACH5BAEKAAEALAAAAAAYACAAAAJRjI+gq+jO4npQWmqsBvQenzBYVE1YQH7imWbm
    ib5xA89cPcp4uPX+DwwKh7SdbWXUGF2S5VHn6oBURWrL+lBmb6UrTpucfsE14u85
    tKZ5wkMBADs=
}

image create photo _check -data {
    R0lGODlhIAAaAIABAAQHB////yH+GkNyZWF0ZWQgd2l0aCBHSU1QIG9uIGEgTWFj
    ACH5BAEKAAEALAAAAAAgABoAAAJMjI+pCeuvgIR0yVtzuFxDDnoWGIoHWZobikUV
    2zLTA89yfLNjetY7iag1Ir4VzCFMfpI6ChOYeeJeTxVTZRBie6htEOrl2sJcsmVb
    AAA7
}

package require xplat


namespace eval regproc {

    if {![info exists library]} {
	variable library [file dirname [info script]]
    }

    #dialog before demo has expired
    proc makePitch {} {
	variable version 
	variable appname
	variable appstore

	toplevel .purchase
	wm title .purchase "Purchase $appname"
	wm resizable .purchase 0 0

	wm withdraw .purchase
	wm transient .purchase .

	wm protocol .purchase WM_DELETE_WINDOW {}

	ttk::frame .purchase.top -padding 10
	pack .purchase.top -side top -fill both -expand yes
	ttk::label .purchase.top.label -text "You are currently using a demo of $appname. This version will give you the chance to try \n$appname free of charge for 30 days. Would you like to buy $appname now?" -image _unlock -compound left -anchor n 

	pack .purchase.top.label  -side top -fill x -expand yes

	ttk::frame .purchase.bottom -padding 5
	pack .purchase.bottom -side bottom -fill both -expand yes

	ttk::frame .purchase.bottom.upper
	pack .purchase.bottom.upper -side top -fill both -expand no


	ttk::frame .purchase.bottom.lower -padding 5
	pack .purchase.bottom.lower -side bottom -fill both -expand no

	ttk::button .purchase.bottom.lower.install -text "Purchase" -default active -command "xplat::launch http://www.codebykevin.com/$appname.html; regproc::getReg; destroy .purchase"
	ttk::button .purchase.bottom.lower.cancel -text "Cancel" -command " destroy .purchase; raise ."
	pack  .purchase.bottom.lower.install .purchase.bottom.lower.cancel  -side right -fill both -expand no
	
	::tk::PlaceWindow .purchase widget .

	wm deiconify .purchase
	focus .purchase.bottom.lower.install
	after idle [list after 0 wm attributes .purchase -notify 1]

	bind all <FocusIn> [list add [list  wm attributes . -notify 0]]

    }

    #check for license, validate if found, set demo pitch if not found
    proc readLic {application version} {

	variable serial 
	variable datadir
	variable appname
	variable appversion
	variable appstore

	set appname $application
	set appversion $version

	set datadir [file join [list xplat::appconfig $appname] "Preferences"]


	if {[file exists $datadir/.lic]} {
	    file rename $datadir/.lic $datadir/$appname.lic
	    set licnum [open $datadir/$appname.lic r]
	    set serial [read $licnum]
	    close $licnum
	    return
	} else {
	    set serial "Unregistered"
	    regproc::makePitch  
	}
    }


    #write license to file
    proc setLic {} {
	variable serial
	variable serialbase
	variable datadir
	variable appname
	variable regwindow
	variable appstore

	if {$serial == ""} {
	    destroy .number
	    return
	}

	set count 20000

	for {set i 1} {$i < $count} {incr i 1} {

	    lappend serialbase [string toupper $appname]-[expr $i * 5]-[expr $i/11]-[expr $i - 1]-[string toupper [string trim [string range $appname 0 1]]]
	}
	
	set output [lsearch  -inline $serialbase $serial]
	puts $serial
	puts $output
	
	if {$output >= 0} {
	    cd $datadir
	    set lic [open $datadir/$appname.lic w]
	    puts $lic "$serial"
	    close $lic
	    tk_messageBox -icon info -title "Thank You" -message "Thank You" -detail "Thank you for registering $appname." -parent .number
	    destroy .number
	    #display window that was hidden
	    catch {wm deiconify .}

	} else {
	    tk_messageBox -icon warning -title "Incorrect Serial Number" -message "Incorrect Serial Number" -detail "Incorrect serial number. Please try again." -parent .number
	    regproc::getReg
	}
    }



    #generate license numbers
    proc genList {application} {

	variable appname
	variable regwindow
	variable appstore

	set appname $application

	set count 20000

	for {set i 1} {$i < $count} {incr i 1} {

	    lappend serialbase [string toupper $appname]-[expr $i * 5]-[expr $i/11]-[expr $i - 1]-[string toupper [string trim [string range $appname 0 1]]]
	}


	if [file exists  $::env(HOME)/[list $appname]-list] {
	    file delete  $::env(HOME)/[list $appname]-list
	}

	foreach item $serialbase {
	    split $item\n
	    set keylist [open $::env(HOME)/[list $appname]-list a]
	    puts $keylist $item
	    close $keylist
	}
    }

    #dialog to input registration number from demo prompt
    proc getReg {} {


	variable serial
	variable regwindow
	variable appstore
	variable expired
	variable appname

	toplevel .number
	wm title .number "License"
	wm resizable .number 0 0

	wm withdraw .number
	wm transient .number .

	wm protocol .number WM_DELETE_WINDOW {}

	ttk::frame .number.top -padding 10
	pack .number.top -side top -fill both -expand yes

	
	ttk::label .number.top.label -text "Please enter your serial number for $appname\nin the field below:" -image _check -compound left -anchor n -padding 10
	pack .number.top.label -side top -fill both -expand yes

	ttk::entry .number.top.entry -textvariable [namespace current]::serial
	pack .number.top.entry -side bottom -fill both -expand yes

	ttk::frame .number.bottom -padding 5
	pack .number.bottom -side bottom -fill both -expand yes

	ttk::frame .number.bottom.upper
	pack .number.bottom.upper -side top -fill both -expand no


	ttk::frame .number.bottom.lower -padding 5
	pack .number.bottom.lower -side bottom -fill both -expand no

	bind .number <Return> {regproc::setLic; destroy .number; raise .}
	ttk::button .number.bottom.lower.install -text "Register" -default active -command {regproc::setLic; destroy .number; raise .}
	ttk::button .number.bottom.lower.cancel -text "Cancel" -command "destroy .number; raise ."
	pack  .number.bottom.lower.install .number.bottom.lower.cancel  -side right -fill both -expand no
	
	::tk::PlaceWindow .number widget .

	wm deiconify .number
	focus .number.bottom.lower.install
	raise .number
	if {[tk windowingsystem] eq "aqua"} {
	    after idle [list after 0 wm attributes .number -notify 1]
	    bind all <FocusIn>  [list  wm attributes . -notify 0]
	}
    }

    namespace export *
}

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded softwareupdate 1.4 [list source [file join $dir softwareupdate.tcl]]

#softwareupdate.tcl  routines to manage spoftware updates

#  Copyright (C) 2014  WordTech Communications LLC

#Proprietary to WordTech Communications LLC. Redistribution prohibited.

package provide softwareupdate 1.4
package require http
package require tdom

namespace eval softwareupdate {

    if {![info exists library]} {
	variable library [file dirname [info script]]
    }


    variable icon
    variable appname
    
    
    proc setIcon {app} {
	
	set iconfile [file join [softwareupdate::findCurrentInstallation] "Contents" "Resources" $app.icns]

	tk::mac::iconBitmap myicon 64 64 -imageFile $iconfile
    }

    proc setAppName {name} {

	variable appname
	set appname $name
	return $appname

    }
    

    #check version of installed software
    proc checkVersion {app version} {
	variable appversion
	variable appname
	variable currentversion
	variable versionnumber
	variable appcast
	variable sparkledata
	variable changedata

	softwareupdate::setIcon $app
	softwareupdate::checkingForUpdates

	set appcast http://www.codebykevin.com/[string tolower $appname].xml
	http::config -useragent "$appname Update Check"

	set xml [http::data [http::geturl $appcast]]

	puts $xml

	if [catch {http::geturl $appcast} msg] {
	    puts "error: $msg"
	    tk_messageBox -icon info -title "" -message "Update Error!" -detail "An error occurred in retrieving update information.\nPlease try again later."
	    return
	} 

	dom parse $xml sparkledata
	set versionnumber [string trim [$sparkledata selectNodes -namespaces [list x "http://www.andymatuschak.org/xml-namespaces/sparkle"] {string(//enclosure/@x:version)}] .0]

	set changedata [$sparkledata selectNodes {string(//description/text())}]

	set minOS [$sparkledata selectNodes -namespaces [list x "http://www.andymatuschak.org/xml-namespaces/sparkle"] {string(//x:minimumSystemVersion)}]

	set hostOS [exec sw_vers -productVersion]

	if {![package vsatisfies $hostOS $minOS]} {
	    tk_messageBox -icon warning -message "Error!" -detail "$appname is not supported on Mac OS X $hostOS. The minimum supported OS version is $minOS." 
	    return
	}
	
	if {[expr $currentversion < $versionnumber]} {
	    softwareupdate::updatePitch
	} else {
	    softwareupdate::upToDate $appname $currentversion
	}
    }


    #define the current version of the software
    proc setVersion {app number} {
	variable currentversion
	variable appname
	set currentversion $number
	set appname $app
	
    }


    #get the current installation path
    proc findCurrentInstallation {} {
	variable currentinstall
	set approot [info nameofexecutable]
	set apppath [split $approot /]
	set currentinstall [join [lrange $apppath 0 [lsearch $apppath "*.app"]] / ]
	return $currentinstall

    }

    #prompt user to update: for Perl, which chokes on XML parsing from Tcl
    proc updatePitchPerl {apptitle appnumber currentapp changelog} {
	variable appname
	variable myicon
	variable changedata
	variable currentversion
	variable versionnumber
	variable changelist

	catch {destroy .updateprogress}

	catch {destroy .update}


	toplevel .update
	wm title .update "Software Update"

	wm withdraw .update

	frame .update.f -bg gray95
	pack .update.f -fill both -expand yes

	frame .update.f.top -bg gray95
	pack .update.f.top -fill both -expand yes

	label .update.f.top.i -bitmap myicon -bg gray95 -relief flat -highlightthickness 0
	pack .update.f.top.i -side left -fill both -expand yes

	frame .update.f.top.r -bg gray95
	pack .update.f.top.r -side right -fill both -expand yes

	label .update.f.top.r.title -text "A new version of $apptitle is available!" -font {-weight bold} -bg gray95 -relief flat -highlightthickness 0
	pack .update.f.top.r.title -fill both -expand yes -side top

	label .update.f.top.r.msg -text "$apptitle $appnumber is available--you have $currentapp. Would you like to download it now?" -bg gray95 -relief flat -highlightthickness 0
	pack .update.f.top.r.msg -fill both -expand yes -side top

	label .update.f.top.r.release -text "Release Notes:" -font {-weight bold} -relief flat -highlightthickness 0 -bg gray95 
	pack .update.f.top.r.release -side top -fill both -expand yes

	text .update.f.top.r.text -font TkDefaultFont
	pack .update.f.top.r.text -side top -fill both -expand yes

	ttk::frame .update.f.top.r.bottom -padding 5
	pack .update.f.top.r.bottom -side bottom -fill both -expand yes

	ttk::button .update.f.top.r.bottom.skip -text "Skip This Version" -command {destroy .update}

	ttk::button .update.f.top.r.bottom.install -text "Install Update" -default active -command softwareupdate::installUpdate
	
	pack .update.f.top.r.bottom.install .update.f.top.r.bottom.skip  -side right  -fill both -expand yes

	set changetext [split $changelog *]

	set changetext [lrange $changetext 1 end]

	foreach item $changetext {
	    
	    .update.f.top.r.text insert end "* $item\n"

	}

	.update.f.top.r.text configure -state disabled

	wm resizable .update 0 0
	wm deiconify .update
	raise .update
	wm transient .update .

    }

    #prompt user to update
    proc updatePitch {} {
	variable appname
	variable myicon
	variable changedata
	variable currentversion
	variable versionnumber

	catch {destroy .updateprogress}

	catch {destroy .update}
	
	toplevel .update
	wm title .update "Software Update"

	wm withdraw .update

	frame .update.f -bg gray95
	pack .update.f -fill both -expand yes

	frame .update.f.top -bg gray95
	pack .update.f.top -fill both -expand yes

	label .update.f.top.i -bitmap myicon -bg gray95 -relief flat -highlightthickness 0
	pack .update.f.top.i -side left -fill both -expand yes

	frame .update.f.top.r -bg gray95
	pack .update.f.top.r -side right -fill both -expand yes

	label .update.f.top.r.title -text "A new version of $appname is available!" -font {-weight bold} -bg gray95 -relief flat -highlightthickness 0
	pack .update.f.top.r.title -fill both -expand yes -side top

	label .update.f.top.r.msg -text "$appname $versionnumber is available--you have $currentversion. Would you like to download it now?" -font {-size 10} -bg gray95 -relief flat -highlightthickness 0
	pack .update.f.top.r.msg -fill both -expand yes -side top

	label .update.f.top.r.release -text "Release Notes:" -font {-size 10 -weight bold} -relief flat -highlightthickness 0 -bg gray95 
	pack .update.f.top.r.release -side top -fill both -expand yes

	text .update.f.top.r.text -font TkDefaultFont
	pack .update.f.top.r.text -side top -fill both -expand yes

	ttk::frame .update.f.top.r.bottom -padding 5
	pack .update.f.top.r.bottom -side bottom -fill both -expand yes

	ttk::button .update.f.top.r.bottom.skip -text "Skip This Version" -command {destroy .update}

	ttk::button .update.f.top.r.bottom.install -text "Install Update" -default active -command softwareupdate::installUpdate
	
	pack .update.f.top.r.bottom.install .update.f.top.r.bottom.skip  -side right  -fill both -expand yes

	.update.f.top.r.text insert end $changedata

	.update.f.top.r.text configure -state disabled

	wm resizable .update 0 0
	wm deiconify .update
	raise .update
	wm transient .update .

    }


    #"busy" dialog
    proc checkingForUpdates {} {

	variable appname

	catch {destroy .updateprogress}

	toplevel .updateprogress 
	wm title .updateprogress "Updating $appname"

	wm withdraw .updateprogress
	update idletasks

	ttk::frame .updateprogress.f -padding 5
	pack .updateprogress.f -fill both -expand yes

	label .updateprogress.f.l -bg gray95 -bitmap myicon -bd 0 -relief flat -highlightthickness 0
	pack .updateprogress.f.l -side left -fill both -expand yes

	frame .updateprogress.f.r -bg gray95 -bd 0 -highlightcolor gray95
	pack .updateprogress.f.r -side right -fill both -expand yes
	
	
	ttk::label .updateprogress.f.r.t -text "Checking for updates..." -padding 5
	pack .updateprogress.f.r.t -side top -fill both -expand yes

	ttk::frame .updateprogress.f.r.f -padding 5
	pack .updateprogress.f.r.f -side top -fill both -expand yes
	
	ttk::progressbar .updateprogress.f.r.f.progress -mode indeterminate -orient horizontal
	pack .updateprogress.f.r.f.progress -fill both -expand yes -side top

	.updateprogress.f.r.f.progress start

	ttk::button .updateprogress.f.r.f.b -text "Cancel" -command {destroy .updateprogress}

	pack .updateprogress.f.r.f.b -side bottom -fill both -expand no

	wm geometry .updateprogress 400x100
	wm resizable .updateprogress 0 0

	wm deiconify .updateprogress
	raise .updateprogress

	wm transient .updateprogress .

    }

    #dialog if current version is installed
    proc upToDate {name number} {

	catch {destroy .updateprogress}

	tk_messageBox  -icon info -message "You're up to date!" -detail "$name $number is the currently the newest version available."


    }

    #show progress of installation
    proc progressDialog {} {

	variable appname
	variable status

	catch {destroy .downloadprogress}

	toplevel .downloadprogress
	wm title .downloadprogress "Updating $appname"

	wm transient .downloadprogress .

	label .downloadprogress.label -bitmap myicon   -anchor w -bg gray95 -highlightthickness 0

	pack .downloadprogress.label -side left -fill both -expand yes


	ttk::frame .downloadprogress.frame -padding 5
	pack .downloadprogress.frame -side right -fill both -expand yes

	ttk::label .downloadprogress.frame.l -textvariable softwareupdate::status -width 40 -text ""
	pack .downloadprogress.frame.l -side top -fill both -expand yes

	ttk::progressbar .downloadprogress.frame.bar -mode indeterminate -orient horizontal  -maximum 100
	pack .downloadprogress.frame.bar -side top -fill both -expand yes

	.downloadprogress.frame.bar start
	update

	ttk::button .downloadprogress.frame.b -text "Cancel" -command {destroy .updateprogress}
	pack .downloadprogress.frame.b -side right -fill both -expand no

	wm geometry .downloadprogress 400x100
	wm resizable .downloadprogress 0 0
	
    }

    #download and install the update
    proc installUpdate {} {
	variable currentinstall
	variable status
	variable appname

	catch {destroy .update}

	softwareupdate::findCurrentInstallation

	variable appname
	variable status


	softwareupdate::progressDialog
	set status "Downloading update for $appname"
	#use curl because http module seems broken especially when called from Perl; also use /tmp because Perl doesn't like env(TMPDIR)
	catch {exec curl http://www.codebykevin.com/updates/[list $appname].tgz >/tmp/$appname.tgz}
	update
	after 1000
	cd /tmp
	set status "Unpacking update for $appname"
	update
	after 1000
	catch {exec tar xvfz [list $appname].tgz}
	set status "Ready to install"
	.downloadprogress.frame.bar configure -mode determinate
	.downloadprogress.frame.bar configure -value 100
	.downloadprogress.frame.bar stop
	destroy .downloadprogress.frame.b 
	pack [ttk::button .downloadprogress.frame.b -text "Install and Relaunch" -command softwareupdate::launchUpdate] -side right -fill both -expand no
	return
    }


    #launch the update
    proc launchUpdate {}  {

	variable currentinstall
	variable appname

	catch {destroy .downloadprogress}

	if {[catch {exec codesign -v /tmp/$appname.app} msg]} {
	    bgerror $msg
	    tk_messageBox -icon warning -message "Error!" -detail "An error occurred in the installation of $appname. Please try again later."
	    return
	} else {

	    file rename -force $currentinstall [file join /Users [exec whoami] .Trash [file tail $currentinstall]]

	    file rename -force /tmp/$appname.app $currentinstall

	    exec $currentinstall/Contents/MacOS/$appname &

	    exit
	}

    }

    namespace export *

}

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xpla 1.0 [list source [file join $dir xplat.tcl]]

#xplat.tcl: utility shell routines for cross-platform applications. Execute appropriate platform-specific shell command for specified call.

#(c) 2015 Kevin Walzer/WordTech Communications LLC. License: standard Tcl license, http://www.tcl.tk/software/tcltk/license.html

package provide xplat 1.0

namespace eval xplat {

    #print text files: HTML and image files not supported
    proc print {filename} {

	switch [tk windowingsystem] {

	    "x11" {
		exec lpr [list $filename]
	    }
	    "win32" {
		auto_execok start  /min notepad /p [list $filename]
	    }
	    
	    "aqua" {
		exec lpr [list $filename]
	    }
	}
    }


    #launch file with system default application
    proc launch {filename} {
	switch [tk windowingsystem] {

	    "x11" {
		exec xdg-open [list $filename]
	    }
	    "win32" {
		auto_execok start {} [list $filename]
	    }
	    
	    "aqua" {
		exec open $filename
	    }
	}
    }

    #keyboard accelerator key
    proc controlkey {} {
	
	switch [tk windowingsystem] {

	    "x11" {
		return "Control"
	    }
	    "win32" {
		return "Control"
	    }
	    
	    "aqua" {
		return "Command"
	    }   
	}
    }

    #system location for storing app data
    proc appconfig {appname} {
	switch [tk windowingsystem] {

	    "x11" {
		return [file join $::env(HOME) "." [string tolower [list $appname]]]
	    }
	    "win32" {
		return [file join $::env(APPDATA) [list $appname]]
	    }
	    
	    "aqua" {
		[file join $::env(HOME) "Library" "Application Support" [list $appname]]
	    }   
	}
    }

    #manipulate appeareance of app icon
    proc seticon {win imgpath} {
	switch [tk windowingsystem] {

	    "x11" {
		return [wm iconphoto $win $imgpath]
	    }
	    "win32" {
		return [wm iconphoto $win $imgpath]
	    }
	    
	    "aqua" {
		package require tkdock
		tkdock::switchIcon $imgpath
	    }   
	}
    }
    
    #manipulate appeareance of app icon
    proc seticon {win imgpath} {
	switch [tk windowingsystem] {

	    "x11" {
		return [wm iconphoto $win $imgpath]
	    }
	    "win32" {
		return [wm iconphoto $win $imgpath]
	    }
	    
	    "aqua" {
		package require tkdock
		tkdock::origIcon
	    }   
	}
    }


    namespace export *

}