diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 7bf4bf7c..9c330abb 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu @values -min 0 -max 0 }] proc sgr_cache {args} { - set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache] + set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] diff --git a/src/bootsupport/modules/punk/args-0.2.1.tm b/src/bootsupport/modules/punk/args-0.2.1.tm index 088f1a33..beb0bc9f 100644 --- a/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/bootsupport/modules/punk/args-0.2.1.tm @@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args { variable id_cache_rawdef set defspace "" if {[dict exists $rawdef_cache_about $args]} { - set cinfo [dict get $rawdef_cache_about $args] + set cinfo [dict get $rawdef_cache_about $args] set id [dict get $cinfo -id] set is_dynamic [dict get $cinfo -dynamic] if {[dict exists $cinfo -defspace]} { @@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args { #test the rawdef for @dynamic directive proc rawdef_is_dynamic {rawdef} { #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}] if {$flagged_dynamic} { return true } @@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args { #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" set maxloop 10 ;#failsafe - while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} { + while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} { #looks like a script - haven't gone up far enough? #(e.g patternpunk oo system: >punk . poses -invalidoption) incr call_level -1 @@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args { if {$use_table} { append errmsg \n } else { - if {($returntype in {table tableobject}) && !$has_textblock} { + if {!$has_textblock && ($returntype in {table tableobject})} { append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n } else { append errmsg \n @@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args { variable parse_cache [dict create] proc parse {args} { #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef if {[llength $args] < 3} { #error "punk::args::parse - invalid call. < 3 args" punk::args::parse $args -cache 1 withid ::punk::args::parse @@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args { } } #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals + #set values $opts_and_vals #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + #set tailtype [lindex $values 0] ;#withid|withdef + #set tailargs [lrange $values 1 end] + set tailtype [lpop opts_and_vals 0] - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} #Default the -errorstyle to standard # (slow on unhappy path - but probably clearest for playing with new APIs interactively) @@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args { } switch -- $tailtype { withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] + #JJJ + #set id [lindex $opts_and_vals 0] + set deflist [raw_def [lindex $opts_and_vals 0]] if {[llength $deflist] == 0} { + if {[llength $opts_and_vals] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } error "punk::args::parse - no such id: $id" } } withdef { - set deflist $tailargs + set deflist $opts_and_vals if {[llength $deflist] < 1} { error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" } default { error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" @@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args { proc get_dict {deflist rawargs args} { #see arg_error regarding considerations around unhappy-path performance - if {![punk::args::lib::string_is_dict $args]} { - error "punk::args::get_dict args must be a dict of option value pairs" - } set defaults [dict create\ -form *\ ] + #if {![punk::args::lib::string_is_dict $args]} { + # error "punk::args::get_dict args must be a dict of option value pairs" + #} set proc_opts [dict merge $defaults $args] dict for {k v} $proc_opts { switch -- $k { @@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args { #define will either return a permanently cached argspecs (-dynamic 0) - or # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info # ----------------------------------------------- # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars + #tcl::dict::with argspecs {} ;#turn keys into vars #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names # ----------------------------------------------- + #we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with + set FORMS [dict get $argspecs FORMS] + set form_names [dict get $argspecs form_names] + + set opt_form [dict get $proc_opts -form] if {$opt_form eq "*"} { set selected_forms $form_names @@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args { #todo - handle multiple fids? set fid [lindex $selected_forms 0] set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + # formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED + # LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED + # LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES + # OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS + # VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS + # VAL_CHECKS_DEFAULTS FORMDISPLAY + + #tcl::dict::with formdict {} + ##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + #individual var extraction is faster than 'dict with' - even though we need nearly every key + set ARG_INFO [dict get $formdict ARG_INFO] + set ARG_CHECKS [dict get $formdict ARG_CHECKS] + + set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS] + set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED] + set LEADER_NAMES [dict get $formdict LEADER_NAMES] + set LEADER_MIN [dict get $formdict LEADER_MIN] + set LEADER_MAX [dict get $formdict LEADER_MAX] + set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO] + set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED] + set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS] + set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS] + + set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS] + set OPT_REQUIRED [dict get $formdict OPT_REQUIRED] + set OPT_NAMES [dict get $formdict OPT_NAMES] + set OPT_ANY [dict get $formdict OPT_ANY] + #set OPT_MIN [dict get $formdict OPT_MIN] + set OPT_MAX [dict get $formdict OPT_MAX] + #set OPT_SOLOS [dict get $formdict OPT_SOLOS] + set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] + set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] + #set OPT_GROUPS [dict get $formdict OPT_GROUPS] + + set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS] + set VAL_REQUIRED [dict get $formdict VAL_REQUIRED] + set VAL_NAMES [dict get $formdict VAL_NAMES] + set VAL_MIN [dict get $formdict VAL_MIN] + set VAL_MAX [dict get $formdict VAL_MAX] + set VAL_UNNAMED [dict get $formdict VAL_UNNAMED] + set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS] + set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS] + + set FORMDISPLAY [dict get $formdict FORMDISPLAY] + if {$VAL_MIN eq ""} { set valmin 0 #set VAL_MIN 0 @@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args { # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) # e.g -types {a ?xxx?} #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] set clause_length 0 - foreach t $typelist { + #for each t in typelist + foreach t [dict get $ARG_INFO $v -type] { if {![string match {\?*\?} $t]} { incr clause_length } @@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args { #REVIEW - what about optional members in leaders e.g -type {int ?double?} set named_leader_args_max 0 foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] + incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]] } #set id [dict get $argspecs id] @@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args { #} set can_have_leaders 1 ;#default assumption - if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} { + if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} { set can_have_leaders 0 } @@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args { if {$OPT_MAX ne "0"} { foreach t $leader_type { set raw [lindex $rawargs $tentative_idx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set flagname $raw if {[string match --* $raw]} { @@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args { # and only for the last defined leader. This should be done in the definition parsing - not here. foreach t $leader_type { set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set matchopt [::tcl::prefix::match -error {} $all_opts $raw] @@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args { set leadermin $LEADER_MIN } if {$LEADER_MAX eq ""} { - if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} { + if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} { set leadermax 0 } else { set leadermax -1 @@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args { } if {$VAL_MAX eq ""} { - if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} { + if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} { set valmax 0 } else { set valmax -1 @@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args { #assert leadermax leadermin are numeric #assert - remaining_rawargs has been reduced by leading positionals - set opts [dict create] ;#don't set to OPT_DEFAULTS here + #beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true) + #set opts [dict create] ;#don't set to OPT_DEFAULTS here + set opts [list] + set leaders [list] set arglist {} @@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args { #valmin, valmax #puts stderr "remaining_rawargs: $remaining_rawargs" #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { + if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} { #contains at least one possible flag set maxidx [expr {[llength $remaining_rawargs] -1}] if {$valmax == -1} { @@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args { break } set a [lindex $remaining_rawargs $i] - switch -glob -- $a { - -- { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } - --* { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= 2} { + #only allow longopt-style = for double leading dash longopts + #--*= 2} { + if {$eposn > 2 && [string match --* $a]} { #only allow longopt-style = for double leading dash longopts #--*=>>>==== $opts" + #puts ">>>>====opts: $opts" set seen_pks [list] #treating opts as list for this loop. foreach optset $OPT_NAMES { @@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $leadername -optional]} { puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?" incr ldridx -1 set leadername_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$leadername ni $leadernames_received} { #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." @@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could use break? continue } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { + if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset leaders_dict $leadername @@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $valname -optional]} { #error 333 puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" incr validx -1 set valname_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$valname ni $valnames_received} { #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." @@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could break? continue } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { + if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset values_dict $vname @@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args { #puts " >>>>>>> ---lookup_optset :$lookup_optset" #puts "---argstate:$argstate" #JJJ argname_or_ident; ident example: -increasing|-SORTOPTION + + #review - ensure all possible keys present in thisarg_keys + + set pkoverride [Dict_getdef $argstate -parsekey ""] + tcl::dict::for {argname_or_ident value_group} $opts_and_values { # #parsekey: key used in resulting leaders opts values dictionaries @@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args { #get full option name such as -fg|-foreground from non-alias name such as -foreground #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined set argname [dict get $lookup_optset $argname_or_ident] - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args { } } else { set argname $argname_or_ident - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args { #an example argname_or_compound for the above might be: -path|--filename # where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] + #using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict + set typelist [tcl::dict::get $thisarg -type] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + #set validationtransform [tcl::dict::get $thisarg -validationtransform] + set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { set defaultval [tcl::dict::get $thisarg -default] } - set typelist [tcl::dict::get $thisarg -type] set clause_size [llength $typelist] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set validationtransform [tcl::dict::get $thisarg -validationtransform] #JJJJ @@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args { set vlist_original $vlist ;#retain for possible final strip_ansi #review - validationtransform - if {$is_validate_ansistripped} { + if {[llength $vlist] && $is_validate_ansistripped} { #validate_ansistripped 1 package require punk::ansi set vlist_check [list] @@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args { set vlist_typelist_validate [list] #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$parsekey in $receivednames && $has_choices} { + if {$has_choices && $parsekey in $receivednames} { #-choices must also work with -multiple #todo -choicelabels set choiceprefix [tcl::dict::get $thisarg -choiceprefix] @@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args { set vlist [list] set vlist_check_validate [list] } else { - if {[llength $vlist] && $has_default} { + if {$has_default && [llength $vlist]} { #defaultval here is a value for the entire clause. (clause usually length 1) #J2 #set vlist_validate [list] #set vlist_check_validate [list] - set tp [dict get $thisarg -type] - set clause_size [llength $tp] + #set tp [dict get $thisarg -type] + set clause_size [llength $typelist] foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist { #JJJJ #REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation? @@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args { } } - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach clause_value $vlist { - foreach e $clause_value { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + if {[llength $vlist]} { + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {!$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach clause_value $vlist { + foreach e $clause_value { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } } } } - } - #puts "argname:$argname v:$v is_default:$is_default" - #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value - #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. - #arguments that are at their default are not subject to type and other checks + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] #$t = clause column #for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {} @@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args { } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident $stripped_list - } - option { - tcl::dict::set opts $argname_or_ident $stripped_list - } - value { - tcl::dict::set values_dict $argname_or_ident $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {$is_multiple} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident $stripped_list + } + option { + tcl::dict::set opts $argname_or_ident $stripped_list + } + value { + tcl::dict::set values_dict $argname_or_ident $stripped_list + } } - value { - tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } } } } + } + } set finalopts [dict create] diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 2ce845d7..c64720d2 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1329,7 +1329,7 @@ namespace eval punk::console { "Omit or pass empty string to query current echo state." }] proc echo {args} { - set argd [punk::args::parse $args withid ::punk::console::local::echo] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo] set onoff [dict get $argd values onoff] set is_windows [string equal "windows" $::tcl_platform(platform)] @@ -1835,7 +1835,7 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc dec_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -1881,7 +1881,7 @@ namespace eval punk::console { } #todo - should accept multiple mode nums/names at once proc dec_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1927,7 +1927,7 @@ namespace eval punk::console { }] } proc dec_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1990,7 +1990,7 @@ namespace eval punk::console { }] } proc dec_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode] lassign [dict values $argd] leaders opts values received set console [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2061,7 +2061,7 @@ namespace eval punk::console { "Match code or name" }] proc dec_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes] lassign [dict values $argd] leaders opts values received set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2241,7 +2241,7 @@ namespace eval punk::console { }] } proc ansi_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode] lassign [dict values $argd] leaders opts values received set console [dict get $opts -console] set num_or_name [dict get $values mode] @@ -2314,7 +2314,7 @@ namespace eval punk::console { }] } proc ansi_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2361,7 +2361,7 @@ namespace eval punk::console { }] } proc ansi_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2427,7 +2427,7 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc ansi_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2469,7 +2469,7 @@ namespace eval punk::console { "Match code or name" }] proc ansi_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes] lassign [dict values $argd] leaders opts values received set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2716,7 +2716,7 @@ namespace eval punk::console { name -type string }] proc dec_request_setting {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_request_setting] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting] lassign [dict values $argd] leaders opts values set console [dict get $opts -console] set name [dict get $values name] diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 8d82916a..36db6d56 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -4815,7 +4815,7 @@ tcl::namespace::eval textblock { 123456789ABCDEF " -size -type integer\ - -default 15\ + -default 16\ -optional 1\ -range {1 ""} -direction -default horizontal\ @@ -4946,6 +4946,7 @@ tcl::namespace::eval textblock { for {set r 0} {$r < $size} {incr r} { append block [::join $charsubset ""] \n } + set block [tcl::string::trimright $block \n] if {[llength $colour]} { set block [a+ {*}$colour]$block$RST } @@ -7843,7 +7844,7 @@ tcl::namespace::eval textblock { } } proc frame_cache {args} { - set argd [punk::args::parse $args withid ::textblock::frame_cache] + set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache] set action [dict get $argd values action] variable frame_cache set all_values_dict [dict get $argd values] diff --git a/src/modules/#modpod-gridplus-999999.0a1.0/LICENSE.GRIDPLUS b/src/modules/#modpod-gridplus-999999.0a1.0/LICENSE.GRIDPLUS new file mode 100644 index 00000000..668f818b --- /dev/null +++ b/src/modules/#modpod-gridplus-999999.0a1.0/LICENSE.GRIDPLUS @@ -0,0 +1,36 @@ +This software (GRIDPLUS) is Copyright (c) 2004-2015 by Adrian Davis (adrian@satisoft.com). + +The author hereby grants 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. \ No newline at end of file diff --git a/src/modules/#modpod-gridplus-999999.0a1.0/gridplus-999999.0a1.0.tm b/src/modules/#modpod-gridplus-999999.0a1.0/gridplus-999999.0a1.0.tm new file mode 100644 index 00000000..00eb9215 --- /dev/null +++ b/src/modules/#modpod-gridplus-999999.0a1.0/gridplus-999999.0a1.0.tm @@ -0,0 +1,6873 @@ +#========================================================================# +# SCRIPT : gridplus.tcl # +# PURPOSE: Gridplus layout manager. # +# AUTHOR : Adrian Davis # +# : Incudes code from tile "combobox.tcl" by Joe English. # +# VERSION: 2.11 # +# DATE : 27/11/2015 # +#------------------------------------------------------------------------# +# HISTORY: 2.0 07/10/2006 - First release of Tile based GRIDPLUS. # +# : 2.1 24/02/2007 - Enchanced gpmap: Array mapping. # +# : - Documents gpinsert and gpselect. # +# : - Adds Container. # +# : - Removes special main/title condition. # +# : - Adds notebook "-command" option. # +# : - Fix tablelist sort problem. # +# : - Adds text "-font" option. # +# : 2.2 22/07/2007 - Change gpmap to set dropdown value not list.# +# : - Adds "-icons" option for tree. # +# : - Fix padding problem in layout. # +# : - Fix "container". # +# : - Changes "gridplus window" for container. # +# : 2.3 15/05/2008 - Adds Find dialog to text pop-up menu. # +# : - Adds "-labelanchor" option. # +# : - Adds "-validateauto" option. # +# : - Adds "-validate" for tablelist/tree. # +# : - Adds option to specify an event to "-ecmd". # +# : - Adds option to fix maximum entry characters.# +# : - Adds "popup" validation error messages. # +# : - Adds "?!" help text set to validation text. # +# : - Adds menu "underline" option. # +# : - Adds gpfind_dialog. # +# : - Adds gpfind, gpclear, gpcut, gpcopy and # +# : gppaste. # +# : - Adds "-topmost" option to "gridplus window".# +# : - Adds "-columnformat & -cfmt". # +# : - Change menu "=" as separator. # +# : - Change menu allow "~" to indicate command. # +# : - Fix problem with date validations. # +# : - Fix Validation in contained window problem. # +# : 2.4 05/02/2009 - Adds "-columnstretch". # +# : - Adds "-basename". # +# : - Adds new syntax for embedded grids. # +# : - Adds #style" widget option. # +# : - Adds radiobutton groups. # +# : - Adds "gridplus define". # +# : - Adds resize options to layout and "pack" # +# : command mode. # +# : - Adds "-command" to text - Triggered when # +# : text is modified. # +# : - Fix validate popup for toplevel windows. # +# : - Fix for "gpEditMenu" in contained windows. # +# : - Fix problem with validation for command # +# : invoked by pressing enter in entry. If a # +# : field has both a command and a validation # +# : specified, the validation will always be # +# : done when a command specified for the entry # +# : is invoked. # +# : - Fix problem setting dropdown using gpmap. # +# : - "gpselect" modified to "see" tablelist row. # +# : - Fix date validations. # +# : - Fix validation popup in notebooks. # +# : - Fix problem displaying label text when # +# : default widget is button/link/menubutton. # +# : 2.5 25/10/2009 - Adds "calendar" gridplus command mode. # +# : - Adds "dateselector" gridplus command mode. # +# : - Adds "gpnav" command. # +# : - Adds extra pre-defined entry validations. # +# : - Adds "trim:" option for entry validations. # +# : - Adds "!+" button wigdet option. # +# : - Adds "-overrideredirect" option for window. # +# : - Adds default (".") optionset. # +# : - Change gpset and gpselect to set values for # +# : "calendar" and "dateselector". # +# : - Change button widget so that Enter key will # +# : invoke the button command. # +# : - Change entry validation behaviour to work # +# : better losing focus to toplevel windows. # +# : - Fix entry validation losing focus to a # +# : toplevel window. # +# : - Fix entry validation popup messages in # +# : notebooks. # +# : - Fix "num" validation pattern. # +# : - Fix "expected integer" font problem due to # +# : Tcl/Tk bug. # +# : 2.6 23/10/2010 - Adds "single/space" option to tree. # +# : - Adds "ISO" date format. # +# : - Fix Unix container problem. # +# : 2.7 26/02/2012 - Adds option to set locale. # +# : - Adds "gpdefault" command. # +# : - Adds "gpdate" command. # +# : - Adds "=inline" entry/date default option. # +# : - Adds "tablelist" sort options. # +# : - Adds label width option. # +# : - Adds "Gridplus.optionsetDefaultStyle". # +# : - Fix date selector problem in topmost window.# +# : - Fix problem clearing radiobutton groups. # +# : - Fix modal flag clear problem. # +# : 2.8 28/03/2012 - Adds "=inline" dropdown default option. # +# : - Adds "~command" link option. # +# : - Change "checkbutton" so that the "+" option # +# : always results in a checked button. # +# : - Fix "gpset" to make sure window is updated. # +# : - Fix problem clearing "radiobutton" groups. # +# : - Fix link indent problem. # +# : - Fix gap in "theme" style border caused by # +# : ttk::labelframe bug. # +# : 2.9 04/07/2012 - Fix problem with value of tree node # +# : containing spaces. # +# : - Fix problem with "container" frame sizing. # +# : - Fix problem with some validations in # +# : "contained" toplevels. # +# : - Fix "clear" to withdraw validation pop-up # +# : message. # +# : 2.10 01/07/2013 - Adds "spinbox" gridplus command mode. # +# : - Adds "pane" gridplus command mode. # +# : - Adds "gpoptions" command. # +# : - Adds interface (and supporting procedures) # +# : to create user defined widget types for # +# : "widget" grid. # +# : - Adds "dateselector" option to display icon # +# : instead of downarrow. # +# : - Adds "-menu" option to "text". # +# : - Adds "-seeinsert" option to "text". # +# : - Adds "-seeinsert" option to "tablelist". # +# : - Adds "-takefocus" option to "tablelist". # +# : - Adds "-selectpage" option to "tablelist". # +# : - Adds "+" (focus) button widget option. # +# : - Adds new "gpselect" syntax/options. # +# : - Adds "-title" option to "gpset". # +# : - Adds "-name" option to "gpset". # +# : - Adds "gpmap" option to map to dict. # +# : - Adds Grid/Layout and Notebook command # +# : substitution. # +# : - Adds Popup/Balloon help display duration. # +# : - Change Popup/Balloon help to display at # +# : pointer position. # +# : - Change to allow "@" embedded widgets to # +# : work in embedded grids. # +# : - Change: Support for old "&w" embedded # +# : widget grid syntax removed. # +# : - Fix problem setting tablelist sort column # +# : when first column is integer/real. # +# : - Fix problem with tablelist row selection. # +# : - Fix problem with clipboard operations when # +# : widget with focus not of suitable type. # +# : - Fix problem with "gpfind" with patterns # +# : begining with "-". # +# : - Fix problem when selecting tablelist row # +# : using (Up and Down) cursor keys. # +# : - Fix menu separator problem with cascade # +# : style menus. # +# : - Code Tidy:- # +# : gpWidget rewritten/retructured/modularised. # +# : Four namespace variables eliminated. # +# : 2.11 27/11/2015 - Adds "gpdb" command. # +# : - Adds "gpdelete" command. # +# : - Adds "gpupdate" command. # +# : - Adds "gpget" command. # +# : - Adds "-save", "-restore", # +# : "-max", "-min", # +# : "-first", "-last", # +# : "-row" and "|" options to "gpselect". # +# : - Adds "-maintainsort" to "tablelist". # +# : - Adds true/false options for "tablelist" # +# : "-insertoptions". # +# : - Adds "tablelist" proc to return column # +# : values for selected row. # +# : - Adds "tablelist" "asciinocase" and # +# : "dictionary" column sort options. # +# : - Adds new "tree" "-selectfirst" option. # +# : - Adds new "tree" "-selectmode" option. # +# : - Adds widget option subsitution in embedded # +# : widget grid. # +# : - Adds new "layout" column/row weight setting # +# : syntax. # +# : - Adds new "notebook" "-padding" and # +# : "-tabpadding" options. # +# : - Adds new "grid" row "ns" stretch option. # +# : - Adds new "grid" "-attach ns" option. # +# : - Adds "buttonWidth" and "entryWidth" option # +# : database options. # +# : - Adds "gpset" "-|" dedent option. # +# : - Change "tablelist" to automatically set # +# : default column names. # +# : - Change "-insertexpr" to allow use of column # +# : names. # +# : - Change "gpselect" to allow use of column # +# : names. # +# : - Change "gpset" so that "-sortfirst" is # +# : disabled if there is a "saved" selection. # +# : - Change "gpunset" to allow patterns. # +# : - Fix "tree" keyboard traversal selection. # +# : - Fix problem with entry validation when # +# : using right-click menu in another entry. # +# : - Fix setting "checkbutton" default selected # +# : when "-state" is "disabled". # +# : - Fix "checkbutton" command options. # +# : - Fix setting "radiobutton" default selected # +# : when "-state" is "disabled". # +# : - Fix "dropdown" to use "-state" correctly. # +# : - Fix notebook pane name problem. # +# : - Fix problem with Text find dialog with # +# : patterns begining with "-". # +# : - Fix problem with "Date" clearing when # +# : "dateIcon" specified. # +########################################################################## +#unofficial JMN 2025 +#some fixes for tcl9 - explicitly reference globals + +package require Tk 8.6- + +package require msgcat +namespace import msgcat::* + +catch {package require icons} +catch {package require tablelist_tile} + +package provide gridplus 999999.0a1.0 + +#=======================================================================# +# Export the public interface. # +#=======================================================================# + +namespace eval ::gridplus:: { + namespace export gridplus + namespace export gpcopy + namespace export gpclear + namespace export gpcut + namespace export gpdate + namespace export gpdb + namespace export gpdefault + namespace export gpdelete + namespace export gpfind + namespace export gpfind_dialog + namespace export gpget + namespace export gpinsert + namespace export gpmap + namespace export gpnav + namespace export gpoptions + namespace export gppaste + namespace export gpselect + namespace export gpset + namespace export gpunset + namespace export gpupdate + variable gpWidgetHelp + variable gpConfig + variable gpInfo + variable gpOptionSets + variable gpTabOrder + variable gpValidate + variable gpValidateError + variable gpValidations +} + +#=======================================================================# +# PROC : ::gridplus::gridplus # +# PURPOSE: Exported command. # +#=======================================================================# + +proc ::gridplus::gridplus {args} { + variable gpConfig + variable gpInfo + + # If first call run initialisation. + if {! [info exists gpConfig]} { + gpInit + } + + # Set array of valid/default options. + array set options [list \ + -action none \ + -anchor [=< anchor s] \ + -autogroup [=< autoGroup] \ + -attach [=< attach] \ + -background [=< background] \ + -borderwidth [=< borderWidth 2] \ + -basename {} \ + -calcolor [=< calColor black/white] \ + -calrelief [=< calRelief flat] \ + -calselectcolor [=< calSelectColor black/gray] \ + -ccmd {} \ + -century $gpConfig(date:century) \ + -cfmt [=< columnFormat] \ + -checkbuttoncommand {} \ + -columnformat [=< columnFormat] \ + -columnsort [=< columnSort 1] \ + -command {} \ + -compound left \ + -date {} \ + -dateclear [=< dateClear 1] \ + -datecommand {} \ + -dateformat $gpConfig(dateformat) \ + -dcmd {} \ + -Dcmd {} \ + -dropdowncommand {} \ + -ecmd [=< entryCommand] \ + -entrycommand [=< entryCommand] \ + -errormessage $gpConfig(errormessage) \ + -fileicon [=< fileIcon file] \ + -fixed [=< fixed 999999] \ + -foldericon [=< folderIcon folder] \ + -font [=< font] \ + -foreground [=< foreground black] \ + -from [=< from] \ + -group {} \ + -height [=< height 10] \ + -icon [=< icon] \ + -iconfile $gpConfig(iconfile) \ + -iconpath $gpConfig(iconpath) \ + -icons [=< icons 1] \ + -in {} \ + -increment [=< increment 1] \ + -insertexpr {} \ + -insertoptions {} \ + -justify left \ + -labelanchor [=< labelAnchor] \ + -labelcolor [=< labelColor /] \ + -labelstyle [=< labelStyle /] \ + -linerelief [=< lineRelief sunken] \ + -linewidth [=< lineWidth 2] \ + -linkcolor [=< linkColor black/black] \ + -linkcursor [=< linkCursor arrow] \ + -linkstyle [=< linkStyle /underline] \ + -listvariable {} \ + -locale $gpConfig(locale) \ + -maintainsort [=< mantainSort 0] \ + -menu {} \ + -minx 100 \ + -miny 100 \ + -modal 0 \ + -names {} \ + -navbar [=< navBar 1] \ + -navcommand {} \ + -navselect [=< navSelect 0] \ + -open [=< open 0] \ + -optionset {} \ + -overrideredirect 0 \ + -pad [=< pad 5] \ + -padding [=< padding {5 5 5 5}] \ + -padx [=< padX [=< pad 5]] \ + -pady [=< padY [=< pad 5]] \ + -pattern {} \ + -prefix $gpConfig(prefix) \ + -proc $gpConfig(proc) \ + -radiobuttoncommand {} \ + -rcmd {} \ + -relief [=< relief flat] \ + -resize {} \ + -scroll none \ + -seeinsert [=< seeInsert 0] \ + -selectfirst 0 \ + -selectmode [=< selectMode browse] \ + -selectpage [=< selectPage 0] \ + -selecttoday [=< selectToday 0] \ + -show [=< show tree] \ + -sortfirst 0 \ + -sortorder increasing \ + -space [=< space 20] \ + -spacestretch {} \ + -spinformat [=< spinFormat] \ + -state normal \ + -sticky [=< sticky] \ + -stretch {} \ + -style {} \ + -subst [=< subst 1] \ + -tableoptions {} \ + -taborder column \ + -tabpadding [=< tabPadding] \ + -takefocus 1 \ + -tags 0 \ + -text {} \ + -title {} \ + -to [=< to] \ + -topmost [=< topmost 0] \ + -validate [=< validate 0] \ + -validateauto [=< validateAuto 1] \ + -validatepopup [=< validatePopup 0] \ + -validation {} \ + -variable {} \ + -variables 1 \ + -wcmd {} \ + -weekstart [=< weekStart 1] \ + -widget [=< widget grid] \ + -width [=< width 40] \ + -windowcommand {} \ + -wrap word \ + -wraplength 0 \ + -wtitle {} \ + ] + + # Read mode. + set mode [lindex $args 0] + + # Validate mode and set parameter template. + switch -- $mode { + add {set argTemplate [list "name 1" "options 2 end"]} + button {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< buttonWidth [=< widgetWidth 10]]} + calendar {set argTemplate [list "name 1" "options 2 end"]} + checkbutton {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + clear {set argTemplate [list "name 1" "options 2 end"]} + container {set argTemplate [list "name 1" "options 2 end"];set options(-height) [=< containerHeight 200];set options(-width) [=< containerWidth 250]} + date {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + define {set argTemplate [list "layout 1"]} + dropdown {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + entry {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< entryWidth [=< widgetWidth 10]]} + goto {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} + grid {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} + init {set argTemplate [list "options 1 end"]} + layout {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} + line {set argTemplate [list "name 1" "options 2 end"]} + link {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + menu {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} + menubutton {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + notebook {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-padding) [=< notebookPadding]} + optionset {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} + pack {set argTemplate [list "name 1" "options 2 end"]} + pane {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-height) [=< paneHeight 0];set options(-width) [=< paneWidth 0]} + radiobutton {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + set {set argTemplate [list "options 1 end"]} + spinbox {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + tablelist {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< tableWidth 40];set options(-takefocus) 0} + text {set argTemplate [list "name 1" "options 2 end"];set options(-width) [=< textWidth 40]} + tree {set argTemplate [list "name 1" "options 2 end"];set options(-width) [=< treeWidth 200];set options(-selectmode) [=< treeSelectMode extended]} + widget {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} + window {set argTemplate [list "name 1" "options 2 end"]} + default {error "GRIDPLUS ERROR: Invalid mode ($mode)."} + } + + # Check if sufficient args. + if {[llength $args] < [llength $argTemplate]} { + error "GRIDPLUS ERROR: Wrong number of Args." + } + + # Check if sufficient args remain for option/value pairs. + if {$mode ne "define" && [expr {([llength $args] - [llength $argTemplate]) % 2}] != 0} { + error "GRIDPLUS ERROR: Unmatched option/value." + } + + # Unset gpUnknown. + foreach unknownItem [array names gpInfo *] { + unset gpInfo($unknownItem) + } + + # Read/validate arguments. + foreach template $argTemplate { + set argName [lindex $template 0] + set argStart [lindex $template 1] + set argEnd [lindex $template 2] + # If argName is "options" read option/value pairs. + if {$argName eq "options"} { + foreach {option value} [lrange $args $argStart $argEnd] { + if {[info exists options($option)]} { + switch -- $option { + -pad { + set options(-padx) $value + set options(-pady) $value + } + -title { + set options(-title) $value + if {$options(-title) ne ""} { + set options(-relief) theme + } + } + default { + set options($option) $value + } + } + } else { + if {[=< unknown 1]} { + set gpInfo($option) $value + } else { + error "GRIDPLUS ERROR: Invalid option ($option)." + } + } + } + } else { + set options($argName) [lindex $args $argStart] + } + } + + # Set optionset. + gpSetOptionset + + # Remove blank lines from "layout". + if {[info exists options(layout)]} { + regsub -all -- {\n\n} $options(layout) "\n" options(layout) + regsub -all -- {(^\n)|(\n$)|(\n +$)} $options(layout) "" options(layout) + } + + # Call appropriate procedure according to specified mode. + switch -- $mode { + add {gpAdd} + button {set options(-widget) b;gpWidget} + calendar {gpCalendar} + checkbutton {set options(-widget) c;gpWidget} + clear {gpClear} + container {gpContainer} + date {set options(-widget) D;gpWidget} + define {gpDefine} + dropdown {set options(-widget) d;gpWidget} + entry {set options(-widget) e;gpWidget} + goto {gpGoto} + grid {gpGrid} + layout {gpLayout} + line {gpLine} + link {set options(-widget) l;gpWidget} + menu {gpMenu} + menubutton {set options(-widget) m;gpWidget} + notebook {gpNotebook} + optionset {gpOptionset} + pack {gpPack} + pane {gpPane} + radiobutton {set options(-widget) r;gpWidget} + set {gpSet} + spinbox {set options(-widget) s;gpWidget} + tablelist {gpTablelist} + text {gpText} + tree {gpTree} + widget {gpWidget} + window {gpWindow} + } + +} + +#=======================================================================# +# PROC : ::gridplus::gpWidget # +# PURPOSE: Create widget grid. # +#=======================================================================# + +proc ::gridplus::gpWidget {} { + upvar 1 options globaloptions + + array set options [array get globaloptions] + + global {} + + variable gpConfig + variable gpInfo + variable gpValidation + variable gpValidations + + if {$options(-fixed) eq ""} { + set defaultFixed $options(-width) + } else { + set defaultFixed $options(-fixed) + } + + if {$options(-basename) eq ""} { + set basename $options(name) + } else { + set basename $options(-basename) + } + + set defaultWidget [string range $options(-widget) 0 0] + set gridData {} + set rowCount 0 + set widgetID 1 + + if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { + set window {} + } + + foreach row [split $options(layout) "\n"] { + set columnCount 0 + foreach column $row { + set action 0 + set createWidget 0 + set errorMessage {} + set fixed $defaultFixed + set gridColumn {} + set itemFixed {} + set itemWidth {} + set state $options(-state) + set style $options(-style) + set widget $defaultWidget + set widgetHelp {} + set widgetOptions [dict create widget options] + set width $options(-width) + + if {$options(-autogroup) ne ""} {} + + set column [::gridplus::gpDefineWidget $column] + set column [::gridplus::gpParseEmbeddedGrid $column] + + foreach item $column { + switch -regexp -- $item { + + ^[&]=[a-zA-Z] { + set widget "=" + set userWidget [string range $item 2 2] + set widgetLayout [lrange $item 2 end] + regexp {^[&]=[^: ]+:([^ ]*)} $item -> style + } + ^[&] { + set widgetLayout [lrange $item 1 end] + if {! [regexp {^[&]([^: ]+):([^ ]*)} $item -> widget style]} { + set widget [lindex [string range $item 1 end] 0] + } + if {$widget eq "&" && $style eq ""} { + set style "{}" + } + if {$widget eq "d" && $options(-state) eq "normal"} { + set state readonly + } + } + ^[.] { + set createWidget 1 + if {[regexp -- {(^[.]$)|(^[.]:)} $item]} { + if {$widget eq "&"} { + regsub -- {[.]} $item $options(name)-$widgetID item + } else { + regsub -- {[.]} $item [regsub -- {([^.]+)[.]} $options(name)-$widgetID {\1_-_}] item + } + incr widgetID + } + if {! [regexp {(^[^:]+)(:[nsewc]+$)} $item -> item sticky]} {set sticky {}} + if {$widget in "g &"} { + set widgetName $item + } else { + set widgetName $basename,[string range $item 1 end] + } + if {$options(-autogroup) ne ""} {dict set widgetOptions > "::gridplus::gpAutoGroup $widgetName $options(-autogroup) normal"} + if {$options(-group) ne ""} {set gpInfo($widgetName:group) $options(-group)} + lappend gridColumn $widgetName$sticky + } + ^: { + dict set widgetOptions : [string range $item 1 end] + if {$widget in "b m"} { + if {! $createWidget} { + set createWidget 1 + set widgetName $options(name),[= $widgetOptions :] + if {$options(-group) ne ""} {set gpInfo($widgetName:group) $options(-group)} + lappend gridColumn $widgetName + } + } elseif {! $createWidget && $widget ne "l"} { + lappend gridColumn $item%% + } + } + ^[0-9]+$ { + set width $item + } + ^([0-9]*)/([0-9]*)$ { + regexp -- {^([0-9]*)/([0-9]*)$} $item -> itemWidth itemFixed + if {$itemWidth eq ""} { + set width $options(-width) + } else { + set width $itemWidth + } + if {$itemFixed eq ""} { + set fixed $width + } else { + set fixed $itemFixed + } + } + ^@ { + set gridName .[string range $item 1 end] + lappend gridColumn $gridName + } + ^% { + set gpInfo($widgetName:group) [string range $item 1 end] + } + ^[-+*~!] { + dict set widgetOptions [string range $item 0 0] [string range $item 1 end] + } + ^[?] { + set widgetHelp [mc [string range $item 1 end]] + } + ^[|]$ { + lappend gridColumn $item + } + ^[=]$ { + lappend gridColumn $item + } + ^[=].+ { + dict set widgetOptions = [string range $item 1 end] + } + ^<$ { + set state disabled + } + ^>$ { + set state normal + } + ^<.+ { + ::gridplus::gridplus set -group [string range $item 1 end] -state normal + dict set widgetOptions < "::gridplus::gpAutoGroup $widgetName [string range $item 1 end] disabled" + } + ^>.+ { + ::gridplus::gridplus set -group [string range $item 1 end] -state disabled + dict set widgetOptions > "::gridplus::gpAutoGroup $widgetName [string range $item 1 end] normal" + } + ^[#].* { + set style [string range $item 1 end] + } + default { + if {$widget in "b l m"} { + if {[llength $column] > 1} { + dict set widgetOptions text [mc $item] + } else { + lappend gridColumn $item + } + } else { + lappend gridColumn $item + } + } + } + } + + switch -glob -- $widget { + [cbdDelmrs] { + #---------------# + # Create widget # + #---------------# + if {$createWidget} { + ::gridplus::widget:$widget $widgetName $window $basename $style $width $fixed [=% $widgetName $state] $widgetOptions + } + } + [=] { + #----------------------------# + # Create user defined widget # + #----------------------------# + if {$createWidget} { + ::gridplus::widget:=$userWidget $widgetName $window $basename $style $width $fixed [=% $widgetName $state] $widgetOptions + } + } + & { + #-------------------------------# + # Create embedded "widget" grid # + #-------------------------------# + set stretch [lindex $widgetLayout 0] + set widgetWidget [lindex $widgetLayout 1] + set widgetStyle [lindex $widgetLayout 2] + set widgetLayout [lrange $widgetLayout 3 end] + if {$widgetStyle ne ""} { + if {$widgetStyle eq "%"} { + set style "{}" + } else { + set style $widgetStyle + } + } + set widgetCommand "::gridplus::gridplus widget $widgetName -basename $basename -borderwidth 0 -spacestretch [list $stretch] -pad 0 -padding {0 0 0 0} -style $style -widget $widgetWidget [list $widgetLayout]" + eval $widgetCommand + } + } + + if {$widgetHelp ne ""} { + if {$widgetHelp eq "!"} { + set widgetHelp [::gridplus::gpValidateText [= $widgetOptions !]] + } + gpWidgetHelpInit $widgetName $widgetHelp + } + + lappend gridData $gridColumn + incr columnCount + } + lappend gridData !!!! + incr rowCount + } + + regsub -all {!!!!} $gridData \n gridData + + set gridCommand "::gridplus::gridplus grid $options(name)" + + foreach option [array names options -*] { + set gridCommand "$gridCommand $option {$options($option)}" + } + + set gridCommand "$gridCommand {$gridData}" + + eval $gridCommand +} + +#=======================================================================# +# PROC : ::gridplus::widget:b # +# PURPOSE: Create button widget. # +#=======================================================================# + +proc ::gridplus::widget:b {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + variable gpInfo + + set command [= $widgetOptions ~] + set icon [= $widgetOptions :] + set text [= $widgetOptions text] + + set gpInfo($name:validationmode) force + set doValidation $options(-validate) + + if {[=? $widgetOptions !]} { + set doValidation 1 + if {[= $widgetOptions !] eq "+" } { + set gpInfo($name:validationmode) focus + } + } + + if {$command ne ""} { + set buttonCommand $command + } else { + if {[regexp -- {^([^=]*)=(.*)$} $name -> buttonCommand buttonParameter]} { + set buttonCommand "$buttonCommand $buttonParameter" + } else { + set buttonCommand "$name" + } + } + + if {$options(-proc)} { + set command "set ::gridplus::gpInfo() \[focus\];gpProc [::gridplus::gpCommandFormat $buttonCommand]" + } else { + set command "set ::gridplus::gpInfo() \[focus\];$options(-prefix)[::gridplus::gpCommandFormat $buttonCommand]" + } + + if {$icon ne ""} { + if {$text eq ""} { + ::ttk::button $name -command "::gridplus::gpCommand {$command} .$window $doValidation" -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) + } else { + ::ttk::button $name -command "::gridplus::gpCommand {$command} .$window $doValidation" -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width -compound $options(-compound) + } + } else { + ::ttk::button $name -command "::gridplus::gpCommand {$command} .$window $doValidation" -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width + } + + if {$state eq "disabled"} {$name configure -takefocus 0} + + if {[=? $widgetOptions +]} {focus $name} + + bind $name "$name invoke" +} + +#=======================================================================# +# PROC : ::gridplus::widget:c # +# PURPOSE: Create checkbutton widget. # +#=======================================================================# + +proc ::gridplus::widget:c {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + global {} + + set command [= $widgetOptions ~] + set ($name) [= $widgetOptions = [=@ $name 0]] + + set options(-checkbuttoncommand) [::gridplus::gpOptionAlias -checkbuttoncommand -ccmd] + + ::ttk::checkbutton $name -offvalue 0 -onvalue 1 -style $style -takefocus $options(-takefocus) -variable ($name) + + if {$state eq "disabled"} { + $name configure -takefocus 0 + } + + if {[=? $widgetOptions ~]} { + if {$command eq ""} { + set command $name + } + if {$options(-proc)} { + set command "gpProc [::gridplus::gpCommandFormat $command]" + } else { + set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" + } + $name configure -command $command + } elseif {$options(-checkbuttoncommand) ne ""} { + if {$options(-proc)} { + set command "gpProc $options(-checkbuttoncommand)" + } else { + set command "$options(-prefix)$options(-checkbuttoncommand)" + } + $name configure -command $command + } + + if {[=? $widgetOptions +]} { + set ($name) 0 + $name invoke + } + + $name configure -state $state +} + +#=======================================================================# +# PROC : ::gridplus::widget:d # +# PURPOSE: Create dropdown widget. # +#=======================================================================# + +proc ::gridplus::widget:d {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + global {} + + set command [= $widgetOptions ~] + set values [= $widgetOptions +] + set ($name) [= $widgetOptions = [=@ $name [lindex [= $widgetOptions +] 0]]] + + set options(-dropdowncommand) [::gridplus::gpOptionAlias -dropdowncommand -dcmd] + + ::ttk::combobox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -values $values -width $width + + if {$state eq "disabled"} { + $name configure -takefocus 0 + } + + if {[=? $widgetOptions ~]} { + if {$command eq ""} { + set command $name + } + if {$options(-proc)} { + set command "gpProc [::gridplus::gpCommandFormat $command]" + } else { + set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" + } + bind $name <> $command + } elseif {$options(-dropdowncommand) ne ""} { + if {$options(-proc)} { + set command "gpProc $options(-dropdowncommand)" + } else { + set command "$options(-prefix)$options(-dropdowncommand)" + } + bind $name <> "$command" + } +} + +#=======================================================================# +# PROC : ::gridplus::widget:D # +# PURPOSE: Create dateselector widget. # +#=======================================================================# + +proc ::gridplus::widget:D {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + variable gpInfo + + global {} + + set command [= $widgetOptions ~] + set ($name) [::gridplus::gpdate [= $widgetOptions = [=@ $name]]] + + if {$state eq "normal"} { + set state readonly + } + + set options(-datecommand) [::gridplus::gpOptionAlias -datecommand -Dcmd] + + if {[=< dateIcon] ne ""} { + if {"GridplusDate.downarrow" ni [ttk::style element names]} { + set normalIcon [=: [=< dateIcon]] + set disabledIcon [image create photo] + + ::ttk::combobox .gpComboboxHeight + set height [winfo reqheight .gpComboboxHeight] + destroy .gpComboboxHeight + + $disabledIcon copy $normalIcon + $disabledIcon configure -palette 16 -gamma 1.5 + + ::ttk::style element create GridplusDate.downarrow image [list $normalIcon disabled $disabledIcon] -height $height -sticky e + + ::ttk::style layout GridplusDate.TCombobox { + Combobox.field -sticky nswe -children { + GridplusDate.downarrow -side right -sticky ns + Combobox.padding -expand 1 -sticky nswe -children { + Combobox.textarea -sticky nswe + } + } + } + } + + set style "GridplusDate.TCombobox" + } + + ::ttk::combobox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -width $width + + bind $name "::gridplus::gpDateSelectorKeyPress $name %W post" + bind $name "::gridplus::gpDateSelectorKeyPress $name %W unpost" + bind $name "::gridplus::gpDateSelectorToggle $name %W" + bind $name "$name selection range 0 end" + bind $name "::gridplus::gpEntryEdit {} %X %Y" + + if {$options(-dateclear)} { + bind $name "::gridplus::gpDateSelectorClear $name %K" + } + + if {$state eq "disabled"} { + $name configure -takefocus 0 + } + + set gpInfo($name:datecommand) {} + + if {[=? $widgetOptions ~]} { + if {$command eq ""} { + set gpInfo($name:datecommand) $name + } + if {$options(-proc)} { + set gpInfo($name:datecommand) "gpProc [::gridplus::gpCommandFormat $command]" + } else { + set gpInfo($name:datecommand) "$options(-prefix)[::gridplus::gpCommandFormat $command]" + } + } elseif {$options(-datecommand) ne ""} { + if {$options(-proc)} { + set gpInfo($name:datecommand) "gpProc $options(-datecommand)" + } else { + set gpInfo($name:datecommand) "$options(-prefix)$options(-datecommand)" + } + } +} + +#=======================================================================# +# PROC : ::gridplus::widget:e # +# PURPOSE: Create entry widget. # +#=======================================================================# + +proc ::gridplus::widget:e {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + variable gpInfo + variable gpValidations + + global {} + + set autoGroupCommand [= $widgetOptions > [= $widgetOptions <]] + set command [= $widgetOptions ~ $name] + set validation [= $widgetOptions !] + set ($name) [= $widgetOptions = [=@ $name]] + + set options(-entrycommand) [::gridplus::gpOptionAlias -entrycommand -ecmd] + + if {$state eq "disabled"} { + set state [=< entryDisabled readonly] + } + + if {[=? $widgetOptions !]} { + set doValidation 1 + lappend gpValidations(.$window) $name:$validation + } else { + set doValidation 0 + } + + if {$validation eq ""} { + set validation "__gpFixed__" + } else { + ::gridplus::gpValidateErrorInit $name [::gridplus::gpValidateText $validation] + } + + ::ttk::entry $name -invalidcommand "::gridplus::gpValidateFailed %W" -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -validate all -validatecommand "::gridplus::gpValidate %W \"$validation\" %V %P $fixed $options(-validateauto)" -width $width + + if {$state eq "disabled"} { + $name configure -background lightgray -takefocus 0 + } + + if {[=? $widgetOptions ~]} { + if {$options(-proc)} { + set command "gpProc [::gridplus::gpCommandFormat $command]" + } else { + set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" + } + if {[string match <*> $command]} { + bind $name "event generate $name $command" + } elseif {[string match "<*> *" $command]} { + regsub -all {:} $command "." command + bind $name "event generate [lindex $command 1] [lindex $command 0]" + } else { + bind $name "::gridplus::gpCommand {$command} .$window $doValidation" + } + } elseif {$options(-entrycommand) ne ""} { + if {$options(-proc)} { + set command "gpProc $options(-entrycommand)" + } else { + set command "$options(-prefix)$options(-entrycommand)" + } + if {[string match <*> $command]} { + bind $name "event generate $name $command" + } elseif {[string match "<*> *" $command]} { + regsub -all {:} $command "." command + bind $name "event generate [lindex $command 1] [lindex $command 0]" + } else { + bind $name "::gridplus::gpCommand {$command} .$window $doValidation" + } + } + + if {$autoGroupCommand ne ""} { + trace add variable ($name) write $autoGroupCommand + } + + if {$options(-validatepopup) && $validation ne "__gpFixed__"} { + ::gridplus::gpValidateErrorInit $name [::gridplus::gpValidateText $validation] popup + } + + if {[=? $widgetOptions *]} {$name configure -show "*"} + if {[=? $widgetOptions +]} {focus $name} + + bind $name "::gridplus::gpEntryEdit {$window} %X %Y" + +} + +#=======================================================================# +# PROC : ::gridplus::widget:l # +# PURPOSE: Create link widget. # +#=======================================================================# + +proc ::gridplus::widget:l {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + set command [= $widgetOptions ~ $name] + set icon [= $widgetOptions :] + set text [= $widgetOptions text] + + foreach {normalColor overColor} [split $options(-linkcolor) /] {} + foreach {normalStyle overStyle} [split $options(-linkstyle) /] {} + + regsub -- {[&]} $overStyle $normalStyle, overStyle + regsub -all -- {,} $normalStyle { } normalStyle + regsub -all -- {,} $overStyle { } overStyle + + if {! [string match */* $options(-linkcolor)]} {set overColor $normalColor} + + if {$normalColor eq ""} {set normalColor "black"} + if {$overColor eq ""} {set overColor "black"} + + if {[=? $widgetOptions !]} { + set doValidation 1 + } else { + set doValidation 0 + } + + if {[=? $widgetOptions -]} { + set indent " " + } elseif {[=? $widgetOptions +]} { + set indent "\u2022 " + } else { + set indent "" + } + + if {$options(-proc)} { + set linkCommand "set ::gridplus::gpInfo() \[focus\];gpProc [::gridplus::gpCommandFormat $command]" + } else { + set linkCommand "set ::gridplus::gpInfo() \[focus\];$options(-prefix)[::gridplus::gpCommandFormat $command]" + } + + ::ttk::frame $name + ::ttk::label $name.link -background $options(-background) -foreground $options(-foreground) -text [mc $text] + + set normalFont [::gridplus::gpSetFont $normalStyle] + set overFont [::gridplus::gpSetFont $overStyle] + + $name.link configure -font $normalFont -foreground $normalColor + + bind $name.link "$name.link configure -font {$overFont} -foreground $overColor -cursor $options(-linkcursor)" + bind $name.link "$name.link configure -font {$normalFont} -foreground $normalColor -cursor {}" + bind $name.link "eval \"::gridplus::gpCommand {$linkCommand} .$window $doValidation\"" + + if {[=? $widgetOptions :]} { + if {$icon eq ""} {set icon $options(-icon)} + ::ttk::label $name.icon -image [=: $icon] + bind $name.icon "$name.icon configure -cursor $options(-linkcursor)" + bind $name.icon "$name.icon configure -cursor {}" + bind $name.icon "eval \"::gridplus::gpCommand {$linkCommand} .$window $doValidation\"" + grid $name.icon $name.link + } else { + ::ttk::label $name.indent -background $options(-background) -foreground $options(-foreground) -text $indent + grid $name.indent $name.link + } +} + +#=======================================================================# +# PROC : ::gridplus::widget:m # +# PURPOSE: Create menubutton widget. # +#=======================================================================# + +proc ::gridplus::widget:m {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + set icon [= $widgetOptions :] + set text [= $widgetOptions text] + + set menu "$name:menu" + + if {$icon ne ""} { + if {$text eq ""} { + ::ttk::menubutton $name -menu $menu -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) + } else { + ::ttk::menubutton $name -menu $menu -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width -compound $options(-compound) + } + } else { + ::ttk::menubutton $name -menu $menu -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width + } + + if {$state eq "disabled"} { + $name configure -takefocus 0 + } +} + +#=======================================================================# +# PROC : ::gridplus::widget:r # +# PURPOSE: Create radiobutton widget. # +#=======================================================================# + +proc ::gridplus::widget:r {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + variable gpInfo + + global {} + + set command [= $widgetOptions ~] + set group [= $widgetOptions *] + set value [= $widgetOptions + [= $widgetOptions -]] + + if {[=? $widgetOptions *]} { + set group ",$group" + } else { + set group {} + } + if {$basename eq ""} { + set variable "$options(name)$group" + if {$group ne ""} {set gpInfo($options(name):radiobuttonGroups) [lappend gpInfo($options(name):radiobuttonGroups) $group]} + } else { + set variable "$basename$group" + if {$group ne ""} {set gpInfo($basename:radiobuttonGroups) [lappend gpInfo($basename:radiobuttonGroups) $group]} + } + + set ($variable) {} + + set options(-radiobuttoncommand) [::gridplus::gpOptionAlias -radiobuttoncommand -rcmd] + + ::ttk::radiobutton $name -style $style -takefocus $options(-takefocus) -value $value -variable ($variable) + + if {$state eq "disabled"} { + $name configure -takefocus 0 + } + + if {[=? $widgetOptions +] || [=@ $variable] eq $value} { + after idle "$name invoke; $name configure -state $state" + } else { + $name configure -state $state + } + + if {[=? $widgetOptions ~]} { + if {$command eq ""} { + set command $name + } + if {$options(-proc)} { + set command "gpProc [::gridplus::gpCommandFormat $command]" + } else { + set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" + } + $name configure -command $command + } elseif {$options(-radiobuttoncommand) ne ""} { + if {$options(-proc)} { + set command "gpProc $options(-radiobuttoncommand)" + } else { + set command "$options(-prefix)$options(-radiobuttoncommand)" + } + $name configure -command $command + } +} + +#=======================================================================# +# PROC : ::gridplus::widget:s # +# PURPOSE: Create spinbox widget. # +#=======================================================================# + +proc ::gridplus::widget:s {name window basename style width fixed state widgetOptions} { + upvar 1 options options + + variable gpInfo + + global {} + + set value [= $widgetOptions +] + set ($name) [= $widgetOptions = [=@ $name]] + + if {$state eq "normal"} { + set state readonly + } + + set from {} + set to {} + set increment {} + set format {} + + if {[string match */* $value]} { + foreach {from to increment format} [split $value /] {} + + if {$from eq ""} { + if {$options(-from) eq ""} { + error "GRIDPLUS ERROR: 'From' value not specified for spinbox \"$name\"." + } else { + set from $options(-from) + } + } + if {$to eq ""} { + if {$options(-to) eq ""} { + error "GRIDPLUS ERROR: 'To' value not specified for spinbox \"$name\"." + } else { + set to $options(-to) + } + } + if {$increment eq ""} { + if {$options(-increment) eq ""} { + error "GRIDPLUS ERROR: 'Increment' value not specified for spinbox \"$name\"." + } else { + set increment $options(-increment) + } + } + if {$format eq ""} { + set format $options(-spinformat) + } + + if {$($name) eq ""} { + set ($name) $from + } + + ::ttk::spinbox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -from $from -to $to -increment $increment -format $format -width $width + } else { + if {$($name) eq ""} { + set ($name) [lindex $value 0] + } + + ::ttk::spinbox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -values $value -width $width + } + + if {$state eq "disabled"} { + $name configure -takefocus 0 + } + + bind $name "::gridplus::gpEntryEdit {$window} %X %Y" +} + +#=======================================================================# +# PROC : ::gridplus::gpAdd # +# PURPOSE: Add non-gridplus widget to group. # +#=======================================================================# + +proc ::gridplus::gpAdd {} { + upvar 1 options options + + variable gpInfo + + set gpInfo($options(name):group) $options(-group) +} + +#=======================================================================# +# PROC : ::gridplus::gpAutoGroup # +# PURPOSE: Set group state when entry has been updated. # +#=======================================================================# + +proc ::gridplus::gpAutoGroup {name group state args} { + + global {} + + trace remove variable ($name) write "::gridplus::gpAutoGroup $name $group $state" + + ::gridplus::gridplus set -group $group -state $state +} + +#=======================================================================# +# PROCS : ::gridplus::gpWidgetHelpInit # +# : ::gridplus::gpWidgetHelpDelay # +# : ::gridplus::gpWidgetHelpCancel # +# : ::gridplus::gpWidgetHelpShow # +# PURPOSE: Gridplus widget help. # +#=======================================================================# + +proc ::gridplus::gpWidgetHelpInit {item message} { + variable gpWidgetHelp + + if {! [winfo exists .gpWidgetHelp]} { + toplevel .gpWidgetHelp -background black -borderwidth 1 -relief flat + label .gpWidgetHelp.message -background lightyellow + pack .gpWidgetHelp.message + wm overrideredirect .gpWidgetHelp 1 + wm withdraw .gpWidgetHelp + } + + set gpWidgetHelp($item) $message + bind $item {::gridplus::gpWidgetHelpDelay %W} + bind $item {::gridplus::gpWidgetHelpCancel} +} + +proc ::gridplus::gpWidgetHelpDelay {item} { + variable gpWidgetHelp + + gpWidgetHelpCancel + set gpWidgetHelp(delay) [after 300 [list ::gridplus::gpWidgetHelpShow $item]] +} + +proc ::gridplus::gpWidgetHelpCancel {} { + variable gpWidgetHelp + + if {[info exists gpWidgetHelp(delay)]} { + after cancel $gpWidgetHelp(delay) + unset gpWidgetHelp(delay) + } + + if {[info exists gpWidgetHelp(show)]} { + after cancel $gpWidgetHelp(show) + unset gpWidgetHelp(show) + } + + if {[winfo exists .gpWidgetHelp]} { + wm withdraw .gpWidgetHelp + } +} + +proc ::gridplus::gpWidgetHelpShow {item} { + variable gpWidgetHelp + + .gpWidgetHelp.message configure -text $gpWidgetHelp($item) + + set screenWidth [lindex [wm maxsize .] 0] + set helpWidth [winfo width .gpWidgetHelp] + set helpX [winfo pointerx $item] + set helpY [expr [winfo rooty $item] + [winfo height $item]] + + if {[expr {$helpX + $helpWidth}] > $screenWidth} { + set helpX [expr {$screenWidth - $helpWidth - 8}] + } + + wm geometry .gpWidgetHelp +$helpX+$helpY + wm deiconify .gpWidgetHelp + + raise .gpWidgetHelp + + unset gpWidgetHelp(delay) + + set gpWidgetHelp(show) [after [=< helpDisplayTime 2500] ::gridplus::gpWidgetHelpCancel] +} + +#=======================================================================# +# PROC : ::gridplus::gpCalendar # +# PURPOSE: Create calendar. # +#=======================================================================# + +proc ::gridplus::gpCalendar {} { + upvar 1 options options + + global {} + + variable gpInfo + + set columnWidth 3 + + set gpInfo($options(name):fg) [lindex [split $options(-calcolor) "/"] 0] + set gpInfo($options(name):bg) [lindex [split $options(-calcolor) "/"] 1] + set gpInfo($options(name):selectfg) [lindex [split $options(-calselectcolor) "/"] 0] + set gpInfo($options(name):selectbg) [lindex [split $options(-calselectcolor) "/"] 1] + set gpInfo($options(name):command) $options(-command) + set gpInfo($options(name):navcommand) $options(-navcommand) + set gpInfo($options(name):navselect) $options(-navselect) + set gpInfo($options(name):variable) $options(-variable) + set gpInfo($options(name):selecttoday) $options(-selecttoday) + set gpInfo($options(name):weekstart) $options(-weekstart) + + if {$options(-date) eq ""} { + foreach {month day year} [clock format [clock seconds] -format "%m %d %Y"] {} + } else { + foreach {month day year} [::gridplus::gpFormatDate $options(-date) internal] {} + if {! [::gridplus::gpCalCheckDate $month $day $year]} { + error "GRIDPLUS ERROR: (gridplus calendar) \"$options(-date)\" is not a valid date." + } + } + + ::gridplus::gpLabelframe + + frame $options(name).calendar -bg $gpInfo($options(name):bg) -relief $options(-calrelief) -borderwidth 2 + frame $options(name).calendar.header -bg $gpInfo($options(name):bg) + + label $options(name).calendar.header.month -text "" -font [::gridplus::gpSetFont {+2 bold}] -bg $gpInfo($options(name):bg) -fg $gpInfo($options(name):fg) -padx 0 + label $options(name).calendar.header.year -text "" -font [::gridplus::gpSetFont {+2 bold}] -bg $gpInfo($options(name):bg) -fg $gpInfo($options(name):fg) -padx 0 + + pack $options(name).calendar.header.month -side left -anchor w + pack $options(name).calendar.header.year -side right -anchor e + + grid $options(name).calendar.header -columnspan 7 -sticky ew + + if {$options(-navbar)} { + frame $options(name).calendar.navbar -bg $gpInfo($options(name):bg) + frame $options(name).calendar.navbar.left -bg $gpInfo($options(name):bg) + frame $options(name).calendar.navbar.centre -bg $gpInfo($options(name):bg) + frame $options(name).calendar.navbar.right -bg $gpInfo($options(name):bg) + + ttk::label $options(name).calendar.navbar.left.navbackyear -image gpcal-prev-year -background $gpInfo($options(name):bg) + pack $options(name).calendar.navbar.left.navbackyear -side left + bind $options(name).calendar.navbar.left.navbackyear "::gridplus::gpCalendarNav $options(name) year -1" + + ttk::label $options(name).calendar.navbar.right.navnextyear -image gpcal-next-year -background $gpInfo($options(name):bg) + pack $options(name).calendar.navbar.right.navnextyear -side right + bind $options(name).calendar.navbar.right.navnextyear "::gridplus::gpCalendarNav $options(name) year +1" + + ttk::label $options(name).calendar.navbar.centre.current -image gpcal-today -background $gpInfo($options(name):bg) + pack $options(name).calendar.navbar.centre.current + bind $options(name).calendar.navbar.centre.current "::gridplus::gpCalendarNav $options(name) current" + + ttk::label $options(name).calendar.navbar.left.navbackmonth -image gpcal-prev-month -background $gpInfo($options(name):bg) + pack $options(name).calendar.navbar.left.navbackmonth -side left + bind $options(name).calendar.navbar.left.navbackmonth "::gridplus::gpCalendarNav $options(name) month -1" + + ttk::label $options(name).calendar.navbar.right.navnextmonth -image gpcal-next-month -background $gpInfo($options(name):bg) + pack $options(name).calendar.navbar.right.navnextmonth -side right + bind $options(name).calendar.navbar.right.navnextmonth "::gridplus::gpCalendarNav $options(name) month +1" + + pack $options(name).calendar.navbar.left -side left + pack $options(name).calendar.navbar.centre -side left -expand 1 -fill x + pack $options(name).calendar.navbar.right -side right + + grid $options(name).calendar.navbar -columnspan 7 -sticky ew + } + + set rowData "" + + foreach dayName [::gridplus::gpCalDayNames $options(-weekstart)] { + label $options(name).calendar.days:$dayName -text $dayName -borderwidth 1 -width $columnWidth -font [::gridplus::gpSetFont bold] -bg $gpInfo($options(name):bg) -fg $gpInfo($options(name):fg) + set rowData "$rowData $options(name).calendar.days:$dayName" + } + + grid {*}$rowData -sticky e + + for {set row 1} {$row < 7} {incr row} { + set rowData "" + for {set column 1} {$column < 8} {incr column} { + label $options(name).calendar.$row:$column -text "" -borderwidth 1 -width 3 -fg $gpInfo($options(name):fg) -bg $gpInfo($options(name):bg) + set rowData "$rowData $options(name).calendar.$row:$column" + } + grid {*}$rowData -sticky e + } + + grid columnconfigure $options(name) "all" -uniform allTheSame + + foreach child [winfo children $options(name).calendar] { + bind $child "::gridplus::gpCalendarSelect $options(name) %W" + } + + if {$options(-variable) ne ""} { + set ($options(-variable)) "" + } else { + set ($options(name)) "" + } + + pack $options(name).calendar + + ::gridplus::gpCalendarDisplay $options(name) $day $month $year +} + +#=======================================================================# +# PROC : ::gridplus::gpCalendarDisplay # +# PURPOSE: Display calendar for specified month. # +#=======================================================================# + +proc ::gridplus::gpCalendarDisplay {name day month year} { + + global {} + + variable gpConfig + variable gpInfo + + if {[info exists gpInfo($name:selected)] && $gpInfo($name:selected) ne ""} { + $gpInfo($name:selected) configure -bg $gpInfo($name:bg) -fg $gpInfo($name:fg) + } + + foreach {currentDay currentMonth currentYear} [clock format [clock seconds] -format "%d %m %Y"] {} + + if {$month eq $currentMonth && $year eq $currentYear} { + set current 1 + } else { + set current 0 + } + + if {[info exists gpInfo($name:selectedmonth)] && $month eq $gpInfo($name:selectedmonth) && $year eq $gpInfo($name:selectedyear)} { + set selected 1 + } else { + set selected 0 + } + + foreach {monthName startDay} [clock format [clock scan 01/$month/$year -format %d/%m/%Y] -format "%B %u" -locale $gpConfig(locale)] {} + + if {$gpInfo($name:weekstart) == 0} { + set startColumn [expr {$startDay + 1}] + if {$startColumn == 8} { + set startColumn 1 + } + } else { + set startColumn $startDay + } + + $name.calendar.header.month configure -text $monthName + $name.calendar.header.year configure -text $year + + set output 0 + set outputDay 1 + + set gpInfo($name:displaymonth) $month + set gpInfo($name:displayyear) $year + + for {set row 1} {$row < 7} {incr row} { + set rowData "" + for {set column 1} {$column < 8} {incr column} { + if {$row == 1} { + if {$column == $startColumn} { + set output 1 + } + } + + if {$outputDay > [::gridplus::gpCalMonthDays $month $year]} { + set output 0 + } + + if {$output} { + $name.calendar.$row:$column configure -text $outputDay -relief flat + + if {$current && [format %02d $outputDay] eq $currentDay} { + $name.calendar.$row:$column configure -relief solid + } + + if {$gpInfo($name:selecttoday) && [format %02d $outputDay] eq $day} { + ::gridplus::gpCalendarSelect $name $name.calendar.$row:$column -displayonly + } + + if {$selected && [format %02d $outputDay] eq $gpInfo($name:selectedday)} { + $name.calendar.$row:$column configure -bg $gpInfo($name:selectbg) -fg $gpInfo($name:selectfg) + } + incr outputDay + } else { + $name.calendar.$row:$column configure -text "" -relief flat + } + } + } + + set gpInfo($name:selecttoday) 0 +} + +#=======================================================================# +# PROC : ::gridplus::gpCalendarNav # +# PURPOSE: Calendar navigation. # +#=======================================================================# + +proc ::gridplus::gpCalendarNav {name unit {increment {}}} { + + global {} + + variable gpInfo + + if {$unit eq "current"} { + if {$increment eq ""} { + foreach {month year} [clock format [clock seconds] -format "%m %Y"] {} + } else { + foreach {month year} [clock format [clock add [clock seconds] $increment month] -format "%m %Y"] {} + } + } else { + set month $gpInfo($name:displaymonth) + set year $gpInfo($name:displayyear) + foreach {month year} [clock format [clock add [clock scan 01/$gpInfo($name:displaymonth)/$gpInfo($name:displayyear) -format "%d/%m/%Y"] $increment $unit] -format "%m %Y"] {} + } + + ::gridplus::gpCalendarDisplay $name {} $month $year + + if {$gpInfo($name:navselect)} { + if {$gpInfo($name:variable) ne ""} { + set variable $gpInfo($name:variable) + } else { + set variable $name + } + + if {$($variable) ne ""} { + foreach {varMonth varDay varYear} [::gridplus::gpFormatDate $($variable) internal] {} + if {$month eq $varMonth && $year eq $varYear} { + ::gridplus::gpselect $name $($variable) + } + } + } + + if {$gpInfo($name:navcommand) ne ""} { + eval "$gpInfo($name:navcommand) $name $unit $increment" + } +} + + +#=======================================================================# +# PROC : ::gridplus::gpCalendarSelect # +# PURPOSE: Sets value for calendar selection. # +#=======================================================================# + +proc ::gridplus::gpCalendarSelect {name window {mode {}}} { + + global {} + + variable gpConfig + variable gpInfo + + if {[winfo class $window] ne "Label" || ! [string is integer -strict [$window cget -text]]} {return} + + if {$gpInfo($name:variable) ne ""} { + set variable $gpInfo($name:variable) + } else { + set variable $name + } + + if {[info exists gpInfo($name:selected)] && $gpInfo($name:selected) ne ""} { + $gpInfo($name:selected) configure -bg $gpInfo($name:bg) -fg $gpInfo($name:fg) + } + + $window configure -bg $gpInfo($name:selectbg) -fg $gpInfo($name:selectfg) + + set gpInfo($name:selected) $window + set gpInfo($name:selectedday) [format %02d [$window cget -text]] + set gpInfo($name:selectedmonth) $gpInfo($name:displaymonth) + set gpInfo($name:selectedyear) $gpInfo($name:displayyear) + + switch -- $gpConfig(dateformat) { + eu {set ($variable) "$gpInfo($name:selectedday).$gpInfo($name:selectedmonth).$gpInfo($name:selectedyear)"} + iso {set ($variable) "$gpInfo($name:selectedyear)-$gpInfo($name:selectedmonth)-$gpInfo($name:selectedday)"} + uk {set ($variable) "$gpInfo($name:selectedday)/$gpInfo($name:selectedmonth)/$gpInfo($name:selectedyear)"} + us {set ($variable) "$gpInfo($name:selectedmonth)/$gpInfo($name:selectedday)/$gpInfo($name:selectedyear)"} + } + + if {$mode ne "-displayonly" && $gpInfo($name:command) ne ""} { + eval $gpInfo($name:command) + } +} + +#=======================================================================# +# PROC : ::gridplus::gpClear # +# PURPOSE: Clear window and unset associated variables. # +#=======================================================================# + +proc ::gridplus::gpClear {} { + upvar 1 options options + + global {} + + variable gpWidgetHelp + variable gpInfo + variable gpTabOrder + variable gpValidateError + variable gpValidations + + if {$options(name) ne "."} { + unset -nocomplain gpInfo($options(name):toplevel) + unset -nocomplain gpInfo($options(name):modal) + } + + if {[winfo exists $options(name).container]} { + eval $gpInfo($options(name):wcmd) + unset -nocomplain gpInfo($options(name):in) + set gpInfo($options(name):wcmd) {} + return + } + + $options(name) configure -menu {} + + unset -nocomplain gpInfo(validation:failed) + unset -nocomplain gpValidations($options(name)) + + if {[winfo exists .gpValidateError]} { + wm withdraw .gpValidateError + } + + foreach item [winfo child $options(name)] { + if {! [winfo exists $item]} {continue} + + set class [winfo class $item] + + if {[regexp -- {^[.]_} $item]} { + continue + } + + if {[string match *.gpEditMenu $item]} { + continue + } + + if {$class ne "Toplevel"} { + if {$options(-variables) && [info exists ($item)]} { + if {$class eq "Entry"} { + $item configure -textvariable {} + } + unset ($item) + } + if {$options(-variables) && [info exists gpInfo($item:radiobuttonGroups)]} { + foreach radiobuttonGroup $gpInfo($item:radiobuttonGroups) { + if {[info exists ($item$radiobuttonGroup)]} { + unset ($item$radiobuttonGroup) + } + } + unset gpInfo($item:radiobuttonGroups) + } + if {[info exists gpWidgetHelp($item)]} { + unset gpWidgetHelp($item) + } + if {[info exists gpInfo($item:wcmd)]} { + eval $gpInfo($item:wcmd) + } + foreach infoItem [array names gpInfo $item:*] { + unset gpInfo($infoItem) + } + foreach tabOrderItem [array names gpTabOrder $item:*] { + unset gpTabOrder($tabOrderItem) + } + foreach validateErrorItem [array names gpValidateError $item:*] { + unset gpValidateError($validateErrorItem) + } + if {$gpInfo() eq "$item.text"} { + if {[winfo exists .gpTextFind]} { + ::gridplus::gpTextFind:action,cancel + } + } + if {$class eq "Menu"} { + foreach infoItem [array names gpInfo $item.*:group] { + unset gpInfo($infoItem) + } + } + + destroy $item + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpCommand # +# PURPOSE: Evals command, performing validations if required. # +#=======================================================================# + +proc ::gridplus::gpCommand {command window validate} { + + global {} + + variable gpValidations + variable gpInfo + + if {$window eq "."} { + set containers [array names gpInfo -regexp {^[.][^.]+:in$}] + } else { + set containers [array names gpInfo -regexp "^$window\[.\]\[^.\]+:in$"] + } + + set containedWindows {} + + foreach container $containers { + set containedWindows "$containedWindows $gpInfo($container)" + } + + if {[info exists gpValidations($window)]} { + set validations $gpValidations($window) + } else { + set validations {} + } + + foreach containedWindow $containedWindows { + if {[info exists gpValidations($containedWindow)]} { + set validations "$validations $gpValidations($containedWindow)" + } + } + + if {$validate && $validations ne ""} { + foreach validationInfo $validations { + set entry [lindex [split $validationInfo :] 0] + regexp -- {:(.+)$} $validationInfo -> validation + if {! [::gridplus::gpValidate $entry $validation focusout - - 1]} { + ::gridplus::gpValidateFailed $entry + return + } + } + } + + eval $command +} + +#=======================================================================# +# PROC : ::gridplus::gpCommandFormat # +# PURPOSE: Makes sure "command" is in the correct format. # +#=======================================================================# + +proc ::gridplus::gpCommandFormat {command} { + + set commandProc [lindex $command 0] + set commandParameters [lrange $command 1 end] + + regsub -all {[.]} $commandProc ":" commandProc + regsub {;:} $commandProc ";" commandProc + regsub {^:} $commandProc {} commandProc + + if {[llength $command] eq 1} { + return $commandProc + } else { + return [list $commandProc {*}$commandParameters] + } +} + +#=======================================================================# +# PROC : ::gridplus::gpContainer # +# PURPOSE: Create container for toplevel windows. # +#=======================================================================# + +proc ::gridplus::gpContainer {} { + upvar 1 options options + + variable gpInfo + + if {[regexp -- {(^[.][^.]+)[.]} $options(name) -> window]} { + if {! $gpInfo($window:toplevel)} { + error "GRIDPLUS ERROR: (gridplus container) \"$window\" is a contained toplevel." + } + } + + if {$options(-relief) eq "theme"} { + if {$options(-title) eq ""} { + ::ttk::labelframe $options(name) -height $options(-height) -width $options(-width) -padding $options(-padding) + ::ttk::separator $options(name).separator -orient horizontal + $options(name) configure -labelwidget $options(name).separator -labelanchor s + } else { + if {$options(-labelanchor) eq ""} { + ::ttk::labelframe $options(name) -height $options(-height) -width $options(-width) -padding $options(-padding) -text [mc $options(-title)] + } else { + ::ttk::labelframe $options(name) -height $options(-height) -width $options(-width) -labelanchor $options(-labelanchor) -padding $options(-padding) -text [mc $options(-title)] + } + } + } else { + ::ttk::frame $options(name) -height $options(-height) -width $options(-width) -padding $options(-padding) -relief $options(-relief) + } + + grid propagate $options(name) 0 + pack propagate $options(name) 0 + + set gpInfo($options(name):sticky) $options(-sticky) + set gpInfo($options(name):wcmd) {} + +} + +#=======================================================================# +# PROC : ::gridplus::gpCreateIcons # +# PURPOSE: Creates default icons for GRIDPLUS Tree. # +#=======================================================================# + +proc ::gridplus::gpCreateIcons {} { + + image create photo ::icon::file -data { + R0lGODlhEAAQAIIAAPwCBFxaXISChPz+/MTCxKSipAAAAAAAACH5BAEAAAAA + LAAAAAAQABAAAANCCLrcGzBC4UAYOE8XiCdYF1BMJ5ye1HTfNxTBSpy0QMBy + ++HlXNu8h24X6/2AReHwllRcMtCgs0CtVpsWiRZbqfgTACH+aENyZWF0ZWQg + YnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29yIDE5OTcs + MTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cuZGV2ZWxj + b3IuY29tADs= + } + + image create photo ::icon::folder -data { + R0lGODlhEAAQAIIAAPwCBFxaXMTCxPz+/KSipAAAAAAAAAAAACH5BAEAAAAA + LAAAAAAQABAAAAM3CLrc/i/IAFcQWFAos56TNYxkOWhKcHossals+64x5qZ0 + fQNwbc++Hy4o2F0IyKTSCGqCKhB/AgAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lG + IFBybyB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENvciAxOTk3LDE5OTguIEFsbCBy + aWdodHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3LmRldmVsY29yLmNvbQA7 + } + + image create photo gpcal-prev-year -data { + R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA + AAACvAAAAAEbhAzQICcB0AoanwTx9Akz2QTx9Akz5wEbhATyEAkz/gzQIATyjAk/ogAAAAAA + AQTyZNUOlwEbhATyECNGkAEbhAAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w + xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQNAQANAQk6/gQNAQAAGgTzWATzCCNGmgTy2NhvHgUK + PgAABxQIQAAAAAAAAQk+Qwk+ggggwQAABAT1fAlRCwggwQAABAk+Qwk+ggggwQAABAT1nAlR + CwggwQAABAT1nAAAAAggwQUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz + bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k + kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc + 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEgwYUADwAAAFa0 + WAEgwQAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA + ALwCAAAAAIQbASDQDNABJ58aCvTxBNkzCfTxBOczCYQbARDyBP4zCSDQDIzyBKI/CQAAAAEA + AGTyBJcO1YQbARDyBJBGI4QbAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw + /QDg/QAAALU4CZQ4CUzzBCx/QAAAAAENBAENAP46CQENBBoAAFjzBAjzBJpGI9jyBB5v2D4K + BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgg + wQAAAAABAAT1hAAAAgla9AlNzwlaxAggwQAAAAABAAT1pAAAAgla9Ala5QgXAAMIBABgYEGD + CBMSFMhwYQCHDQ8uDAgAOw== + } + + image create photo gpcal-prev-month -data { + R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA + AAACvAAAAAEbhAzQIB4MsAoanwTx9Akz2QTx9Akz5wEbhATyEAkz/gzQIATyjAk/ogAAAAAA + AQTyZNUOlwEbhATyECNGkAEbhAAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w + xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQfowAfowk6/gQfowAAGgTzWATzCCNGmgTy2NhvHgUK + PgAABxQIQAAAAAAAAQk+Qwk+gggdPQAABAT1fAlRCwgdPQAABAk+Qwk+gggdPQAABAT1nAlR + CwgdPQAABAT1nAAAAAgdPQUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz + bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k + kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc + 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEdPYUADwAAAFa0 + WAEdPQAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA + ALwCAAAAAIQbASDQDLAMHp8aCvTxBNkzCfTxBOczCYQbARDyBP4zCSDQDIzyBKI/CQAAAAEA + AGTyBJcO1YQbARDyBJBGI4QbAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw + /QDg/QAAALU4CZQ4CUzzBCx/QAAAAKMfBKMfAP46CaMfBBoAAFjzBAjzBJpGI9jyBB5v2D4K + BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgd + PQAAAAABAAT1hAAAAgla9AlNzwlaxAgdPQAAAAABAAT1pAAAAgla9Ala5QgXAAMIFAgAwMCD + BQ8OTKhwocGGBB8GCAgAOw== + } + + image create photo gpcal-today -data { + R0lGODlhZAAFAHcAACH5BAEAAAEALAAAAABkAAUAhwAAAP//8AAAAATzyPqI8PU4cP////lE + qPV9cPWKOgv/6AAAI/WKPpgu3dSYsgTxvNZvbTcLzgTyGNZvjgAAAQABEQAABgYLNjcLznPZ + uAAAgjcLziMlONRNoHPQAATx+ATx+DcLznPZuATyiNa44jcLzgAAggAAAAAAAAAAANcbETcL + zgAAggAAAAAAAATznAT5yAAAADcLzgAAggAAAAAAAAAABAAEsNa4nATzSAAAAPlEyww46PWL + zQUHePWQNww5EAw48Ak+Qwk+gggSoQAABAT1fAlRCwgSoQAABAk+Qwk+gggSoQAABAT1nAlR + CwgSoQAABAT1nAAAAAgSodQa2P///9TFCdRHqjcLzgAAggAAAAAAAATzKNgFm9gDDAAAggAA + ACMBeHPZuHP9gHP9iCMBeAHzVAUAAATyjAAAggTzdHPZsAAAAAAAAAAAAPaUVgAAUgAAAI0k + kAAAAAw48HPeAP3gAAHzXCMAAATy0PqI8ATzxPqI8AAAAgcJiP///wAARwcJiCMlONRNoNTL + oATzlACpGAT0dNjWEAT0JNhvHgcJiAAARwAAAAT4kAAAAdcbEQk67Qk2DwESoYUADwAAAFa3 + oAESoQAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAHA49f///6hE + +XB99TqK9ej/CyMAAD6K9d0umLKY1LzxBG1v1s4LNxjyBI5v1gEAABEBAAYAADYLBs4LN7jZ + c4IAAM4LNzglI6BN1ADQc/jxBPjxBM4LN7jZc4jyBOK41s4LN4IAAAAAAAAAAAAAABEb184L + N4IAAAAAAAAAAJzzBMj5BAAAAM4LN4IAAAAAAAAAAAQAALAEAJy41kjzBAAAAMtE+eg4DM2L + 9XgHBTeQ9RA5DPA4DADec7DZc7jyBOU6+LABADDecwAAI7DZcwAAAIzzBMqM9QlNzwlaxAgS + oQAAAAABAAT1hAAAAgla9AlNzwlaxAgSoQAAAAABAAT1pAAAAgla9Ala5Qg/AAMIHEiwoMGD + CBMOBMAQgMKHECNKnEiRIEOBFytqfNiwo8ePIEOK/GhxpMmTKB1uXHkwY0aWMGPKXNhwZsyA + ADs= + } + + image create photo gpcal-next-year -data { + R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA + AAACvAAAAAEbhAzQICcB0AoanwTx9Akz2QTx9Akz5wEbhATyEAkz/gzQIATyjAk/ogAAAAAA + AQTyZNUOlwEbhATyECNGkAEbhAAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w + xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQQGgAQGgk6/gQQGgAAGgTzWATzCCNGmgTy2NhvHgUK + PgAABxQIQAAAAAAAAQk+Qwk+gggb1gAABAT1fAlRCwgb1gAABAk+Qwk+gggb1gAABAT1nAlR + Cwgb1gAABAT1nAAAAAgb1gUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz + bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k + kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc + 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEb1oUADwAAAFa0 + WAEb1gAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA + ALwCAAAAAIQbASDQDNABJ58aCvTxBNkzCfTxBOczCYQbARDyBP4zCSDQDIzyBKI/CQAAAAEA + AGTyBJcO1YQbARDyBJBGI4QbAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw + /QDg/QAAALU4CZQ4CUzzBCx/QAAAABoQBBoQAP46CRoQBBoAAFjzBAjzBJpGI9jyBB5v2D4K + BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgb + 1gAAAAABAAT1hAAAAgla9AlNzwlaxAgb1gAAAAABAAT1pAAAAgla9Ala5QgZAAMAABBAIMGC + BQcmPIhQocGGBx0+nBggIAA7 + } + + image create photo gpcal-next-month -data { + R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA + AAACvAAAAAEP/gzQIAcAAAoanwTx9Akz2QTx9Akz5wEP/gTyEAkz/gzQIATyjAk/ogAAAAAA + AQTyZNUOlwEP/gTyECNGkAEP/gAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w + xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQa7AAa7Ak6/gQa7AAAGgTzWATzCCNGmgTy2NhvHgUK + PgAABxQIQAAAAAAAAQk+Qwk+gggKNgAABAT1fAlRCwgKNgAABAk+Qwk+gggKNgAABAT1nAlR + CwgKNgAABAT1nAAAAAgKNgUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz + bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k + kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc + 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEKNoUADwAAAFa0 + WAEKNgAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA + ALwCAAAAAP4PASDQDAAAB58aCvTxBNkzCfTxBOczCf4PARDyBP4zCSDQDIzyBKI/CQAAAAEA + AGTyBJcO1f4PARDyBJBGI/4PAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw + /QDg/QAAALU4CZQ4CUzzBCx/QAAAAOwaBOwaAP46CewaBBoAAFjzBAjzBJpGI9jyBB5v2D4K + BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgK + NgAAAAABAAT1hAAAAgla9AlNzwlaxAgKNgAAAAABAAT1pAAAAgla9Ala5QgWAAMIBABAoMGD + BA8qTKgwAMOFBQ8GBAA7 + } + +} + +#=======================================================================# +# PROC : ::gridplus::gpDateSelectorClear # +# PURPOSE: Clear Date Selector field for "Delete" key. # +#=======================================================================# + +proc ::gridplus::gpDateSelectorClear {name key} { + + if {$key eq "Delete"} { + gpset $name {} + } +} + +#=======================================================================# +# PROC : ::gridplus::gpDateSelectorKeyPress # +# PURPOSE: Date Selector key press post/unpost # +#=======================================================================# + +proc ::gridplus::gpDateSelectorKeyPress {name widget action} { + + if {$action eq "post" && ! [$name instate pressed]} { + ::gridplus::gpDateSelectorPost $name + return -code break + } elseif {$action eq "unpost" && [$name instate pressed]} { + if {! [string match .gpDateSelector.calendar.* $widget]} { + ::gridplus::gpDateSelectorUnpost + } + } else { + return -code break + } +} + +#=======================================================================# +# PROC : ::gridplus::gpDateSelectorPost # +# PURPOSE: Post Date Selector dropdown/popup. # +#=======================================================================# + +proc ::gridplus::gpDateSelectorPost {name} { + + global {} + + variable gpInfo + + $name instate disabled {return} + + $name state pressed + + set widgetX [winfo rootx $name] + set widgetY [winfo rooty $name] + set widgetWidth [winfo width $name] + set widgetHeight [winfo height $name] + + gridplus window .gpDateSelector -overrideredirect 1 -topmost 1 + + wm transient .gpDateSelector [winfo toplevel $name] + + bind .gpDateSelector "::gridplus::gpDateSelectorToggle $name %W" + + gridplus calendar .gpDateSelector.calendar \ + -command "::gridplus::gpDateSelectorUnpost;$gpInfo($name:datecommand)" \ + -date $($name) \ + -padding 2 \ + -relief solid \ + -selecttoday 1 \ + -variable $name + + pack .gpDateSelector.calendar + + update idletasks + + set calendarWidth [winfo reqwidth .gpDateSelector] + + if {[tk windowingsystem] eq "aqua"} { + # Adjust for platform-specific bordering to ensure the box is + # directly under actual 'entry square' + set xOffset 3 + set yOffset 2 + incr widgetX $xOffset + set widgetWidth [expr {$widgetWidth - $xOffset*2}] + } else { + set yOffset 0 + } + + set calendarHeight [winfo reqheight .gpDateSelector] + + # Added "+ 40" to take into account windows task bar. + if {$widgetY + $widgetHeight + $calendarHeight + 40 > [winfo screenheight .gpDateSelector]} { + set Y [expr {$widgetY - $calendarHeight - $yOffset}] + } else { + set Y [expr {$widgetY + $widgetHeight - $yOffset}] + } + + set X [expr {$widgetX - ($calendarWidth - $widgetWidth)}] + + if {$X < 0} { + set X $widgetX + } + + wm geometry .gpDateSelector +${X}+${Y} + wm deiconify .gpDateSelector + raise .gpDateSelector + + ttk::globalGrab .gpDateSelector + + focus .gpDateSelector.calendar + bind .gpDateSelector.calendar "::gridplus::gpDateSelectorKeyPress $name %W unpost" +} + +#=======================================================================# +# PROC : ::gridplus::gpDateSelectorToggle # +# PURPOSE: Toggle Date Selector dropdown/popup. # +#=======================================================================# + +proc ::gridplus::gpDateSelectorToggle {name widget} { + + if {[$name instate pressed]} { + if {! [string match .gpDateSelector.calendar.* $widget]} { + ::gridplus::gpDateSelectorUnpost + } + } else { + ::gridplus::gpDateSelectorPost $name + return -code break + } +} + +#=======================================================================# +# PROC : ::gridplus::gpDateSelectorUnpost # +# PURPOSE: Unpost Date Selector dropdown/popup. # +#=======================================================================# + +proc ::gridplus::gpDateSelectorUnpost {{testWindow {}}} { + + variable gpInfo + + if {[winfo exists .gpDateSelector.calendar] && $testWindow ne ".gpDateSelector"} { + foreach dateSelector [array names gpInfo *:datecommand] { + set name [lindex [split $dateSelector :] 0] + if {[$name instate pressed]} { + $name state !pressed + + ttk::releaseGrab .gpDateSelector + + gridplus clear .gpDateSelector + destroy .gpDateSelector + + update idletasks + ttk::combobox::Unpost $name + + focus $name + } + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpDefine # +# PURPOSE: Creates GRIDPLUS widget definitions. # +#=======================================================================# + +proc ::gridplus::gpDefine {} { + upvar 1 options options + + variable gpInfo + + foreach {id widget} $options(layout) { + set gpInfo(:$id) $widget + } +} + +#=======================================================================# +# PROC : ::gridplus::gpDefineWidget # +# PURPOSE: Process "defined" widget. # +#=======================================================================# + +proc ::gridplus::gpDefineWidget {column} { + + variable gpInfo + + if {[string match @* $column]} { + if {[winfo exists .[string range [lindex $column 0] 1 end]]} { + return $column + } + set defineID [string range [lindex $column 0] 1 end] + if {[info exists gpInfo(:$defineID)]} { + set defineWidget $gpInfo(:$defineID) + set replacementID 1 + + foreach replacement [lrange $column 1 end] { + regsub -- "%$replacementID" $defineWidget $replacement defineWidget + incr replacementID + } + } + return [::gridplus::gpDefineWidget $defineWidget] + } else { + return $column + } +} + +#=======================================================================# +# PROC : ::gridplus::gpEditMenu # +# PURPOSE: Pop-up menu for entry widgets. # +#=======================================================================# + +proc ::gridplus::gpEditMenu {mode} { + + set widget [focus] + + switch -- $mode { + cut { + clipboard clear + clipboard append [selection get] + $widget delete sel.first sel.last + } + copy { + clipboard clear + clipboard append [selection get] + } + paste { + $widget selection clear + $widget insert insert [clipboard get] + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpEditMenuCreate # +# PURPOSE: Create pop-up menu for entry widgets. # +#=======================================================================# + +proc ::gridplus::gpEditMenuCreate {window} { + + menu $window.gpEditMenu + + $window.gpEditMenu configure -tearoff 0 + + $window.gpEditMenu add command -label [mc "Cut"] -command "::gridplus::gpEditMenu cut" + $window.gpEditMenu add command -label [mc "Copy"] -command "::gridplus::gpEditMenu copy" + $window.gpEditMenu add command -label [mc "Paste"] -command "::gridplus::gpEditMenu paste" +} + +#=======================================================================# +# PROC : ::gridplus::gpEntryEdit # +# PURPOSE: Pop-up menu for entry widgets. # +#=======================================================================# + +proc ::gridplus::gpEntryEdit {editWindow X Y {variable {}}} { + + focus [winfo containing $X $Y] + + after 1 "::gridplus::gpEntryEditPost \{$editWindow\} $X $Y \{$variable\}" +} + +#=======================================================================# +# PROC : ::gridplus::gpEntryEditPost # +# PURPOSE: Post Pop-up menu for entry widgets. # +#=======================================================================# + +proc ::gridplus::gpEntryEditPost {editWindow X Y {variable {}}} { + + global {} + + variable gpInfo + + set widget [winfo containing $X $Y] + + if {[info exists gpInfo(validation:failed)] && $gpInfo(validation:failed) ne $widget} { + return + } + + if {$variable eq ""} { + set variable $widget + } + + if {$editWindow eq ""} { + set window {} + } else { + set window .$editWindow + } + + if {! [$widget selection present]} { + $widget selection range 0 end + } + + if {[$widget cget -state] ne "normal"} { + $window.gpEditMenu entryconfigure 0 -state disabled + $window.gpEditMenu entryconfigure 1 -state normal + $window.gpEditMenu entryconfigure 2 -state disabled + } else { + $window.gpEditMenu entryconfigure 0 -state normal + $window.gpEditMenu entryconfigure 1 -state normal + $window.gpEditMenu entryconfigure 2 -state normal + } + + if {$($variable) eq ""} { + $window.gpEditMenu entryconfigure 0 -state disabled + $window.gpEditMenu entryconfigure 1 -state disabled + } + + if {[$widget cget -state] ne "disabled"} { + $window.gpEditMenu post $X $Y + } +} + +#=======================================================================# +# PROC : ::gridplus::gpGetFontOption # +# PURPOSE: Get font option for specified font. # +#=======================================================================# + +proc ::gridplus::gpGetFontOption {font option} { + + foreach {fontOption value} [font configure $font] { + if {$fontOption eq $option} { + return $value + } + } + + return {} +} + +#=======================================================================# +# PROC : ::gridplus::gpGetFontSize # +# PURPOSE: Get font size for specified font. # +#=======================================================================# + +proc ::gridplus::gpGetFontSize {font} { + + if {[llength $font] == 1} { + return [::gridplus::gpGetFontOption $font -size] + } else { + return [lindex $font 1] + } +} + +#=======================================================================# +# PROC : ::gridplus::gpGoto # +# PURPOSE: Move text widget display to specified label. # +#=======================================================================# + +proc ::gridplus::gpGoto {} { + upvar 1 options options + + global {} + + $options(name).text yview $options(layout) + + set ($options(name)) $options(layout) +} + +#=======================================================================# +# PROC : ::gridplus::gpGrid # +# PURPOSE: Create grid. # +#=======================================================================# + +proc ::gridplus::gpGrid {} { + upvar 1 options options + + global {} + + variable gpInfo + variable gpTabOrder + + set options(-columnformat) [::gridplus::gpOptionAlias -columnformat -cfmt] + + set labelColor(1) [lindex [split $options(-labelcolor) /] 0] + set labelColor(2) [lindex [split $options(-labelcolor) /] 1] + set labelStyle(1) [lindex [split $options(-labelstyle) /] 0] + set labelStyle(2) [lindex [split $options(-labelstyle) /] 1] + + regsub -all -- {,} $labelStyle(1) { } labelStyle(1) + regsub -all -- {,} $labelStyle(2) { } labelStyle(2) + + if {[string match *w* $options(-attach)]} { + set leftStretch 0 + set rightStretch 1 + set defaultStretch 0 + } else { + set leftStretch 0 + set rightStretch 0 + set defaultStretch 1 + } + + if {[llength $options(-spacestretch)] == 1} { + set options(-spacestretch) [lrepeat 100 $options(-spacestretch)] + } + + set attachNS 0 + + if {[string match *n* $options(-attach)]} { + set weightY 0 + if {[string match *s* $options(-attach)]} { + set attachNS 1 + } + } else { + set weightY 1 + } + + ::gridplus::gpLabelframe + + grid anchor $options(name) $options(-anchor) + + set rowID 0 + set rowTotal [llength [split $options(layout) "\n"]] + set rowCount 1 + + if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { + set window {} + } + + if {$options(-subst)} { + if {[=< substCommandGrid [=< substCommand 0]]} { + set options(layout) [subst -nobackslashes $options(layout)] + } else { + set options(layout) [subst -nobackslashes -nocommands $options(layout)] + } + } + + foreach row [split $options(layout) "\n"] { + set columnID 0 + set columnTotal [llength $row] + set columnCount 1 + set rowWeight1 0 + + if {$options(-spacestretch) eq ""} { + if {$columnTotal > 1} { + set stretch "$leftStretch [lrepeat [expr {$columnTotal - 1}] $defaultStretch] $rightStretch" + } else { + set stretch "$leftStretch $rightStretch" + } + } else { + set stretch $options(-spacestretch) + } + + ::ttk::frame $options(name).space:$rowID:$columnID -width 0 + grid $options(name).space:$rowID:$columnID -column $columnID -row $rowID -sticky ew + grid columnconfigure $options(name) $columnID -weight [lindex $stretch 0] + incr columnID + + foreach column $row { + switch -- [llength $column] { + 0 { + set columnSpan 2 + set column "{}" + } + 1 { + set columnSpan 2 + } + 2 { + set columnSpan 1 + } + default { + error "GRIDPLUS ERROR: Too many items in column." + } + } + + set columnItem 1 + set formatWidth(1) 0 + set formatWidth(2) 0 + + if {[set columnFormat [lindex $options(-columnformat) [expr {$columnCount - 1}]]] ne ""} { + if {[lindex [split $columnFormat "/"] 0] ne ""} { + set formatWidth(1) [lindex [split $columnFormat "/"] 0] + set formatWidth(2) [lindex [split $columnFormat "/"] 1] + } + if {$formatWidth(1) eq ""} {set formatWidth(1) 0} + if {$formatWidth(2) eq ""} {set formatWidth(2) 0} + } + + foreach item $column { + set bold 0 + set command {} + set labelFont $labelStyle($columnItem) + set labelIcon {} + set labelWidth 0 + set sticky {} + set validate 0 + + if {! [string match "*: " $item]} { + regexp {(^[^:]+)(:(([nsewc]+)?([0-9]+)?$)?)} $item -> item - - sticky labelWidth + } + + if {$labelWidth eq ""} {set labelWidth 0} + + switch -- $sticky { + c {set sticky {}} + "" {set sticky w} + } + + if {[string match "*n*" $sticky] && [string match "*s*" $sticky]} { + set rowWeight1 1 + } + + switch -glob -- $item { + .* { + set itemName $item + ::ttk::frame $options(name).widget:$rowID:$columnID + ::ttk::frame $options(name).widget:$rowID:$columnID.width -height 0 -width [expr {$formatWidth($columnItem) * $gpInfo()}] + + if {! [winfo exists $item]} { + set itemName $options(name),[string range $item 1 end] + + if {$options(-basename) ne ""} { + set textVariable $options(-basename),[string range $item 1 end] + } else { + set textVariable $itemName + } + ::ttk::label $itemName -foreground $labelColor($columnItem) -justify $options(-justify) -wraplength $options(-wraplength) -textvariable ($textVariable) + if {$labelFont ne ""} { + $itemName configure -font [::gridplus::gpSetFont $labelFont] + } + } + + grid $options(name).widget:$rowID:$columnID.width -row 0 -column 0 + grid $itemName -in $options(name).widget:$rowID:$columnID -row 1 -column 0 -sticky $sticky + grid configure $options(name).widget:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky $sticky + grid columnconfigure $options(name).widget:$rowID:$columnID 0 -weight 1 + + if {$rowWeight1} { + grid rowconfigure $options(name) $rowID -weight 1 + grid rowconfigure $options(name).widget:$rowID:$columnID 1 -weight 1 + } + + if {$options(-taborder) eq "column"} { + set gpTabOrder([format "%s:%03d%03d%03d" $options(name) $columnCount $rowCount $columnItem]) $itemName + } else { + set gpTabOrder([format "%s:%03d%03d%03d" $options(name) $rowCount $columnCount $columnItem]) $itemName + } + } + | { + ::ttk::separator $options(name).separator:$rowID:$columnID -orient vertical + grid configure $options(name).separator:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky ns + } + = { + ::ttk::separator $options(name).separator:$rowID:$columnID -orient horizontal + grid configure $options(name).separator:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky ew + } + :* { + if {! [regexp -- {^:([^:]*):([^:]*):([^:]*)$} $item -> labelIcon command validate]} { + set labelIcon [string range $item 1 end] + regsub -- {%%$} $labelIcon {} labelIcon + } + if {$labelIcon eq ""} { + set labelIcon $options(-icon) + } + ::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $labelIcon + ::ttk::label $options(name).label:$rowID:$columnID -image ::icon::$labelIcon + grid configure $options(name).label:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky $sticky + if {$command ne ""} { + if {$options(-proc)} { + set command "set ::gridplus::gpInfo() \[focus\];gpProc $command" + } else { + set command "set ::gridplus::gpInfo() \[focus\];$options(-prefix)$command" + regsub -all {[.]} $command ":" command + regsub {;:} $command ";" command + } + + bind $options(name).label:$rowID:$columnID "eval \"::gridplus::gpCommand {$command} .$window $validate\"" + } + } + default { + if {[string match ^* $item]} { + set labelFont "$labelFont bold" + set item [string range $item 1 end] + } + regsub -all -- " +\n +" $item "\n" item + regsub -all -- "" $item "\n" item + + if {$labelWidth == 0} { + set labelWidth $formatWidth($columnItem) + } + + ::ttk::frame $options(name).label:$rowID:$columnID + ::ttk::frame $options(name).label:$rowID:$columnID.width -height 0 -width [expr {$labelWidth * $gpInfo()}] + ::ttk::label $options(name).label:$rowID:$columnID.text -foreground $labelColor($columnItem) -style $options(-style) -justify $options(-justify) -wraplength $options(-wraplength) -text [mc $item] + if {$labelFont ne ""} { + $options(name).label:$rowID:$columnID.text configure -font [::gridplus::gpSetFont $labelFont] + } + grid $options(name).label:$rowID:$columnID.width -row 0 -column 0 + grid $options(name).label:$rowID:$columnID.text -in $options(name).label:$rowID:$columnID -row 1 -column 0 -sticky $sticky + grid configure $options(name).label:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky $sticky + grid columnconfigure $options(name).label:$rowID:$columnID 0 -weight 1 + } + } + incr columnID $columnSpan + incr columnItem + } + + if {$columnCount != $columnTotal} { + ::ttk::frame $options(name).space:$rowID:$columnID -width $options(-space) + grid $options(name).space:$rowID:$columnID -column $columnID -row $rowID -sticky ew + grid columnconfigure $options(name) $columnID -weight [lindex $stretch $columnCount] + incr columnID + } else { + ::ttk::frame $options(name).space:$rowID:$columnID -width 0 + grid $options(name).space:$rowID:$columnID -column $columnID -row $rowID -sticky ew + grid columnconfigure $options(name) $columnID -weight [lindex $stretch $columnCount] + } + + incr columnCount + } + + incr rowID + + if {$rowCount != $rowTotal} { + ::ttk::frame $options(name).space:$rowID:$columnID -height 4 -width 4 + grid $options(name).space:$rowID:$columnID -row $rowID -column 0 -sticky ns -columnspan 3 + grid rowconfigure $options(name) $rowID -weight $weightY + incr rowID + } elseif {! $weightY && ! $attachNS} { + ::ttk::frame $options(name).space:$rowID:$columnID -height 4 -width 4 + grid $options(name).space:$rowID:$columnID -row $rowID -column 0 -sticky ns -columnspan 3 + grid rowconfigure $options(name) $rowID -weight 1 + } + + incr rowCount + } + + foreach stretch $options(-stretch) { + grid columnconfigure $options(name) [expr {(($stretch + 1) * 3) - 1}] -weight 1 + } + + gpSetTabOrder $options(name) + + if {$options(-wtitle) ne ""} { + wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] + } +} + +#=======================================================================# +# PROC : ::gridplus::gpInit # +# PURPOSE: Gridplus initailise. # +#=======================================================================# + +proc ::gridplus::gpInit {} { + variable gpConfig + variable gpInfo + variable gpOptionSets + variable gpValidation + + wm resizable . 0 0 + + set gpInfo(.:toplevel) 1 + set gpInfo(.:modal) 0 + set gpInfo() {} + + ttk::label .gpWidthFactor -width 1 + set gpInfo() [winfo reqwidth .gpWidthFactor] + destroy .gpWidthFactor + + if {[namespace exists "::starkit"]} { + set iconPath [file join $::starkit::topdir lib] + } else { + set iconPath [file join [info library]] + } + + array set gpConfig [list \ + dateformat [=< dateFormat us] \ + errormessage [=< errorMessage %] \ + iconfile [=< iconFile tkIcons] \ + iconpath [=< iconPath $iconPath] \ + locale [=< locale] \ + prefix [=< prefix] \ + proc [=< proc 0] \ + ] + + switch -- $gpConfig(dateformat) { + eu { + set gpConfig(date:day) 0 + set gpConfig(date:month) 1 + set gpConfig(date:year) 2 + set gpConfig(date:separator) . + } + iso { + set gpConfig(date:day) 2 + set gpConfig(date:month) 1 + set gpConfig(date:year) 0 + set gpConfig(date:separator) - + } + uk { + set gpConfig(date:day) 0 + set gpConfig(date:month) 1 + set gpConfig(date:year) 2 + set gpConfig(date:separator) / + } + us { + set gpConfig(date:day) 1 + set gpConfig(date:month) 0 + set gpConfig(date:year) 2 + set gpConfig(date:separator) / + } + } + + set gpConfig(date:century) [=< century 50] + + array set gpValidation { + alpha {^[a-zA-Z]+$} + alphanum {^[a-zA-Z0-9]+$} + date {proc:gpValidateDate} + decimal {trim:^[0-9]+[.][0-9]+$} + -decimal {trim:^(-)?[0-9]+[.][0-9]+$} + money {trim:^[0-9]+[.][0-9][0-9]$} + -money {trim:^(-)?[0-9]+[.][0-9][0-9]$} + num {trim:^[0-9]+([.][0-9]+)?$} + -num {trim:^(-)?[0-9]+([.][0-9]+)?$} + int {trim:^[0-9]+$} + -int {trim:^(-)?[0-9]+$} + notnull {[^\000]} + ! {[^\000]} + alpha:text {Alpha} + alphanum:text {Alphanumeric} + date:text {Date} + decimal:text {Decimal} + -decimal:text {Decimal} + money:text {Money Format} + -money:text {Money Format} + num:text {Numeric} + -num:text {Numeric} + int:text {Integer} + -int:text {Integer} + notnull:text {Not Null} + !:text {Non Blank} + } + + set gpOptionSets(.) { + -space 0 + -style {} + } + + ::gridplus::gpCreateIcons + + ::gridplus::gpEditMenuCreate {} + + bind . "::gridplus::gpWindowBindings . %W 1" + bind . "::gridplus::gpWindowBindings . %W 1" +} + +#=======================================================================# +# PROC : ::gridplus::gpInsertText # +# PURPOSE: Inserts "tagged" data into text widget. # +#=======================================================================# + +proc ::gridplus::gpInsertText {name tag end parameter position text} { + upvar 1 options options + + global {} + + variable gpInfo + + if {! [regexp -- {^[.]([^.]+)[.]} $name -> window]} { + set window {} + } + + set command false + set imageCommand {} + set imageInfo {} + set imageLink {} + set imageParameter {} + set link false + set bgColor $gpInfo($name:bgcolor) + set fgColor $gpInfo($name:fgcolor) + set linkColor $gpInfo($name:link) + set setCommand 0 + set validate 0 + + switch -- $end$tag { + init {set gpInfo($name:font) $gpInfo($name:defaultfont) + set gpInfo($name:size) 10 + set gpInfo($name:weight) normal + set gpInfo($name:slant) roman + set gpInfo($name:underline) false} + b {set gpInfo($name:weight) bold} + /b {set gpInfo($name:weight) normal} + bgcolor {set bgColor [lindex [split $parameter :] 0] + set bgParameter [lindex [split $parameter :] 1] + if {$bgParameter eq "default"} {set gpInfo($name:defaultbg) $bgColor} + set gpInfo($name:bgcolor) $bgColor} + /bgcolor {set bgColor $gpInfo($name:defaultbg) + set gpInfo($name:bgcolor) $gpInfo($name:defaultbg)} + color {set fgColor [lindex [split $parameter :] 0] + set fgParameter [lindex [split $parameter :] 1] + if {$fgParameter eq "default"} {set gpInfo($name:defaultfg) $fgColor} + set gpInfo($name:fgcolor) $fgColor} + /color {set fgColor $gpInfo($name:defaultfg) + set gpInfo($name:fgcolor) $gpInfo($name:defaultfg)} + command {set fgColor $gpInfo($name:normalcolor) + set gpInfo($name:underline) $gpInfo($name:normalstyle) + set command [lindex [split $parameter :] 0] + set commandParameter [lindex [split $parameter :] 1] + if {$commandParameter eq ""} {set commandParameter $text}} + font {set font [lindex [split $parameter :] 0] + set fontParameter [lindex [split $parameter :] 1] + if {$fontParameter eq "default"} {set gpInfo($name:defaultfont) $font} + set gpInfo($name:font) $font} + /font {set gpInfo($name:font) $gpInfo($name:defaultfont)} + i {set gpInfo($name:slant) italic} + /i {set gpInfo($name:slant) roman} + image {set imageInfo $parameter} + indent {set gpInfo($name:indent) $parameter + set tabs [string repeat "\t" $parameter] + set text "$tabs$text"} + /indent {set gpInfo($name:indent) 0} + label {set label [lindex [split $parameter :] 0] + set labelParameter [lindex [split $parameter :] 1] + if {$labelParameter eq "default"} {set ($name) $label} + $name.text mark set $label "insert wordstart" + $name.text mark gravity $label left} + link {set fgColor $gpInfo($name:normalcolor) + set gpInfo($name:underline) $gpInfo($name:normalstyle) + set link $parameter} + size {set size [lindex [split $parameter :] 0] + set sizeParameter [lindex [split $parameter :] 1] + if {$sizeParameter eq "default"} {set gpInfo($name:defaultsize) $size} + set gpInfo($name:size) [gridplus::gpSetFontSize $gpInfo($name:defaultsize) $size]} + /size {set gpInfo($name:size) $gpInfo($name:defaultsize)} + tab {if {$parameter eq ""} {set parameter 1} + set tabs [string repeat "\t" $parameter] + set text "$tabs$text"} + u {set gpInfo($name:underline) true} + /u {set gpInfo($name:underline) false} + } + + set tagName "tag[incr gpInfo($name:tagid)]" + set font "-family $gpInfo($name:font) -size $gpInfo($name:size) -slant $gpInfo($name:slant) -underline $gpInfo($name:underline) -weight $gpInfo($name:weight)" + set indent "[expr {$gpInfo($name:indent) * 0.5}]c" + + $name.text tag configure $tagName -lmargin1 $indent -lmargin2 $indent -background $bgColor -foreground $fgColor -font "$font" + + if {$imageInfo ne ""} { + if {[string match *@* $imageInfo]} { + set image [lindex [split $imageInfo @] 0] + set imageLink [lindex [split $imageInfo @] 1] + } else { + set image [lindex [split $imageInfo ~] 0] + set imageCommand [lindex [split [lindex [split $imageInfo ~] 1] :] 0] + set imageParameter [lindex [split [lindex [split $imageInfo ~] 1] :] 1] + + if {$imageCommand ne ""} { + set setCommand 1 + set imageCommand "$name,$imageCommand" + + if {$gpInfo($name:proc)} { + set imageCommand "set ::gridplus::gpInfo() \[focus\];gpProc $imageCommand" + } else { + set imageCommand "set ::gridplus::gpInfo() \[focus\];$gpInfo($name:prefix)$imageCommand" + regsub -all {[.]} $imageCommand ":" imageCommand + regsub {;:} $imageCommand ";" imageCommand + } + } + } + + if {[string match :* $image]} { + set icon [string range $image 1 end] + set image "::icon::$icon" + ::icons::icons create -file $gpInfo($name:iconlibrary) $icon + } + + set imageName [$name.text image create end -image $image] + + $name.text tag add $imageName $imageName + $name.text tag configure $imageName -background $bgColor + + if {$imageLink ne ""} { + $name.text tag bind $imageName "$name.text configure -cursor $gpInfo($name:linkcursor)" + $name.text tag bind $imageName "$name.text configure -cursor {}" + $name.text tag bind $imageName "set ($name) $imageLink; $name.text yview $imageLink" + } elseif {$setCommand} { + $name.text tag bind $imageName "$name.text configure -cursor $gpInfo($name:linkcursor)" + $name.text tag bind $imageName "$name.text configure -cursor {}" + $name.text tag bind $imageName "set ($name) \"$imageParameter\"; ::gridplus::gpCommand {$imageCommand} .$window $validate" + } + } + + if {$command ne "false"} { + + set command "$name,$command" + + if {$gpInfo($name:proc)} { + set command "set ::gridplus::gpInfo() \[focus\];gpProc $command" + } else { + set command "set ::gridplus::gpInfo() \[focus\];$gpInfo($name:prefix)$command" + regsub -all {[.]} $command ":" command + regsub {;:} $command ";" command + } + + $name.text tag bind $tagName "$name.text configure -cursor $gpInfo($name:linkcursor); $name.text tag configure $tagName -foreground $gpInfo($name:overcolor) -underline $gpInfo($name:overstyle)" + $name.text tag bind $tagName "$name.text configure -cursor {}; $name.text tag configure $tagName -foreground $gpInfo($name:normalcolor) -underline $gpInfo($name:normalstyle)" + $name.text tag bind $tagName "set ($name) \"$commandParameter\"; ::gridplus::gpCommand {$command} .$window $validate" + + set gpInfo($name:underline) false + } + + if {$link ne "false"} { + $name.text tag bind $tagName "$name.text configure -cursor $gpInfo($name:linkcursor); $name.text tag configure $tagName -foreground $gpInfo($name:overcolor) -underline $gpInfo($name:overstyle)" + $name.text tag bind $tagName "$name.text configure -cursor {}; $name.text tag configure $tagName -foreground $gpInfo($name:normalcolor) -underline $gpInfo($name:normalstyle)" + $name.text tag bind $tagName "set ($name) $link; $name.text yview $link" + set gpInfo($name:underline) false + } + + if {$text ne ""} { + regsub -all {!b:} $text "\u2022" text + regsub -all {!ob:} $text \{ text + regsub -all {!cb:} $text \} text + regsub -all {!bs:} $text {\\} text + regsub -all {!lt:} $text {<} text + regsub -all {!gt:} $text {>} text + $name.text insert $position $text $tagName + } +} + +#=======================================================================# +# PROC : ::gridplus::gpLabelframe # +# PURPOSE: Implements work-around to deal with ttk::labelframe bug. # +#=======================================================================# + +proc ::gridplus::gpLabelframe {} { + upvar 1 options options + + if {$options(-relief) eq "theme"} { + if {$options(-title) eq ""} { + ::ttk::labelframe $options(name) -padding $options(-padding) + ::ttk::separator $options(name).separator -orient horizontal + $options(name) configure -labelwidget $options(name).separator -labelanchor s + } else { + if {$options(-labelanchor) eq ""} { + ::ttk::labelframe $options(name) -padding $options(-padding) -text [mc $options(-title)] + } else { + ::ttk::labelframe $options(name) -labelanchor $options(-labelanchor) -padding $options(-padding) -text [mc $options(-title)] + } + } + } else { + ::ttk::frame $options(name) -padding $options(-padding) -relief $options(-relief) + } +} + +#=======================================================================# +# PROC : ::gridplus::gpLayout # +# PURPOSE: Create layout. # +#=======================================================================# + +proc ::gridplus::gpLayout {} { + upvar 1 options options + + global {} + + variable gpTabOrder + + set rowCount 0 + set layout(items) {} + set toplevel {} + + set setWeights 0 + set columnWeight1 {} + set rowWeight1 {} + + set maxColumn 0 + set maxRow 0 + + if {$options(-subst)} { + if {[=< substCommandLayout [=< substCommand 0]]} { + set options(layout) [subst -nobackslashes $options(layout)] + } else { + set options(layout) [subst -nobackslashes -nocommands $options(layout)] + } + } + + foreach row [split $options(layout) "\n"] { + set columnCount 0 + set rowIncr 1 + foreach column $row { + set columnIncr 1 + set setXweight 0 + set setYweight 0 + set sticky {} + + if {$column eq "="} {set column ".="} + if {$column eq "|"} {set column ".|"} + + regexp -- {(^[^:]+)(:([nsewc]+$)?)} $column -> column -> sticky + + if {[regexp -- {(^[.][^|]+)([|]([nsewc]+$)?)} $column -> column -> sticky]} { + set setXweight 1 + } + if {[regexp -- {(^[.][^=]+)([=]([nsewc]+$)?)} $column -> column -> sticky]} { + set setYweight 1 + } + if {[regexp -- {(^[.][^+]+)([+]([nsewc]+$)?)} $column -> column -> sticky]} { + set setXweight 1 + set setYweight 1 + } + + set layout($column:xweight) 1 + set layout($column:yweight) 1 + + if {$setXweight} {set layout($column:xweight) 0} + if {$setYweight} {set layout($column:yweight) 0} + + switch -- $sticky { + c {set sticky {}} + "" {set sticky w} + } + switch -glob -- $column { + .* { + if {$column eq ".="} { + ::ttk::separator $options(name):line:$columnCount:$rowCount -orient horizontal + set sticky "nsew" + set column $options(name):line:$columnCount:$rowCount + set layout($column:yweight) 0 + } + if {$column eq ".|"} { + ::ttk::separator $options(name):line:$columnCount:$rowCount -orient vertical + set sticky "nsew" + set column $options(name):line:$columnCount:$rowCount + set layout($column:xweight) 0 + } + set column [regsub -all -- {%} $column [string range $options(name) 1 end]] + lappend layout(items) $column + set layout(cell:$columnCount,$rowCount) $column + set layout($column:x) $columnCount + set layout($column:y) $rowCount + set layout($column:xspan) 1 + set layout($column:yspan) 1 + set layout($column:sticky) $sticky + if {$options(-taborder) eq "column"} { + set gpTabOrder([format "%s:%03d%03d001" $options(name) $columnCount $rowCount]) $column + } else { + set gpTabOrder([format "%s:%03d%03d001" $options(name) $rowCount $columnCount]) $column + } + } + - { + if {$columnCount == 0} {error "GRIDPLUS ERROR (layout): Column span not valid in first column"} + set previousColumn [expr {$columnCount - 1}] + set cell $layout(cell:$previousColumn,$rowCount) + set layout(cell:$columnCount,$rowCount) $layout(cell:$previousColumn,$rowCount) + incr layout($cell:xspan) + } + ^ { + if {$rowCount == 0} {error "GRIDPLUS ERROR (layout): Row span not valid in first row"} + set previousRow [expr {$rowCount - 1}] + set previousCell [expr {$columnCount - 1}] + set cell $layout(cell:$columnCount,$previousRow) + set layout(cell:$columnCount,$rowCount) $layout(cell:$columnCount,$previousRow) + if {! ([info exists layout(cell:$previousCell,$rowCount)] && $layout(cell:$previousCell,$rowCount) eq $cell)} { + incr layout($cell:yspan) + } + } + x { + } + > { + set setWeights 1 + set columnIncr 0 + lappend rowWeight1 $rowCount + } + v { + set setWeights 1 + set rowIncr 0 + lappend columnWeight1 $columnCount + } + ~ { + set setWeights 1 + } + default { + error "GRIDPLUS ERROR (layout): Invalid item/option ($column)" + } + } + if {$columnCount > $maxColumn} {set maxColumn $columnCount} + incr columnCount $columnIncr + } + if {$rowCount > $maxRow} {set maxRow $rowCount} + incr rowCount $rowIncr + } + + if {$options(-wtitle) ne "" && [regexp {([.][^.]*)[.].+$} $options(name) -> window]} { + wm title $window [mc $options(-wtitle)] + } + + ::gridplus::gpLabelframe + + foreach item $layout(items) { + set padxLeft $options(-padx) + set padxRight $options(-padx) + + if {$layout($item:x) == 0} { + set padxLeft 0 + } + if {[expr {$layout($item:x) + $layout($item:xspan)}] == $columnCount} { + set padxRight 0 + } + + set padyTop $options(-pady) + set padyBottom $options(-pady) + + if {$layout($item:y) == 0} { + set padyTop 0 + } + if {[expr {$layout($item:y) + $layout($item:yspan)}] == $rowCount} { + set padyBottom 0 + } + + set padx [list $padxLeft $padxRight] + set pady [list $padyTop $padyBottom] + + grid configure $item -in $options(name) -column $layout($item:x) -row $layout($item:y) -columnspan $layout($item:xspan) -rowspan $layout($item:yspan) -sticky $layout($item:sticky) -padx $padx -pady $pady + + if {[info exists layout($item:xweight)]} { + set xweight $layout($item:xweight) + } else { + set xweight 1 + } + if {[info exists layout($item:yweight)]} { + set yweight $layout($item:yweight) + } else { + set yweight 1 + } + + grid columnconfigure $options(name) $layout($item:x) -weight $xweight + grid rowconfigure $options(name) $layout($item:y) -weight $yweight + gpSetTabOrder $options(name) + } + + if {$setWeights} { + for {set rowCount 0} {$rowCount <= $maxRow} {incr rowCount} { + if {[lsearch $rowWeight1 $rowCount] > -1} { + grid rowconfigure $options(name) $rowCount -weight 1 + } else { + grid rowconfigure $options(name) $rowCount -weight 0 + } + } + + for {set columnCount 0} {$columnCount <= $maxColumn} {incr columnCount} { + if {[lsearch $columnWeight1 $columnCount] > -1} { + grid columnconfigure $options(name) $columnCount -weight 1 + } else { + grid columnconfigure $options(name) $columnCount -weight 0 + } + } + } + + if {$options(-wtitle) ne ""} { + wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] + } +} + +#=======================================================================# +# PROC : ::gridplus::gpLine # +# PURPOSE: Gridplus create line. # +#=======================================================================# + +proc ::gridplus::gpLine {} { + upvar 1 options options + + if {$options(-background) eq ""} { + set background [. cget -background] + } else { + set background $options(-background) + } + + if {$options(-title) ne ""} { + frame $options(name) -background $background -padx $options(-padx) -pady $options(-pady) + frame $options(name).left -background $background -borderwidth 2 -height 2 -relief sunken -width 5 + frame $options(name).right -background $background -borderwidth 2 -height 2 -relief sunken + label $options(name).label -background $background -text [mc $options(-title)] -borderwidth 1 + grid configure $options(name).left -column 0 -row 0 -sticky ew + grid configure $options(name).label -column 1 -row 0 + grid configure $options(name).right -column 2 -row 0 -sticky ew + grid columnconfigure $options(name) 2 -weight 1 + } else { + frame $options(name) -background $background -borderwidth $options(-borderwidth) -height $options(-linewidth) -padx $options(-padx) -pady $options(-pady) -relief $options(-linerelief) -width $options(-linewidth) + } +} + +#=======================================================================# +# PROC : ::gridplus::gpMenu # +# PURPOSE: Create menu(bar). # +#=======================================================================# + +proc ::gridplus::gpMenu {} { + upvar 1 options options + + if {$options(name) eq "."} { + set rootMenu .menubar + $options(name) configure -menu $rootMenu + } elseif {[winfo exists $options(name)] && [winfo class $options(name)] eq "Toplevel"} { + set rootMenu $options(name).menubar + $options(name) configure -menu $rootMenu + } else { + set rootMenu $options(name) + } + + menu $rootMenu + + $rootMenu configure -tearoff 0 + + set rootMenuIndex 0 + + foreach {menuLabel menuEntries} $options(layout) { + set underline [string first "_" $menuLabel] + regsub -all -- {_} $menuLabel {} menuLabel + + if {$menuLabel eq "~"} { + ::gridplus::gpMenuOption $rootMenu {} $rootMenuIndex $menuEntries + incr rootMenuIndex + continue + } + + if {[string match @* $menuEntries]} { + set cascade ".[string range $menuEntries 1 end]" + $rootMenu add cascade -label [mc $menuLabel] -menu $cascade -underline $underline + continue + } + + set menu [string tolower $menuLabel] + + $rootMenu add cascade -label [mc $menuLabel] -menu $rootMenu.$menu -underline $underline + menu $rootMenu.$menu + $rootMenu.$menu configure -tearoff 0 + + set menuIndex 0 + + foreach menuEntryData $menuEntries { + ::gridplus::gpMenuOption $rootMenu $menu $menuIndex $menuEntryData + incr menuIndex + } + + incr rootMenuIndex + } + +} + +#=======================================================================# +# PROC : ::gridplus::gpMenuOption # +# PURPOSE: Create menu(bar) option. # +#=======================================================================# + +proc ::gridplus::gpMenuOption {rootMenu menu menuIndex menuEntryData} { + upvar 1 options options + + variable gpInfo + + set menuEntryLabel [lindex $menuEntryData 0] + set menuEntryOptions [lrange $menuEntryData 1 end] + set underline [string first "_" $menuEntryLabel] + + regsub -all -- {_} $menuEntryLabel {} menuEntryLabel + + set menuEntry [string tolower $menuEntryLabel] + + regsub -all -- { } $menuEntry {_} menuEntry + + if {$menuEntry eq "-" || $menuEntry eq "="} { + if {$menu eq ""} { + $rootMenu add separator + } else { + $rootMenu.$menu add separator + } + } else { + if {$menu eq ""} { + set command $rootMenu,$menuEntry + set menuEntryID $rootMenu@$menuIndex + set menuName {} + } else { + set command $rootMenu:$menu,$menuEntry + set menuEntryID $rootMenu.$menu@$menuIndex + set menuName .$menu + } + set cascade {} + set compound none + set menuIcon {} + set state $options(-state) + set validate 0 + + foreach item $menuEntryOptions { + switch -regexp -- $item { + ^% { + set gpInfo($menuEntryID:group) [string range $item 1 end] + } + ^<$ { + set state disabled + } + ^>$ { + set state normal + } + ^!$ { + set validate 1 + } + ^@ { + set cascade ".[string range $item 1 end]" + } + ^[.~].+ { + set command [string range $item 1 end] + } + ^: { + set menuIcon "::icon::[::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] [string range $item 1 end]]" + set compound left + } + } + } + + if {$options(-proc)} { + set command "gpProc [::gridplus::gpCommandFormat $command]" + } else { + set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" + } + + set state [=% $menuEntryID $state] + + if {$cascade ne ""} { + $rootMenu$menuName add cascade -label [mc $menuEntryLabel] -menu $cascade -state $state -compound $compound -image $menuIcon -underline $underline + } else { + $rootMenu$menuName add command -label [mc $menuEntryLabel] -command "::gridplus::gpCommand {$command} $options(name) $validate" -state $state -compound $compound -image $menuIcon -underline $underline + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpNotebook # +# : ::gridplus::gpNotebookSet # +# PURPOSE: Create notebook. # +#=======================================================================# + +proc ::gridplus::gpNotebook {} { + upvar 1 options options + + global {} + + variable gpTabOrder + + if {$options(-subst)} { + if {[=< substCommandNotebook [=< substCommand 0]]} { + set options(layout) [subst -nobackslashes $options(layout)] + } else { + set options(layout) [subst -nobackslashes -nocommands $options(layout)] + } + } + + ::ttk::notebook $options(name) -padding $options(-padding) + + if {$options(-command) ne ""} { + set command "$options(-command) \[$options(name) index current\] \[$options(name) tab \[$options(name) index current\] -text\];" + } else { + set command "" + } + + bind $options(name) <> "${command}::gridplus::gpNotebookSet $options(name)" + + foreach {tab item} $options(layout) { + set pane [winfo name $item] + $options(name) add [::ttk::frame $options(name).$pane -padding $options(-tabpadding)] -text [mc $tab] + pack $item -in $options(name).$pane -expand 1 -fill both + } + + ::gridplus::gpNotebookSet $options(name) + + if {$options(-wtitle) ne ""} { + wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] + } +} + +proc ::gridplus::gpNotebookSet {name} { + global {} + + variable gpInfo + variable gpValidations + + if {[info exists gpInfo(validation:failed)]} { + foreach windowValidations [array names ::gridplus::gpValidations] { + foreach windowValidation $windowValidations { + foreach validationInfo $::gridplus::gpValidations($windowValidation) { + foreach {entry validation} [split $validationInfo :] {} + if {[info exists gpInfo(validation:failed)] && $gpInfo(validation:failed) eq $entry} { + if {! [::gridplus::gpValidate $entry $validation focusout - - 1]} { + ::gridplus::gpValidateFailed $entry + } + } + } + } + } + + if {[info exists gpInfo(validation:failed)]} { + ::gridplus::gpNotebookIn $gpInfo(validation:failed) + return + } + } + + variable gpTabOrder + + set pane [$name index current] + set panes [$name tabs] + + #!FIX + # regsub -all .[winfo name $name] [lindex $panes $pane] {} item + regsub .[winfo name $name] [lindex $panes $pane] {} item + + set gpTabOrder($name:000000) $item + + gpSetTabOrder $name +} + +#=======================================================================# +# PROC : ::gridplus::gpOptionAlias # +# PURPOSE: Set value for option with "alias". # +#=======================================================================# + +proc ::gridplus::gpOptionAlias {option alias} { + upvar 1 options options + + if {$options($option) ne ""} {return $options($option)} + if {$options($alias) ne ""} {return $options($alias)} + + return {} +} + +#=======================================================================# +# PROC : ::gridplus::gpOptionset # +# PURPOSE: Create optionset. # +#=======================================================================# + +proc ::gridplus::gpOptionset {} { + upvar 1 options options + + variable gpOptionSets + + set gpOptionSets($options(name)) $options(layout) + + if {[lsearch $gpOptionSets($options(name)) -style] < 0 && [=< optionsetDefaultStyle 0]} { + lappend gpOptionSets($options(name)) -style {} + } +} + +#=======================================================================# +# PROC : ::gridplus::gpPack # +# PURPOSE: Pack specified layout where resizing is required. # +#=======================================================================# + +proc ::gridplus::gpPack {} { + upvar 1 options options + + if {$options(-resize) eq ""} { + pack $options(name) + return + } + + if {! [regexp -- {(^[.][^.]+)[.]} $options(name) -> window]} { + set window "." + } + + set resizeX 0 + set resizeY 0 + + switch -- $options(-resize) { + x {set resizeX 1} + y {set resizeY 1} + xy {set resizeX 1; set resizeY 1} + } + + wm minsize $window 1 1 + + update idletasks + + pack $options(name) -expand 1 -fill both + + update idletasks + + regexp -- {^([0-9]+)x([0-9]+)} [wm geometry $window] -> width height + + set width [expr {int(($width / 100.0) * $options(-minx))}] + set height [expr {int(($height / 100.0) * $options(-miny))}] + + wm minsize $window $width $height + wm resizable $window $resizeX $resizeY +} + +#=======================================================================# +# PROC : ::gridplus::gpPane # +# PURPOSE: Create paned window. # +#=======================================================================# + +proc ::gridplus::gpPane {} { + upvar 1 options options + + variable gpInfo + variable gpTabOrder + + ::gridplus::gpLabelframe + + if {[llength [lindex [split $options(layout) "\n"] 0]] > 1} { + set orient horizontal + } else { + set orient vertical + } + + set paneCount 1 + + ::ttk::panedwindow $options(name).pane -height $options(-height) -width $options(-width) -orient $orient + + foreach row [split $options(layout) "\n"] { + set columnCount 0 + + foreach column $row { + if {[regexp -- {(^[^:+|=]+)[:+|=]} $column -> column]} { + set weight 1 + } else { + set weight 0 + } + + $options(name).pane insert end $column + + $options(name).pane pane $column -weight $weight + + set gpTabOrder([format "%s:000000%03d" $options(name) $paneCount]) $column + incr paneCount + } + } + + pack $options(name).pane -expand 1 -fill both + + gpSetTabOrder $options(name) +} + +#=======================================================================# +# PROC : ::gridplus::gpParseEmbeddedGrid # +# PURPOSE: If column contains embedded grid, parse it. # +#=======================================================================# + +proc ::gridplus::gpParseEmbeddedGrid {column} { + + if {! [regexp -- {[|][|:>&<=]} $column]} {return $column} + + set left {} + set right {} + + regsub -- {[|]:[|]} $column {|: __gpBar__ |:} column + regsub -- {[|]>[|]} $column {|> __gpBar__ |:} column + regsub -- {[|]<[|]} $column {|: __gpBar__ |>} column + regsub -- {[|]=[|]} $column {|> __gpBar__ |>} column + + if {"||" in $column} { + regexp -- {^(.*)\|\|(.*)$} $column -> left right + + if {[regexp -- {[|][:>&]} $left]} { + set grid [gpEmbeddedGridParse $left] + set side left + } else { + set label $left + } + + if {[regexp -- {[|][:>&]} $right]} { + set grid [gpEmbeddedGridParse $right] + set side right + } else { + set label $right + } + } else { + set grid [gpEmbeddedGridParse $column] + set side both + } + + switch -- $side { + left {return "$grid .:ew $label"} + right {return "$grid $label .:ew"} + both {return "$grid .:ew"} + } +} + +proc ::gridplus::gpEmbeddedGridParse {grid} { + + set columns {} + set stretch {} + set defaultWidget grid + set leftStretch 0 + set rightStretch 1 + set style {} + set widgetOptions {} + + if {[regexp -- {^(.+) [|][:]$} $grid -> left]} { + set grid $left + set leftStretch 1 + set rightStretch 0 + } + + if {[regexp -- {[|][#]([^ ]*)} $grid -> style]} { + regsub -- {[|][#]([^ ]*)} $grid {} grid + if {$style eq ""} {set style %} + } + + if {[regexp -- {[|][&]([^ ]*)} $grid -> defaultWidget]} { + regsub -- {[|][&]([^ ]*)} $grid {} grid + if {$defaultWidget eq ""} {set defaultWidget "grid"} + } + + if {[regexp -- {[|][(](.*)[)]} $grid -> widgetOptions]} { + regsub -- {[|][(](.*)[)]} $grid {} grid + regsub -- {\&} $widgetOptions {\\&} widgetOptions + if {$widgetOptions ne ""} { + set newGrid {} + foreach item $grid { + set item [list $item] + if {[string match ".*" $item]} { + set item "$widgetOptions $item" + } + set newGrid "$newGrid $item" + } + set grid $newGrid + } + } + + while {[regexp -- {^([^|]*)([|][:>])(.*)$} $grid -> left op right]} { + lappend columns $left + switch -- $op { + |: {lappend stretch 0} + |> {lappend stretch 1;set rightStretch 0} + } + + set grid $right + } + + lappend columns $grid + + regsub -- {__gpBar__} $columns {|} columns + + set stretch "$leftStretch $stretch $rightStretch" + + return "{&& {$stretch} {$defaultWidget} {$style} $columns}" +} + +#=======================================================================# +# PROC : ::gridplus::gpParseTags # +# PURPOSE: Parse tags for text widget. # +#=======================================================================# + +proc ::gridplus::gpParseTags {name tagText position} { + + regsub -all \{ $tagText {!ob:} tagText + regsub -all \} $tagText {!cb:} tagText + regsub -all {\\} $tagText {!bs:} tagText + + set whitespace " \t\r\n" + set pattern <(/?)(\[^$whitespace>]+)\[$whitespace]*(\[^>]*)> + + set substitute "\}\n::gridplus::gpInsertText $name {\\2} {\\1} {\\3} $position \{" + regsub -all $pattern $tagText $substitute tagText + + eval "::gridplus::gpInsertText $name {init} {} {} $position {$tagText}" +} + +#=======================================================================# +# PROC : ::gridplus::gpSet # +# PURPOSE: Gridplus Set values. # +#=======================================================================# + +proc ::gridplus::gpSet {} { + upvar 1 options options + + variable gpConfig + variable gpInfo + variable gpValidation + + foreach option [array names options -*] { + switch -- $option { + -century { + set gpConfig(date:century) $options(-century) + } + -dateformat { + switch -- $options(-dateformat) { + eu { + set gpConfig(date:day) 0 + set gpConfig(date:month) 1 + set gpConfig(date:year) 2 + set gpConfig(date:separator) . + } + iso { + set gpConfig(date:day) 2 + set gpConfig(date:month) 1 + set gpConfig(date:year) 0 + set gpConfig(date:separator) - + } + uk { + set gpConfig(date:day) 0 + set gpConfig(date:month) 1 + set gpConfig(date:year) 2 + set gpConfig(date:separator) / + } + us { + set gpConfig(date:day) 1 + set gpConfig(date:month) 0 + set gpConfig(date:year) 2 + set gpConfig(date:separator) / + } + default { + error "GRIDPLUS ERROR: Invalid date format ($options(-dateformat))." + return + } + } + set gpConfig(dateformat) $options(-dateformat) + } + -errormessage { + set gpConfig(errormessage) $options(-errormessage) + } + -group { + set gpInfo($options(-group)) $options(-state) + ::gridplus::gpSetGroup + } + -locale { + set gpConfig(locale) $options(-locale) + } + -prefix { + set gpConfig(prefix) $options(-prefix) + } + -proc { + set gpConfig(proc) $options(-proc) + } + -validation { + if {$options(-pattern) ne ""} { + set gpValidation($options(-validation)) $options(-pattern) + if {$options(-text) ne ""} { + set gpValidation($options(-validation):text) $options(-text) + } else { + set gpValidation($options(-validation):text) $options(-validation) + } + } + + } + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpSetFont # +# PURPOSE: Gridplus Set font attributes. # +#=======================================================================# + +proc ::gridplus::gpSetFont {attributes} { + + set font [dict create {*}[font configure TkDefaultFont]] + + if {[dict get $font -size] < 0} { + set sign "-" + } else { + set sign "" + } + + foreach attribute $attributes { + switch -regexp -- $attribute { + {^[0-9]+$} { + set font [dict replace $font -size $attribute] + } + {^[+][0-9]+$} { + set font [dict replace $font -size $sign[expr {abs([dict get $font -size]) + $attribute}]] + } + {^[-][0-9]+$} { + set font [dict replace $font -size $sign[expr {abs([dict get $font -size]) - $attribute}]] + } + {^bold$} { + set font [dict replace $font -weight bold] + } + {^underline$} { + set font [dict replace $font -underline 1] + } + {^italic$} { + set font [dict replace $font -slant italic] + } + } + } + + return "[lrange $font 2 end] [lrange $font 0 1]" +} + +#=======================================================================# +# PROC : ::gridplus::gpSetFontSize # +# PURPOSE: Gridplus Set font size for "tagged" text widget. # +#=======================================================================# + +proc ::gridplus::gpSetFontSize {defaultSize newSize} { + + switch -regexp -- $newSize { + {^[0-9]+$} { + set fontSize $newSize + } + {^[+][0-9]+$} { + set value [string range $newSize 1 end] + set fontSize [expr {$defaultSize + $value}] + } + {^[-][0-9]+$} { + set value [string range $newSize 1 end] + set fontSize [expr {$defaultSize - $value}] + } + default { + set fontSize $defaultSize + } + } + + return $fontSize +} + +#=======================================================================# +# PROC : ::gridplus::gpSetGroup # +# PURPOSE: Gridplus Set widgets state to "group" state. # +#=======================================================================# + +proc ::gridplus::gpSetGroup {} { + variable gpInfo + + foreach groupItem [array names gpInfo *:group] { + set item [string map {:group {}} $groupItem] + if { [info exists gpInfo($gpInfo($item:group))] } { + if {[regexp {^([^@]+)@(.+)$} $item -> configureItem index]} { + $configureItem entryconfigure $index -state $gpInfo($gpInfo($item:group)) + } else { + if {[string match *Entry [winfo class $item]] && $gpInfo($gpInfo($item:group)) eq "disabled"} { + $item configure -state [=< entryDisabled readonly] + } elseif {[winfo class $item] in "TSpinbox TCombobox" && $gpInfo($gpInfo($item:group)) eq "normal"} { + $item configure -state readonly + } else { + $item configure -state $gpInfo($gpInfo($item:group)) + } + } + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpSetOptionset # +# PURPOSE: Set optionset options. # +#=======================================================================# + +proc ::gridplus::gpSetOptionset {} { + upvar 1 options options + + variable gpOptionSets + + if {$options(-optionset) eq ""} { + if {$options(-style) ne "" && [info exists gpOptionSets($options(-style))] && [=< optionSetStyle 1]} { + set options(-optionset) $options(-style) + } else { + return + } + } + + if {[info exists gpOptionSets($options(-optionset))]} { + foreach {option value} $gpOptionSets($options(-optionset)) { + if {$option eq "-pad"} { + set options(-padx) $value + set options(-pady) $value + } else { + set options($option) $value + } + } + } else { + error "GRIDPLUS ERROR: Invalid optionset ($options(-optionset))." + } +} + +#=======================================================================# +# PROC : ::gridplus::gpSetTabOrder # +# PURPOSE: Gridplus Set widgets to correct "tab" order. # +#=======================================================================# + +proc ::gridplus::gpSetTabOrder {name} { + variable gpTabOrder + + foreach item [lsort [array names gpTabOrder $name:*]] { + raise $gpTabOrder($item) + ::gridplus::gpSetTabOrder $gpTabOrder($item) + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelist # +# PURPOSE: Create tablelist. # +#=======================================================================# + +proc ::gridplus::gpTablelist {} { + upvar 1 options options + + global {} + + variable gpInfo + + if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { + set window {} + } + + set gpInfo($options(name):action) $options(-action) + set gpInfo($options(name):columnsort) $options(-columnsort) + set gpInfo($options(name):iconlibrary) [file join $options(-iconpath) $options(-iconfile)] + set gpInfo($options(name):insertexpr) $options(-insertexpr) + set gpInfo($options(name):insertoptions) $options(-insertoptions) + set gpInfo($options(name):maintainsort) $options(-maintainsort) + set gpInfo($options(name):selectfirst) $options(-selectfirst) + set gpInfo($options(name):selectmode) $options(-selectmode) + set gpInfo($options(name):selectpage) $options(-selectpage) + set gpInfo($options(name):sortorder) $options(-sortorder) + set gpInfo($options(name):validate) $options(-validate) + set gpInfo($options(name):window) .$window + + if {[regsub -all -- {/[^/\} ]*} $options(-insertoptions) {} gpInfo($options(name):trueOptions)]} { + regsub -all -- {[^/\} ]*/} $options(-insertoptions) {} gpInfo($options(name):falseOptions) + } else { + set gpInfo($options(name):trueOptions) $options(-insertoptions) + set gpInfo($options(name):falseOptions) {} + } + + set state $options(-state) + + if {$options(-group) ne ""} { + set gpInfo($options(name).tablelist:group) $options(-group) + } + + set state [=% $options(name).tablelist $state] + +#-------------------------------------# +# Deal with "hide" columns in layout. # +#-------------------------------------# + + set column -1 + set columnNames {} + set count 0 + set first 0 + set hide {} + set index 0 + set sortASCIInocase {} + set sortDictionary {} + set sortInteger {} + set sortReal {} + + foreach item $options(layout) { + + if {[string is integer $item]} { + set count 0 + incr column + } + + if {$item in {asciinocase dicionary hide integer real} && $count > 1} { + switch -- $item { + asciinocase {lappend sortASCIInocase $column} + dictionary {lappend sortDictionary $column} + hide {lappend hide $column} + integer {lappend sortInteger $column} + real {lappend sortReal $column} + } + set options(layout) [lreplace $options(layout) $index $index] + incr index -1 + if {$item eq "hide" && $column == $first} { + incr first + } + } + + if {[string match =* $item]} { + lappend columnNames [list $column [string range $item 1 end]] + set options(layout) [lreplace $options(layout) $index $index] + incr index -1 + } + + incr count + incr index + } + + if {$options(-sortfirst)} { + set gpInfo($options(name):firstcolumn) 0 + } else { + set gpInfo($options(name):firstcolumn) $first + } + + set gpInfo($options(name):seeinsert) $options(-seeinsert) + + ::gridplus::gpLabelframe + + tablelist::tablelist $options(name).tablelist \ + -columns $options(layout) \ + -exportselection 0 \ + -height $options(-height) \ + -listvariable $options(-listvariable) \ + -selectmode $options(-selectmode) \ + -state $state \ + -stretch all \ + -width $options(-width) \ + -xscrollcommand [list $options(name).xbar set] \ + -yscrollcommand [list $options(name).ybar set] \ + -takefocus $options(-takefocus) \ + + if {$options(-columnsort)} { + $options(name).tablelist configure -labelcommand ::gridplus::gpTablelistSort + } + + ::ttk::scrollbar $options(name).xbar -orient horizontal -command [list $options(name).tablelist xview] + ::ttk::scrollbar $options(name).ybar -orient vertical -command [list $options(name).tablelist yview] + + foreach item $hide { + $options(name).tablelist columnconfigure $item -hide 1 + } + + foreach item $sortASCIInocase { + $options(name).tablelist columnconfigure $item -sortmode "asciinocase" + } + + foreach item $sortDictionary { + $options(name).tablelist columnconfigure $item -sortmode "dictionary" + } + + foreach item $sortInteger { + $options(name).tablelist columnconfigure $item -sortmode "integer" + } + + foreach item $sortReal { + $options(name).tablelist columnconfigure $item -sortmode "real" + } + + for {set column 0} {$column < [$options(name).tablelist columncount]} {incr column} { + set columnName [string tolower [$options(name).tablelist columncget $column -title]] + regsub -all -- {[ ]+} $columnName {_} columnName + regsub -all -- {[^a-z0-9_]} $columnName {} columnName + $options(name).tablelist columnconfigure $column -name $columnName + } + + foreach item $columnNames { + $options(name).tablelist columnconfigure [lindex $item 0] -name [lindex $item 1] + } + + if {$options(-names) ne ""} { + ::gridplus::gpTablelistSetColumns $options(name) -name $options(-names) + } + + for {set column 0} {$column < [$options(name).tablelist columncount]} {incr column} { + lappend gpInfo($options(name):columnNames) [$options(name).tablelist columncget $column -name] + } + + grid $options(name).tablelist -row 0 -column 0 -sticky news + + switch -- $options(-scroll) { + x { + grid $options(name).xbar -row 1 -column 0 -sticky ew + } + y { + grid $options(name).ybar -row 0 -column 1 -sticky ns + } + xy { + grid $options(name).xbar -row 1 -column 0 -sticky ew + grid $options(name).ybar -row 0 -column 1 -sticky ns + } + } + + grid rowconfigure $options(name) 0 -weight 1 + grid columnconfigure $options(name) 0 -weight 1 + + foreach item $options(-tableoptions) { + switch -- $item { + stripe { + $options(name).tablelist configure -stripebackground #e0e8f0 + } + separator { + $options(name).tablelist configure -showseparators yes + } + } + } + + foreach unknownItem [array names gpInfo *] { + set unknownOption [string map { {}} $unknownItem] + $options(name).tablelist configure $unknownOption $gpInfo($unknownItem) + } + + if {$options(-proc)} { + set command "gpProc [::gridplus::gpCommandFormat $options(name)]" + } else { + if {$options(-command) eq ""} { + set command "$options(-prefix)[::gridplus::gpCommandFormat $options(name)]" + } else { + set command $options(-command) + } + } + + set gpInfo($options(name):command) $command + + switch -- $options(-action) { + double { + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window 0]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpCommand [list $command] .$window $options(-validate)]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window 0]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window 0]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window 0]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window 0]" + } + single { + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate) [list $command]]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate) [list $command]]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate) [list $command]]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate) [list $command]]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate) [list $command]]" + } + default { + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate)]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate)]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate)]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate)]" + bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate)]" + } + } + + if {$options(-menu) ne ""} { + bind [$options(name).tablelist bodypath] "after 1 {::gridplus::gpTablelistMenu $options(-menu) %x %y %X %Y %W $options(name)}" + } + + bind ::$options(name) "rename ::$options(name) {}" + rename ::$options(name) ::gridplus::$options(name):frame + + proc ::$options(name) {args} { + + set thisProc [lindex [info level 0] 0] + set frameProc "::gridplus::$thisProc:frame" + + if {[lindex $args 0] in "configure cget"} { + $frameProc {*}$args + } else { + ::gridplus::gpget $thisProc [lindex $args 0] + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistColumnIndex # +# PURPOSE: Returns tablelist numeric column index for column "index". # +#=======================================================================# + +proc ::gridplus::gpTablelistColumnIndex {item index caller} { + variable gpInfo + + if {[string is integer $index]} { + return $index + } else { + if {[set columnIndex [lsearch $gpInfo($item:columnNames) $index]] == -1} { + error "GRIDPLUS ERROR: ($caller) Column name \"$index\" does not exist." + } else { + return $columnIndex + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistInsert # +# PURPOSE: Inserts/updates tablelist line. # +#=======================================================================# + +proc ::gridplus::gpTablelistInsert {item position line {gpset 0} {update 0}} { + variable gpInfo + + set column 0 + set tableLine {} + + unset -nocomplain tableIcon + + foreach tableColumn $line { + if {[regexp -- {^:([^ ]+) ?} $tableColumn -> tableIcon($column)]} { + regsub -- {^:([^ ]+) ?} $tableColumn {} tableColumn + } + lappend tableLine $tableColumn + incr column + } + + if {$update} { + $item.tablelist rowconfigure $position -text $tableLine + } else { + $item.tablelist insert $position $tableLine + } + + if {[info exists tableIcon]} { + foreach iconColumn [array names tableIcon] { + set icon $tableIcon($iconColumn) + set image "::icon::$icon" + if {$image ni [image names]} {::icons::icons create -file $gpInfo($item:iconlibrary) $icon} + $item.tablelist cellconfigure $position,$iconColumn -image $image + } + } + + if {$gpInfo($item:insertexpr) ne ""} { + gpTablelistInsertExpr $item $position $line + } + + if {$gpInfo($item:seeinsert) && ! $gpset} { + update idletasks + $item.tablelist see $position + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistInsertExpr # +# PURPOSE: Expand tablelist insert expression. # +#=======================================================================# + +proc ::gridplus::gpTablelistInsertExpr {name position line} { + upvar 1 options options + + variable gpInfo + + regsub -all -- {%([a-zA-Z0-9_]+)} $gpInfo($name:insertexpr) {[lindex $line [::gridplus::gpTablelistColumnIndex $name \1 "gpTablelistInsertExpr"]]} insertExpr + + eval "if {$insertExpr} {set result 1} else {set result 0}" + + ::gridplus::gpTablelistInsertOptions $name $position $result +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistInsertOptions # +# PURPOSE: Process tablelist insert options. # +#=======================================================================# + +proc ::gridplus::gpTablelistInsertOptions {name position result} { + upvar 1 options options + + variable gpInfo + + if {$result} { + foreach insertOption $gpInfo($name:trueOptions) { + if {[lindex $insertOption 0] eq "*"} { + regsub -- {[*]} $insertOption $position insertOption + eval "$name.tablelist rowconfigure $insertOption" + } else { + eval "$name.tablelist cellconfigure $position,$insertOption" + } + } + } else { + if {$gpInfo($name:falseOptions) ne ""} { + foreach insertOption $gpInfo($name:falseOptions) { + if {[lindex $insertOption 0] eq "*"} { + regsub -- {[*]} $insertOption $position insertOption + eval "$name.tablelist rowconfigure $insertOption" + } else { + eval "$name.tablelist cellconfigure $position,$insertOption" + } + } + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistMenu # +# PURPOSE: Right-click pop-up menu for tablelist. # +#=======================================================================# + +proc ::gridplus::gpTablelistMenu {menu x y X Y W name} { + global {} + + foreach {Widget xPosition yPosition} [tablelist::convEventFields $W $x $y] {} + set row [$name.tablelist nearest $yPosition] + + $name.tablelist selection clear 0 end + $name.tablelist selection set $row + + set ($name) [$name.tablelist get $row] + + $menu post $X $Y +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistSelect # +# PURPOSE: Sets value for tablelist selections. # +#=======================================================================# + +proc ::gridplus::gpTablelistSelect {name selection window validate {command {}}} { + upvar 1 options options + + global {} + + variable gpInfo + + if {$selection eq "-"} { + if {$gpInfo($name:selectpage) && $gpInfo($name:selectmode) eq "browse"} { + $name.tablelist selection clear 0 end + $name.tablelist selection set [$name.tablelist index active] + set selection [$name.tablelist curselection] + } else { + return + } + } + + set count [llength $selection] + set value [$name.tablelist get $selection] + + if {$gpInfo($name:selectmode) eq "multiple" || $gpInfo($name:selectmode) eq "extended"} { + if {$count == 1} { + set ($name) [list $value] + } else { + set ($name) $value + } + } else { + set ($name) $value + } + + if {$command ne ""} {{*}[list ::gridplus::gpCommand $command $window $validate]} +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistSetColumns # +# PURPOSE: Set tablelist column titles/names. # +#=======================================================================# + +proc ::gridplus::gpTablelistSetColumns {name option values} { + + set column 0 + + foreach value $values { + $name.tablelist columnconfigure $column $option $value + incr column + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTablelistSort # +# PURPOSE: Sort tablelist and save last sort. # +#=======================================================================# + +proc ::gridplus::gpTablelistSort {name column} { + + variable gpInfo + + ::tablelist::sortByColumn $name $column + + set item [regsub -- {[.]tablelist$} $name {}] + + set gpInfo($item:lastsortcolumn) [$name sortcolumn] + set gpInfo($item:lastsortorder) [$name sortorder] +} + +#=======================================================================# +# PROC : ::gridplus::gpText # +# PURPOSE: Create text. # +#=======================================================================# + +proc ::gridplus::gpText {} { + upvar 1 options options + + global {} + + variable gpInfo + + set state $options(-state) + + if {$options(-group) ne ""} { + set gpInfo($options(name).text:group) $options(-group) + } + + set state [=% $options(name).text $state] + + ::gridplus::gpLabelframe + + text $options(name).text \ + -background white \ + -height $options(-height) \ + -font TkTextFont \ + -state $state \ + -tabs {0.5c 1c 1.5c 2c 2.5c 3.0c 3.5c 4.0c 4.5c 5.0c 5.5c 6.0c 6.5c 7.0c 7.5c 8.0c} \ + -takefocus $options(-takefocus) \ + -width $options(-width) \ + -wrap $options(-wrap) \ + -xscrollcommand [list $options(name).xbar set] \ + -yscrollcommand [list $options(name).ybar set] \ + + ::ttk::scrollbar $options(name).xbar -orient horizontal -command [list $options(name).text xview] + ::ttk::scrollbar $options(name).ybar -orient vertical -command [list $options(name).text yview] + + grid $options(name).text -row 0 -column 0 -sticky news + + switch -- $options(-scroll) { + x { + grid $options(name).xbar -row 1 -column 0 -sticky ew + } + y { + grid $options(name).ybar -row 0 -column 1 -sticky ns + } + xy { + grid $options(name).xbar -row 1 -column 0 -sticky ew + grid $options(name).ybar -row 0 -column 1 -sticky ns + } + } + + grid rowconfigure $options(name) 0 -weight 1 + grid columnconfigure $options(name) 0 -weight 1 + + set gpInfo($options(name):seeinsert) $options(-seeinsert) + + if {$options(-tags)} { + set normalColor [lindex [split $options(-linkcolor) /] 0] + set overColor [lindex [split $options(-linkcolor) /] 1] + set normalStyle [lindex [split $options(-linkstyle) /] 0] + set overStyle [lindex [split $options(-linkstyle) /] 1] + + regsub -- {[&]} $overStyle $normalStyle, overStyle + + if {! [string match */* $options(-linkcolor)]} {set overColor $normalColor} + if {! [string match */* $options(-linkstyle)]} {set overStyle $normalStyle} + + if {$normalColor eq ""} {set normalColor "blue"} + if {$overColor eq ""} {set overColor "blue"} + + if {$normalStyle eq "underline"} { + set normalStyle "true" + } else { + set normalStyle "false" + } + if {$overStyle eq "underline"} { + set overStyle "true" + } else { + set overStyle "false" + } + + set gpInfo($options(name):bgcolor) white + set gpInfo($options(name):defaultbg) white + set gpInfo($options(name):defaultfg) black + set gpInfo($options(name):defaultfont) helvetica + set gpInfo($options(name):defaultsize) [::gridplus::gpGetFontSize [$options(name).text cget -font]] + set gpInfo($options(name):fgcolor) black + set gpInfo($options(name):font) [lindex [$options(name).text cget -font] 0] + set gpInfo($options(name):iconlibrary) [file join $options(-iconpath) $options(-iconfile)] + set gpInfo($options(name):indent) 0 + set gpInfo($options(name):link) blue + set gpInfo($options(name):linkcursor) $options(-linkcursor) + set gpInfo($options(name):normalcolor) $normalColor + set gpInfo($options(name):normalstyle) $normalStyle + set gpInfo($options(name):overcolor) $overColor + set gpInfo($options(name):overstyle) $overStyle + set gpInfo($options(name):prefix) $options(-prefix) + set gpInfo($options(name):proc) $options(-proc) + set gpInfo($options(name):size) [::gridplus::gpGetFontSize [$options(name).text cget -font]] + set gpInfo($options(name):tagid) 0 + set gpInfo($options(name):tags) 1 + + $options(name).text configure -cursor {} -state disabled + } else { + if {$options(-font) ne ""} { + $options(name).text configure -font $options(-font) + } + + set gpInfo($options(name):tags) 0 + } + + if {$options(-menu) eq ""} { + set menuName $options(name).text.edit + + menu $menuName -tearoff 0 + + if {$options(-tags) || $options(-state) eq "disabled"} { + $options(name).text.edit add command -label [mc "Copy"] -command "tk_textCopy $options(name).text" + $options(name).text.edit add separator + $options(name).text.edit add command -label [mc "Find"] -command "::gridplus::gpTextFind $options(name).text" + } else { + $options(name).text.edit add command -label [mc "Cut"] -command "tk_textCut $options(name).text;$options(name).text edit modified 1" + $options(name).text.edit add command -label [mc "Copy"] -command "tk_textCopy $options(name).text" + $options(name).text.edit add command -label [mc "Paste"] -command "tk_textPaste $options(name).text;$options(name).text edit modified 1" + $options(name).text.edit add separator + $options(name).text.edit add command -label [mc "Find"] -command "::gridplus::gpTextFind $options(name).text" + } + } else { + set menuName $options(-menu) + } + + if {$options(-command) ne ""} { + bind $options(name).text <> "::gridplus::gpTextSet $options(name) ; eval $options(-command)" + } else { + bind $options(name).text <> "::gridplus::gpTextSet $options(name)" + } + + bind $options(name).text "tk_popup $menuName %X %Y" + bind $options(name).text "[bind all ];break" + bind $options(name).text "[bind all <>]; break" + + set ($options(name)) {} + + if {$options(-autogroup) ne ""} { + set autoGroupCommand "::gridplus::gpAutoGroup $options(name) $options(-autogroup) normal" + trace add variable ($options(name)) write $autoGroupCommand + } + +} + +#=======================================================================# +# PROC : ::gridplus::gpTextSet # +# PURPOSE: Set contents of GRIDPLUS Text. # +#=======================================================================# + +proc ::gridplus::gpTextSet {item} { + global {} + + if {[$item.text edit modified]} { + set ($item) {} + + foreach {key text index} [$item.text dump -text 1.0 end] { + set ($item) "$($item)$text" + } + + $item.text edit modified 0 + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTextInsert # +# PURPOSE: Inserts line into text. # +#=======================================================================# + +proc ::gridplus::gpTextInsert {item position line} { + variable gpInfo + + set textState [$item.text cget -state] + + $item.text configure -state normal + + if {$position eq "end"} { + set insertPosition end + } else { + set insertPosition $position.0 + } + + if {$gpInfo($item:tags)} { + if {$position eq "end"} { + ::gridplus::gpParseTags $item $line $insertPosition + $item.text insert $insertPosition "\n" + } else { + $item.text insert $position.0 "\n" + ::gridplus::gpParseTags $item $line $position.end + } + $item.text tag raise sel + } else { + $item.text insert $insertPosition "$line\n" + $item.text edit modified 0 + set ($item) {} + foreach {key text index} [$item.text dump -text 1.0 end] { + set ($item) "$($item)$text" + } + } + + $item.text configure -state $textState + + if {$gpInfo($item:seeinsert)} { + update idletasks + $item.text see $insertPosition + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTextFind # +# PURPOSE: Find string in GRIDPLUS Text. # +#=======================================================================# + +proc ::gridplus::gpTextFind {item} { + variable gpInfo + + if {[winfo exists .gpTextFind]} { + ::gridplus::gpTextFind:action,cancel + } + + if {[string match *?.text $item]} { + set gpInfo() $item + } else { + set gpInfo() $item.text + } + + gridplus window .gpTextFind -topmost 1 -wcmd ::gridplus::gpTextFind:action,cancel -wtitle Find + + gridplus checkbutton .gpTextFind.match -padding 0 { + {.word "Match whole word only"} + {.case "Match case"} + } + + gridplus radiobutton .gpTextFind.direction -title Direction { + {. Up -backwards} {. Down +forwards} + } + + gridplus button .gpTextFind.action -prefix gridplus:: { + {&e "Find What: " .string 38 + >next ~gpTextFind.action,next} {"Find Next" .next < %next} + {@gpTextFind.match |> @gpTextFind.direction} {"Cancel" .cancel} + } + + pack .gpTextFind.action +} + +#=======================================================================# +# PROC : ::gridplus::gpTextFind:action,next # +# PURPOSE: Find next/previous occurance of string in GRIDPLUS Text. # +#=======================================================================# + +proc ::gridplus::gpTextFind:action,next {} { + global {} + + variable gpInfo + + if {$(.gpTextFind.direction) eq "forwards"} { + set searchIndex "insert+1char" + } else { + set searchIndex "insert" + } + + if {$(.gpTextFind.match,word)} { + set matchWord "-regexp" + set pattern "\[\[:<:\]\]$(.gpTextFind.action,string)\[\[:>:\]\]" + } else { + set matchWord "-exact" + set pattern "$(.gpTextFind.action,string)" + } + + if {$(.gpTextFind.match,case)} { + set position [$gpInfo() search -$(.gpTextFind.direction) $matchWord -- $pattern $searchIndex] + } else { + set position [$gpInfo() search -$(.gpTextFind.direction) $matchWord -nocase -- $pattern $searchIndex] + } + + if {$position ne ""} { + catch "$gpInfo() tag remove sel sel.first sel.last" + $gpInfo() tag add sel $position $position+[string length $(.gpTextFind.action,string)]chars + $gpInfo() configure -inactiveselectbackground [$gpInfo() cget -selectbackground] + $gpInfo() mark set insert $position + $gpInfo() see $position + } +} + +#=======================================================================# +# PROC : ::gridplus::gpTextFind:action,cancel # +# PURPOSE: Cancel/close Find dialog. # +#=======================================================================# + +proc ::gridplus::gpTextFind:action,cancel {} { + global {} + + variable gpInfo + + set gpInfo() {} + + gridplus clear .gpTextFind + destroy .gpTextFind +} + +#=======================================================================# +# PROC : ::gridplus::gpTree # +# PURPOSE: Create tree. # +#=======================================================================# + +proc ::gridplus::gpTree {} { + upvar 1 options options + + global {} + + variable gpInfo + + if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { + set window {} + } + + set gpInfo($options(name):action) $options(-action) + set gpInfo($options(name):fileicon) $options(-fileicon) + set gpInfo($options(name):foldericon) $options(-foldericon) + set gpInfo($options(name):iconlibrary) [file join $options(-iconpath) $options(-iconfile)] + set gpInfo($options(name):icons) $options(-icons) + set gpInfo($options(name):open) $options(-open) + set gpInfo($options(name):selectfirst) $options(-selectfirst) + set gpInfo($options(name):validate) $options(-validate) + set gpInfo($options(name):window) .$window + + ::gridplus::gpLabelframe + + ::ttk::treeview $options(name).tree \ + -cursor left_ptr \ + -height $options(-height) \ + -selectmode $options(-selectmode) \ + -show $options(-show) \ + -xscrollcommand [list $options(name).xbar set] \ + -yscrollcommand [list $options(name).ybar set] + + $options(name).tree column #0 -width $options(-width) + + ::ttk::scrollbar $options(name).xbar -orient horizontal -command [list $options(name).tree xview] + ::ttk::scrollbar $options(name).ybar -orient vertical -command [list $options(name).tree yview] + + grid $options(name).tree -row 0 -column 0 -sticky news + + switch -- $options(-scroll) { + x { + grid $options(name).xbar -row 1 -column 0 -sticky ew + } + y { + grid $options(name).ybar -row 0 -column 1 -sticky ns + } + xy { + grid $options(name).xbar -row 1 -column 0 -sticky ew + grid $options(name).ybar -row 0 -column 1 -sticky ns + } + } + + grid rowconfigure $options(name) 0 -weight 1 + grid columnconfigure $options(name) 0 -weight 1 + + if {$options(-proc)} { + set command "gpProc [::gridplus::gpCommandFormat $options(name)]" + } else { + if {$options(-command) eq ""} { + set command "$options(-prefix)[::gridplus::gpCommandFormat $options(name)]" + } else { + set command $options(-command) + } + } + + set gpInfo($options(name):command) $command + + switch -- $options(-action) { + double { + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window 0]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window 0]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window 0]" + bind $options(name).tree "after 1 [list ::gridplus::gpCommand [list $command] .$window $options(-validate)]" + } + single { + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" + } + single/space { + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" + } + default { + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate)]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate)]" + bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate)]" + } + } + + if {$options(-menu) ne ""} { + bind $options(name).tree "after 1 {::gridplus::gpTreeMenu $options(-menu) %x %y %X %Y %W $options(name)}" + } + + if {[lsearch [image names] ::icon::$options(-fileicon)] < 0} { + ::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $options(-fileicon) + } + if {[lsearch [image names] ::icon::$options(-foldericon)] < 0} { + ::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $options(-foldericon) + } + + set ($options(name)) {} +} + +#=======================================================================# +# PROC : ::gridplus::gpTreeMenu # +# PURPOSE: Right-click pop-up menu for tree. # +#=======================================================================# + +proc ::gridplus::gpTreeMenu {menu x y X Y W name} { + global {} + + $name.tree selection remove $($name) + + set item [lindex [$name.tree identify $x $y] 1] + + $name.tree selection set $item + + set ($name) [$name.tree selection] + + $menu post $X $Y +} + +#=======================================================================# +# PROC : ::gridplus::gpTreeSelect # +# PURPOSE: Sets value for tree selections. # +#=======================================================================# + +proc ::gridplus::gpTreeSelect {name window validate {command {}}} { + global {} + + set ($name) [regsub -all "\034" [$name.tree selection] { }] + + if {$command ne ""} {{*}[list ::gridplus::gpCommand $command $window $validate]} +} + +#=======================================================================# +# PROC : ::gridplus::gpTreeSet # +# PURPOSE: Set contents of GRIDPLUS Tree. # +#=======================================================================# + +proc ::gridplus::gpTreeSet {name nodes} { + variable gpInfo + + $name.tree delete [$name.tree children {}] + + foreach node $nodes { + set icon {} + set nodeText {} + set nodeType file + + foreach item $node { + switch -regexp -- $item { + ^: { + set icon [string range $item 1 end] + } + ^[+]$ { + set nodeType folder + } + ^[/] { + regsub -all { } $item "\034" nodeFullName + } + default { + set nodeText $item + } + } + } + + if {! [regexp {^(.*/)([^/]+)$} $nodeFullName -> path nodeName]} { + set path $nodeFullName + set nodeName $nodeFullName + set indent "" + } + + if {$nodeText ne ""} { + set nodeName $nodeText + } else { + regsub -all "\034" $nodeName { } nodeName + } + + set nodeName [mc $nodeName] + + if {$icon eq ""} { + set icon $gpInfo($name:${nodeType}icon) + } else { + if {[lsearch [image names] ::icon::$icon] < 0} { + ::icons::icons create -file $gpInfo($name:iconlibrary) $icon + } + } + + if {$path eq "/"} { + set parent {} + } else { + regsub -- {/$} $path {} parent + } + + if {$gpInfo($name:icons)} { + $name.tree insert $parent end -id $nodeFullName -image ::icon::$icon -open $gpInfo($name:open) -text $nodeName + } else { + $name.tree insert $parent end -id $nodeFullName -open $gpInfo($name:open) -text $nodeName + } + } + + if {$gpInfo($name:selectfirst)} { + gpselect $name [lindex [$name.tree children {}] 0] + } +} + +#=======================================================================# +# PROC : ::gridplus::gpValidate # +# PURPOSE: Validates contents of entry. # +#=======================================================================# + +proc ::gridplus::gpValidate {item validation condition prevalue fixed auto} { + global {} + + variable gpConfig + variable gpInfo + variable gpValidateError + variable gpValidation + + set focus [focus] + + if {$focus ne ""} { + set focusClass [winfo class $focus] + set focusToplevel [winfo toplevel $focus] + # Set toplevel to modal if unknown (for Tk dialogs?) + if {[info exists gpInfo($focusToplevel:modal)]} { + set focusToplevelModal $gpInfo($focusToplevel:modal) + } else { + set focusToplevelModal 1 + } + } else { + set focusClass "" + set focusToplevel "" + set focusToplevelModal 0 + } + + if {[info exists gpInfo(validation:failed)]} { + set failedItem $gpInfo(validation:failed) + set failedItemToplevel [winfo toplevel $failedItem] + set failedItemToplevelModal $gpInfo($failedItemToplevel:modal) + } else { + set failedItem "" + set failedItemToplevel "" + set failedItemToplevelModal 0 + } + + set itemToplevel [winfo toplevel $item] + set itemToplevelModal $gpInfo($itemToplevel:modal) + + if {[info exists gpInfo($focus:validationmode)]} { + set validationMode $gpInfo($focus:validationmode) + } else { + set validationMode "" + } + + switch -- $condition { + focusout { + if {$focusToplevel ne $itemToplevel && $focusToplevelModal} { + return 1 + } + if {$failedItem ne "" && $failedItem ne $item} { + if {$failedItemToplevel ne $itemToplevel && $itemToplevelModal} { + unset -nocomplain gpInfo(validation:failed) + } + + return 1 + } + } + + focusin { + if {$failedItem ne ""} { + if {$itemToplevelModal && ! $failedItemToplevelModal} { + $failedItem configure -foreground black + + if {[set window $failedItemToplevel] eq "."} { + set window {} + } + + if {[winfo exists $window.errormessage]} { + $window.errormessage configure -text {} + } + + unset -nocomplain gpInfo(validation:failed) + + ::gridplus::gpValidateErrorCancel - - 0 + + return 1 + } + + if {$failedItemToplevel ne $itemToplevel} { + focus $failedItem + return 1 + } + } + } + + key { + if {[string length $prevalue] > $fixed} { + return 0 + } + return 1 + } + } + + if {$validation eq "__gpFixed__" || $condition ne "focusout" || ! $auto} { + return 1 + } + + if {$focusClass in "Button TButton" && $validationMode ne "focus" && $prevalue ne "-"} { + return 1 + } + + if {! [regexp {^([.][^.,]+)} $item -> window]} { + set window {} + } else { + if {[winfo class $window] ne "Toplevel"} { + set window {} + } + } + + set validationOK 0 + + regexp -- {@?([^:?]+)(:([^?]*))*([?](.*))*} $validation -> validationName -> parameter -> errorText + + if {[string match @* $validation] && $($item) eq ""} { + set validationOK 1 + } else { + switch -glob -- $gpValidation($validationName) { + proc:* { + set validateProc [string range $gpValidation($validationName) 5 end] + if {[$validateProc $item $parameter]} { + set validationOK 1 + } + } + trim:* { + set ($item) [string trim $($item)] + if {[regexp [string range $gpValidation($validationName) 5 end] $($item)]} { + set validationOK 1 + } + } + default { + if {[regexp $gpValidation($validationName) $($item)]} { + set validationOK 1 + } + } + } + } + + if $validationOK { + $item configure -foreground black + + if {[winfo exists $window.errormessage]} { + $window.errormessage configure -text {} + } + + unset -nocomplain gpInfo(validation:failed) + + ::gridplus::gpValidateErrorCancel - - 0 + + return 1 + } else { + if {$focus ne ""} { + ::gridplus::gpNotebookIn $item + } + + update idletasks + + set gpInfo(validation:failed) $item + + return 0 + } +} + +#=======================================================================# +# PROC : ::gridplus::gpValidateFailed # +# PURPOSE: Sets focus to failed validation entry. # +#=======================================================================# + +proc ::gridplus::gpValidateFailed {item} { + + variable gpInfo + + if {! [winfo exists $item]} { + return + } + + set focus [focus] + + if {[string compare {} $focus] && [winfo class $focus] eq "Entry"} { + $focus selection clear + + if {[regexp {^(focus(out)?|all)} [set validate [$focus cget -validate]]]} { + $focus configure -validate none + after idle [list $focus configure -validate $validate] + } + } + + if {[info exists gpInfo(validation:failed)]} { + if {[set window [winfo toplevel $item]] eq "."} { + set window {} + } + after 1 "[list focus $item]; ::gridplus::gpValidateErrorDisplay $item" + } +} + +#=======================================================================# +# PROC : ::gridplus::gpValidateErrorDisplay # +# PURPOSE: Display validation error messages. # +#=======================================================================# + +proc ::gridplus::gpValidateErrorDisplay {item} { + variable gpValidateError + + if {! [regexp {^([.][^.,]+)} $item -> window]} { + set window {} + } else { + if {[winfo class $window] ne "Toplevel"} { + set window {} + } + } + + if {[winfo exists $window.errormessage]} { + $window.errormessage configure -text $gpValidateError($item:text) + } + + if {$gpValidateError($item:popup)} { + ::gridplus::gpValidateErrorShow $item + } + + $item configure -foreground red +} + +#=======================================================================# +# PROCS : ::gridplus::gpValidateErrorInit # +# : ::gridplus::gpValidateErrorCancel # +# : ::gridplus::gpValidateErrorShow # +# PURPOSE: Gridplus widget validation "pop-up" error message. # +#=======================================================================# + +proc ::gridplus::gpValidateErrorInit {item message {mode label}} { + variable gpValidateError + + if {! [winfo exists .gpValidateError]} { + toplevel .gpValidateError -background black -borderwidth 1 -relief flat + label .gpValidateError.message -background red -foreground white + pack .gpValidateError.message + wm overrideredirect .gpValidateError 1 + wm withdraw .gpValidateError + } + + if {$mode eq "popup"} { + set gpValidateError($item:popup) 1 + } else { + set gpValidateError($item:popup) 0 + } + + set gpValidateError($item:text) $message +} + +proc ::gridplus::gpValidateErrorCancel {testWindow eventWindow binding} { + variable gpInfo + variable gpValidateError + + if {! $binding && [info exists gpInfo(validation:failed)]} { + return 1 + } + + if {$testWindow eq $eventWindow} { + if {[winfo exists .gpValidateError]} { + wm withdraw .gpValidateError + } + } +} + +proc ::gridplus::gpValidateErrorShow {item} { + variable gpValidateError + + .gpValidateError.message configure -text $gpValidateError($item:text) + + set helpX [expr [winfo rootx $item] + 10] + set helpY [expr [winfo rooty $item] + [expr {[winfo height $item] - 1}]] + + wm geometry .gpValidateError +$helpX+$helpY + wm deiconify .gpValidateError + + raise .gpValidateError +} + +#=======================================================================# +# PROC : ::gridplus::gpValidateText # +# PURPOSE: Returns formatted validation message text. # +#=======================================================================# + +proc ::gridplus::gpValidateText {validation} { + variable gpConfig + variable gpValidation + + regexp -- {@?([^:?]+)(:([^?]*))*([?](.*))*} $validation -> validationName -> parameter -> errorText + + if {$errorText eq ""} { + set errorText [mc $gpValidation($validationName:text)] + set errorMessage [mc $gpConfig(errormessage)] + regsub {%} $errorText $parameter errorText + regsub {%} $errorMessage $errorText errorMessage + return $errorMessage + } else { + return $errorText + } +} + +#=======================================================================# +# PROC : ::gridplus::gpValidateDate # +# PURPOSE: Validates for valid date. # +#=======================================================================# + +proc ::gridplus::gpValidateDate {entry parameter} { + global {} + + foreach {month day year} [::gridplus::gpFormatDate $($entry) internal] {} + + set day [scan $day "%d"] + set month [scan $month "%d"] + set result 0 + + if {$month < 1 || $month > 12} { + return 0 + } else { + if {$day < 1 || $day > [::gridplus::gpCalMonthDays $month $year]} { + return 0 + } else { + set ($entry) [::gridplus::gpFormatDate $($entry) application] + $entry configure -validate focusout + return 1 + } + } +} + +#=======================================================================# +# PROCS : ::gridplus::gpGridIn # +# : ::gridplus::gpPackIn # +# : ::gridplus::gpNotebokIn # +# PURPOSE: If validated entry in notebook select pane containing entry. # +#=======================================================================# + +proc ::gridplus::gpGridIn {name} { + + array set info [grid info $name] + + if {[info exists info(-in)]} { + return $info(-in) + } else { + return {} + } +} + +proc ::gridplus::gpPackIn {name} { + + if {! [catch "pack info $name"]} { + array set info [pack info $name] + return $info(-in) + } else { + return {} + } +} + +proc ::gridplus::gpNotebookIn {name} { + global {} + + variable gpTabOrder + + set in $name + + while {[set in [gpGridIn $in]] ne ""} { + set lastIn $in + } + + set in $lastIn + + while {[set in [gpPackIn $in]] ne ""} { + set lastIn $in + } + + set toplevelLastIn {} + + if {[winfo class $lastIn] eq "Toplevel"} { + foreach item [array names ::gridplus::gpInfo *:in] { + if {$::gridplus::gpInfo($item) eq $lastIn} { + set in [lindex [split $item :] 0] + set toplevelLastIn $in + while {[set in [gpPackIn $in]] ne ""} { + set lastIn $in + } + } + } + } + + if {[regexp -- {(.*)[.]([^.]+$)} $lastIn -> containedIn]} { + + if {$containedIn eq "" && $toplevelLastIn ne ""} { + gpNotebookIn $toplevelLastIn + } elseif {[winfo exists $containedIn] && [winfo class $containedIn] eq "TNotebook"} { + $containedIn select $lastIn + + set pane [$containedIn index current] + set panes [$containedIn tabs] + + regsub -all .[winfo name $containedIn] [lindex $panes $pane] {} item + + set gpTabOrder($containedIn:000000) $item + + gpSetTabOrder $containedIn + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpFormatDate # +# PURPOSE: Converts date format for validation and display. # +#=======================================================================# + +proc ::gridplus::gpFormatDate {date mode} { + variable gpConfig + + if {$gpConfig(dateformat) eq "iso"} { + switch -regexp -- $date { + {^[0-9]{8}$} { + set part(0) [string range $date 0 3] + set part(1) [string range $date 4 5] + set part(2) [string range $date 6 7] + } + {^[0-9]{4}-[0-9]{2}-[0-9]{2}$} { + set part(0) [string range $date 0 3] + set part(1) [string range $date 5 6] + set part(2) [string range $date 8 9] + } + default { + set part(0) 0 + set part(1) 0 + set part(2) 0 + } + } + } else { + switch -regexp -- $date { + {^[0-9]{6}$} { + set part(0) [string range $date 0 1] + set part(1) [string range $date 2 3] + set part(2) [string range $date 4 5] + if {$part(2) <= $gpConfig(date:century)} { + set part(2) "20$part(2)" + } else { + set part(2) "19$part(2)" + } + } + {^[0-9]{8}$} { + set part(0) [string range $date 0 1] + set part(1) [string range $date 2 3] + set part(2) [string range $date 4 7] + } + {^[0-9]{2}.[0-9]{2}.[0-9]{4}$} { + set part(0) [string range $date 0 1] + set part(1) [string range $date 3 4] + set part(2) [string range $date 6 9] + } + default { + set part(0) 0 + set part(1) 0 + set part(2) 0 + } + } + } + + set separator $gpConfig(date:separator) + + if {[string equal $mode internal]} { + return "$part($gpConfig(date:month)) $part($gpConfig(date:day)) $part($gpConfig(date:year))" + } else { + return $part(0)$separator$part(1)$separator$part(2) + } +} + +#=======================================================================# +# PROC : ::gridplus::gpCalCheckDate # +# PURPOSE: Checks for valid date. # +#=======================================================================# + +proc ::gridplus::gpCalCheckDate {month day year} { + + set result 0 + + if {[scan $month %d] < 1 || [scan $month %d] > 12} { + return 0 + } else { + if {[scan $day %d] < 1 || [scan $day %d] > [::gridplus::gpCalMonthDays $month $year]} { + return 0 + } else { + return 1 + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpCalDayNames # +# PURPOSE: Returns day name header information. # +#=======================================================================# + +proc ::gridplus::gpCalDayNames {weekstart} { + variable gpConfig + + set basetime 1220223600 + set daynames {} + + for {set day [expr {$weekstart - 1}]} {$day < [expr {$weekstart + 6}]} {incr day} { + lappend daynames [string range [clock format [clock add $basetime $day day] -format %a -locale $gpConfig(locale)] 0 1] + } + + return $daynames +} + +#=======================================================================# +# PROC : ::gridplus::gpCalMonthDays # +# PURPOSE: Returns number of days for specified month/year. # +#=======================================================================# + +proc ::gridplus::gpCalMonthDays {month year} { + array set days { + 1 31 + 2 28 + 3 31 + 4 30 + 5 31 + 6 30 + 7 31 + 8 31 + 9 30 + 10 31 + 11 30 + 12 31 + } + + if {[clock format [clock add [clock scan 28/02/${year} -format "%d/%m/%Y"] 1 day] -format %d] eq "29"} { + set days(2) 29 + } + + return $days([scan $month "%d"]) +} + + +#=======================================================================# +# PROC : ::gridplus::gpDedent # +# PURPOSE: Returns "dedented" version of "value" string. # +#=======================================================================# + +proc ::gridplus::gpDedent {value} { + + set first 1 + + foreach line [split $value "\n"] { + set spaces {} + + if {[regexp -- {^ +} $line spaces]} { + if {$first} { + set indent [string length $spaces] + set first 0 + } elseif {[string length $spaces] < $indent} { + set indent [string length $spaces] + } + } + } + + regsub -lineanchor -all -- "^ {$indent}" $value {} result + + return $result +} + +#=======================================================================# +# PROC : ::gridplus::gpWindow # +# PURPOSE: Create toplevel window with "modal" option. # +#=======================================================================# + +proc ::gridplus::gpWindow {} { + upvar 1 options options + + variable gpInfo + + set options(-windowcommand) [::gridplus::gpOptionAlias -windowcommand -wcmd] + + if {[winfo exists $options(name)] && $options(-in) eq ""} { + if {! $gpInfo($options(name):toplevel)} { + return 0 + } + + if {$options(-windowcommand) ne ""} { + wm protocol $options(name) WM_DELETE_WINDOW "after 1 {$options(-windowcommand)}" + } + if {$options(-wtitle) ne ""} { + wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] + } + return 0 + } + + regsub -- {%c} $options(-windowcommand) "::gridplus::gridplus clear $options(name)" + regsub -- {%d} $options(-windowcommand) "destroy $options(name)" + + set gpInfo($options(name):modal) 0 + + if {$options(-in) ne ""} { + if {[info exists gpInfo($options(-in):wcmd)]} { + eval $gpInfo($options(-in):wcmd) + } + + if {[winfo exists $options(-in).container]} { + destroy $options(-in).container + } + + frame $options(-in).container -container 1 + + set gpInfo($options(-in):container) [winfo id $options(-in).container] + + grid $options(-in).container -sticky $gpInfo($options(-in):sticky) + grid rowconfigure $options(-in) $options(-in).container -weight 1 + grid columnconfigure $options(-in) $options(-in).container -weight 1 + + toplevel $options(name) -use $gpInfo($options(-in):container) + + set gpInfo($options(name):toplevel) 0 + + if {$gpInfo([winfo toplevel $options(-in)]:modal)} { + set gpInfo($options(name):modal) 1 + } else { + set gpInfo($options(name):modal) 0 + } + + ::gridplus::gpEditMenuCreate $options(name) + + if {$options(-windowcommand) ne ""} { + set gpInfo($options(-in):wcmd) "$options(-windowcommand)" + } else { + set gpInfo($options(-in):wcmd) "::gridplus::gridplus clear $options(name);destroy $options(name)" + } + + set gpInfo($options(-in):in) $options(name) + + return 1 + } else { + set gpInfo($options(name):toplevel) 1 + + if {$options(-modal)} { + set gpInfo($options(name):modal) 1 + } + + toplevel $options(name) + wm overrideredirect $options(name) $options(-overrideredirect) + + bind $options(name) "::gridplus::gpWindowBindings $options(name) %W 1" + bind $options(name) "::gridplus::gpWindowBindings $options(name) %W 1" + bind $options(name) "::gridplus::gpWindowBindings $options(name) %W 1" + } + + wm attributes $options(name) -topmost $options(-topmost) + + bind $options(name) "::gridplus::gpWidgetHelpCancel;::gridplus::gpValidateErrorCancel $options(name) %W 1" + + ::gridplus::gpEditMenuCreate $options(name) + + wm resizable $options(name) 0 0 + + if {$options(-windowcommand) ne ""} { + wm protocol $options(name) WM_DELETE_WINDOW "after 1 {$options(-windowcommand)}" + } else { + wm protocol $options(name) WM_DELETE_WINDOW "after 1 {::gridplus::gridplus clear $options(name);destroy $options(name)}" + } + + if {$options(-wtitle) ne ""} { + wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] + } + + if {$options(-modal)} { + bind modalWindow {wm deiconify %W;raise %W} + bindtags $options(name) [linsert [bindtags $options(name)] 0 modalWindow] + wm deiconify $options(name) + tkwait visibility $options(name) + grab set $options(name) + } + + return 1 +} + +#=======================================================================# +# PROC : ::gridplus::gpWindowBindings # +# PURPOSE: Process window bindings. # +#=======================================================================# + +proc ::gridplus::gpWindowBindings {testWindow eventWindow binding} { + + ::gridplus::gpWidgetHelpCancel + ::gridplus::gpValidateErrorCancel $testWindow $eventWindow $binding + ::gridplus::gpDateSelectorUnpost $testWindow +} + +#=======================================================================# +# PROC : ::gridplus::gpclear # +# PURPOSE: Clear selected text for item. # +#=======================================================================# + +proc ::gridplus::gpclear {{item {}}} { + + if {$item eq ""} { + set item [focus] + } + + if {[string match *.text $item] && [winfo class $item] eq "Text"} { + set textItem $item + } else { + set textItem $item.text + } + + if {[winfo exists $textItem]} { + event generate $textItem <> + $textItem edit modified 1 + } else { + event generate $item <> + } +} + +#=======================================================================# +# PROC : ::gridplus::gpcopy # +# PURPOSE: Perform clipboard copy for item. # +#=======================================================================# + +proc ::gridplus::gpcopy {{item {}}} { + + if {$item eq ""} { + set item [focus] + } + + if {[string match *.text $item] && [winfo class $item] eq "Text"} { + set textItem $item + } else { + set textItem $item.text + } + + if {[winfo exists $textItem]} { + tk_textCopy $textItem + } else { + clipboard clear + catch {clipboard append [selection get]} + } +} + +#=======================================================================# +# PROC : ::gridplus::gpcut # +# PURPOSE: Perform clipboard cut for item. # +#=======================================================================# + +proc ::gridplus::gpcut {{item {}}} { + + if {$item eq ""} { + set item [focus] + } + + if {[string match *.text $item] && [winfo class $item] eq "Text"} { + set textItem $item + } else { + set textItem $item.text + } + + if {[winfo exists $textItem]} { + tk_textCut $textItem + $textItem edit modified 1 + } else { + clipboard clear + catch {clipboard append [selection get]} + catch {$item delete sel.first sel.last} + } +} + +#=======================================================================# +# PROC : ::gridplus::gpdate # +# PURPOSE: Returns (calculated) date in "-dateformat". # +#=======================================================================# + +proc ::gridplus::gpdate {{action {@}} {date {}}} { + variable gpConfig + + # Run initialisation if neccessary. + if {! [info exists gpConfig]} { + gpInit + } + + set unitCode [string index $action 0] + set increment [string range $action 1 end] + + switch -- $gpConfig(dateformat) { + eu {set dateFormat "%d.%m.%Y"} + iso {set dateFormat "%Y-%m-%d"} + uk {set dateFormat "%d/%m/%Y"} + us {set dateFormat "%m/%d/%Y"} + } + + if {$date eq ""} { + set clockSeconds [clock seconds] + } else { + set clockSeconds [clock scan $date -format $dateFormat] + } + + switch -- $unitCode { + @ {return [clock format $clockSeconds -format $dateFormat]} + + {set unit "day"} + - {set unit "day";set increment "-$increment"} + > {set unit "month"} + < {set unit "month";set increment "-$increment"} + default {return $action} + } + + return [clock format [clock add $clockSeconds $increment $unit] -format $dateFormat] +} + +#=======================================================================# +# PROC : ::gridplus::gpdb # +# PURPOSE: TDBC interface. # +#=======================================================================# + +proc ::gridplus::gpdb {args} { + + foreach {option arg database window sql FOREACH code data} [lrepeat 8 {}] {} + + switch [llength $args] { + 3 { + foreach {database window sql} $args {} + } + 4 { + foreach {database window sql data} $args {} + } + 5 { + foreach {database window sql FOREACH code} $args {} + } + 6 { + foreach {database window sql FOREACH code data} $args {} + } + default { + error "GRIDPLUS ERROR: (gpdb) Invalid number of args." + } + } + + ::gridplus::gpdbRunSQL $database $window $sql "$code" $data +} + +#=======================================================================# +# PROC : ::gridplus::gpdbRunSQL # +# PURPOSE: Run SQL and set approprite result. # +#=======================================================================# + +proc ::gridplus::gpdbRunSQL {database window sql code data} { + global {} + + variable gpInfo + + set columnID 1 + set columnMap [dict create] + set dataType "map" + set format "dicts" + set prefix @ + set result {} + set rowCount 1 + set varCount 1 + + if {$code ne ""} { + set dataType "foreach" + set format "dicts" + if {[string match *@* $data]} { + set prefix $data + } + } elseif {$data ne ""} { + if {[string match .* $data]} { + set dataType "tablelist" + set format "lists" + } elseif {[string match *@* $data]} { + set dataType "gridplus" + set prefix $data + } elseif {$data eq "="} { + set dataType "list" + set format "lists" + } else { + set dataType "dict" + upvar #0 $data variable + } + } + + while {[regexp -- {@[(]([^( )@]+)[)]} $sql sqlItem itemID]} { + set columnName "gpdb____$columnID" + dict set columnMap $columnName $itemID + set sql [string map "$sqlItem {as $columnName}" $sql] + incr columnID + } + + while {[regexp -- {((%?):[(]([^( ):]+)(:([a-zA-Z0-9]+))?[)](%?))} $sql -> sqlItem wildcard1 itemID -> index wildcard2]} { + switch -glob -- $itemID { + ,* { + if {$window eq "."} { + set pattern "^\[.\]\[^,.\]+$itemID$" + } else { + set pattern "^\[.\][string range $window 1 end]\[.\]\[^,.\]+$itemID$" + } + set item [array names {} -regexp $pattern] + if {[llength $item] > 1} { + error "GRIDPLUS ERROR: (gpdb) Ambiguous item ($sqlItem)." + } + } + [.]* { + set item $itemID + } + *[@]* { + set item $itemID + } + default { + if {[string match *, $window]} { + set item $window$itemID + } else { + if {$window eq "."} { + set item .$itemID + } else { + set item $window.$itemID + } + } + } + } + + if {! [info exists ($item)]} { + error "GRIDPLUS ERROR: (gpdb) Item \"$item\" does not exist." + } + + if {$index eq ""} { + set gpdbSQLvar$varCount "$wildcard1$($item)$wildcard2" + } else { + set gpdbSQLvar$varCount "$wildcard1[lindex $($item) [::gridplus::gpTablelistColumnIndex $item $index gpdb]]$wildcard2" + } + + set sql [string map "$sqlItem :gpdbSQLvar$varCount" $sql] + + incr varCount + } + + set statement [$database prepare $sql] + + if {[catch { + $statement foreach -as $format -columnsvariable columns row { + switch -- $dataType { + foreach { + dict for {column value} $row { + gpset "$prefix$column" $value + } + eval "global {};$code" + } + tablelist { + lappend result $row + } + list { + lappend result $row + } + default { + if {$rowCount > 1} { + error "GRIDPLUS ERROR: (gpdb) More than 1 row returned for non-list result." + } else { + set result $row + } + } + } + incr rowCount + } + } sqlErrorText]} { + if {[=< sqlErrorProc] eq ""} { + error "GRIDPLUS ERROR: (gpdb) SQL error ($sqlErrorText)." + } else { + [=< sqlErrorProc] "$sqlErrorText" + } + } + + $statement close + + switch -- $dataType { + dict { + set variable [dict create {*}$result] + } + gridplus { + dict for {column value} $result { + gpset "$prefix$column" $value + } + } + map { + ::gridplus::gpdbMap $window $result $columnMap + } + tablelist { + gpset $data $result + } + list { + return $result + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpdbMap # +# PURPOSE: Map result from SQL to GRIDPLUS "variable(s)". # +#=======================================================================# + +proc ::gridplus::gpdbMap {window result columnMap} { + global {} + + dict for {column value} $result { + set mapWindow {} + set mapGrid {} + set mapItem {} + + if {[string match "gpdb____*" $column]} { + set item [dict get $columnMap $column] + } else { + regsub -all -- {[.:]} $column "_" column + set pattern $column + if {[string match *, $window]} { + set item $window$column + } else { + if {$window eq "."} { + set pattern "^\[.\]\[^,.\]+,$pattern$" + } else { + set pattern "^\[.\][string range $window 1 end]\[.\]\[^,.\]+,$pattern$" + } + set item [array names {} -regexp $pattern] + if {[llength $item] > 1} { + error "GRIDPLUS ERROR: (gpdb) Ambiguous item ($column)." + } + } + } + + if {[info exists ($item)]} { + gpset $item $value + } else { + gpset "@$column" $value + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpdefault # +# PURPOSE: Set default values for GRIDPLUS "variable(s)". # +#=======================================================================# + +proc ::gridplus::gpdefault {args} { + + variable gpInfo + + switch -- [llength $args] { + 1 { + if {[expr [llength [lindex $args 0]] % 2] != 0} { + error "GRIDPLUS ERROR: (gpdefault) Unmatched item/value." + } + foreach {item value} [lindex $args 0] { + set gpInfo(default:$item) $value + } + } + 2 { + set item [lindex $args 0] + set value [lindex $args 1] + set gpInfo(default:$item) $value + } + default { + error "GRIDPLUS ERROR: (gpdefault) Wrong number of Args." + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpdelete # +# PURPOSE: Deletes specified row/line/item from a tablelist/text/tree. # +#=======================================================================# + +proc ::gridplus::gpdelete {args} { + global {} + + variable gpInfo + + set focus 0 + set index 0 + set select 0 + + set column 0 + set match {} + + set count 1 + set current 0 + set option 1 + + set autoSelect [=< autoSelect 1] + + foreach arg $args { + switch -glob -- $arg { + | {set option 0} + -first {if {$option} {set index 1; set match 0}} + -focus {if {$option} {set select 1; set focus 1}} + -index {if {$option} {set index 1}} + -last {if {$option} {set index 1; set match "end"}} + -row {if {$option} {set index 1}} + -select {if {$option} {set select 1}} + -- {set option 0} + default { + if {$option && [string match -* $arg]} { + error "GRIDPLUS ERROR: (gpdelete) Invalid option ($arg)." + } + switch -- $count { + 1 {set name $arg; incr count} + 2 {set arg2 $arg; incr count} + 3 {set arg3 $arg; incr count} + } + } + } + } + + switch -- $count { + 2 {if {! $index} { + set current 1 + set index 1 + } + } + 3 {set match $arg2 + } + 4 {set column $arg2 + set match $arg3 + } + default { + error "GRIDPLUS ERROR: (gpdelete) Invalid number of Args." + } + } + + if {[winfo exists $name.tablelist]} { + if {$current && [$name.tablelist cget -selectmode] ni "browse single"} { + error "GRIDPLUS ERROR: (gpdelete) Current row delete only allowed when tablelist selectmode is \"browse\" or \"single\"." + } + + set currentSelection [$name.tablelist curselection] + + if {$currentSelection ne ""} { + if {$autoSelect} { + set select 1 + } + } + + if {$current} { + if {$currentSelection ne ""} { + set match $currentSelection + } else { + error "GRIDPLUS ERROR: (gpdelete) Tablelist does not have a selected row." + } + } + + $name.tablelist selection clear 0 end + set ($name) {} + + if {$index} { + set row $match + if {$row ne "end" && $row >= [$name.tablelist size]} { + set row "end" + } + } else { + set columnIndex [::gridplus::gpTablelistColumnIndex $name $column gpdelete] + set row [lsearch -exact [$name.tablelist getcolumn $columnIndex] $match] + if {$row == -1} { + error "GRIDPLUS ERROR: (gpdelete) Tablelist row with match \"$match\" not found." + } + } + + $name.tablelist delete $row + + if {$select} { + if {$focus} { + gpselect $name -focus -row $row + } else { + gpselect $name -row $row + } + } + } elseif {[winfo exists $name.text]} { + if {$match eq ""} { + error "GRIDPLUS ERROR: (gpdelete) Text line not specified." + } + + if {$match eq "first"} { + set match 1 + } + + if {$match in "end last"} { + $name.text delete "end - 1 line" "end" + } else { + $name.text delete $match.0 $match.end + $name.text delete $match.end + } + } elseif {[winfo exists $name.tree]} { + if {$current && [$name.tree cget -selectmode] ne "browse"} { + error "GRIDPLUS ERROR: (gpdelete) Current node delete only allowed when tree selectmode is \"browse\"." + } + + set currentSelection [$name.tree selection] + + if {$currentSelection ne ""} { + if {$autoSelect} { + set select 1 + } + } + + if {$current} { + if {$currentSelection ne ""} { + set match $currentSelection + } else { + error "GRIDPLUS ERROR: (gpdelete) Tree does not have a selected node." + } + } + + if {$select} { + set selectNode [$name.tree identify item 1 [expr {[lindex [$name.tree bbox $($name)] 1] + [lindex [$name.tree bbox $($name)] 3] + 1}]] + if {$selectNode eq ""} { + set selectNode [$name.tree identify item 1 [expr {[lindex [$name.tree bbox $($name)] 1] - 1}]] + } + } + + $name.tree selection remove $($name) + set ($name) {} + $name.tree delete $match + + if {$select && $selectNode ne ""} { + if {$focus} { + gpselect $name -focus $selectNode + } else { + gpselect $name $selectNode + } + } + } else { + error "GRIDPLUS ERROR: (gpdelete) Widget \"$name\" is not tablelist, text or tree." + } +} + +#=======================================================================# +# PROC : ::gridplus::gpfind # +# PURPOSE: Find next/previous occurance of string in GRIDPLUS Text. # +#=======================================================================# + +proc ::gridplus::gpfind {item pattern {direction forwards}} { + global {} + + if {$direction eq "forwards"} { + set searchIndex "insert+1char" + } else { + set searchIndex "insert" + } + + set position [$item.text search -$direction -exact -nocase -- $pattern $searchIndex] + + if {$position ne ""} { + catch "$item.text tag remove sel sel.first sel.last" + $item.text tag add sel $position $position+[string length $pattern]chars + $item.text configure -inactiveselectbackground [$item.text cget -selectbackground] + $item.text mark set insert $position + $item.text see $position + } +} + +#=======================================================================# +# PROC : ::gridplus::gpfind_dialog # +# PURPOSE: Display find dialog for specified GRIDPLUS text item. # +#=======================================================================# + +proc ::gridplus::gpfind_dialog {item} { + + ::gridplus::gpTextFind $item +} + +#=======================================================================# +# PROC : ::gridplus::gpget # +# PURPOSE: Returns tablelist column data for "columns". # +#=======================================================================# + +proc ::gridplus::gpget {item columns} { + global {} + + set result {} + + if {[string match ?*>*? $columns]} { + foreach {first last} [split $columns >] {} + set firstIndex [::gridplus::gpTablelistColumnIndex $item $first "gpget"] + set lastIndex [::gridplus::gpTablelistColumnIndex $item $last "gpget"] + set columns {} + for {set index $firstIndex} {$index <= $lastIndex} {incr index} { + lappend columns $index + } + set columns [string map {{ } ,} $columns] + } + + foreach column [split $columns ,+] { + if {$column ne ""} { + lappend result [lindex $($item) [::gridplus::gpTablelistColumnIndex $item $column "gpget"]] + } + } + + if {([string match *+* $columns] || [llength $result] == 1) && ! [string match *,* $columns]} { + set result [concat {*}$result] + } + + return $result +} + +#=======================================================================# +# PROC : ::gridplus::gpinsert # +# PURPOSE: Inserts line into tablelist/text. # +#=======================================================================# + +proc ::gridplus::gpinsert {name position line} { + global {} + + variable gpInfo + + if {[winfo exists $name.tablelist]} { + ::gridplus::gpTablelistInsert $name $position $line + } elseif {[winfo exists $name.text]} { + ::gridplus::gpTextInsert $name $position $line + } else { + error "GRIDPLUS ERROR: (gpinsert) Widget \"$name\" is not tablelist or text." + } +} + +#=======================================================================# +# PROC : ::gridplus::gpmap # +# PURPOSE: Map GRIDPLUS "variable(s)" to a list of values, array or dict# +#=======================================================================# + +proc ::gridplus::gpmap {map values {arg __direct}} { + + if {$arg ni "__direct __left __right"} { + upvar #0 $arg variable + + set position 0 + + if {[array exists variable]} { + foreach item $map { + if {[winfo exists $item] && [winfo class $item] eq "TCombobox"} { + gpset [list $item $variable([lindex $values $position])] + } else { + gpset $item $variable([lindex $values $position]) + } + incr position + } + } elseif {! [catch {dict size $variable}]} { + foreach item $map { + if {[winfo exists $item] && [winfo class $item] eq "TCombobox"} { + gpset [list $item [dict get $variable [lindex $values $position]]] + } else { + gpset $item [dict get $variable [lindex $values $position]] + } + incr position + } + } else { + error "GRIDPLUS ERROR: (gpmap) Array/Dict \"$arg\" does not exist." + } + } else { + switch -- $arg { + __direct {set start 0; set increment 1} + __left {set start 0; set increment 2} + __right {set start 1; set increment 2} + default {set start 0; set increment 1} + } + + set position $start + + foreach item $map { + if {[winfo exists $item] && [winfo class $item] eq "TCombobox"} { + gpset [list $item [lindex $values $position]] + } else { + gpset $item [lindex $values $position] + } + incr position $increment + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpnav # +# PURPOSE: Navigate to text label or calendar month. # +#=======================================================================# + +proc ::gridplus::gpnav {name target {increment {}}} { + + global {} + + if {[winfo exists $name.text]} { + $name.text yview $target + set ($name) $target + } elseif {[winfo exists $name.calendar]} { + if {$target in "current month year"} { + ::gridplus::gpCalendarNav $name $target $increment + } else { + if {[llength $target] == 1} { + foreach {month day year} [::gridplus::gpFormatDate $target internal] {} + if {! [::gridplus::gpCalCheckDate $month $day $year]} { + error "GRIDPLUS ERROR: (gpnav) \"$target\" is not a valid date." + } + } elseif {[llength $target] == 2} { + set day {} + set month [lindex $target 0] + set year [lindex $target 1] + if {[scan $month %d] < 1 || [scan $month %d] > 12} { + error "GRIDPLUS ERROR: (gpnav) \"$month\" is not a valid month." + } + if {! [string is integer $year]} { + error "GRIDPLUS ERROR: (gpnav) \"$year\" is not a valid year." + } + } + ::gridplus::gpCalendarDisplay $name $day $month $year + if {$increment ne ""} { + ::gridplus::gpCalendarNav $name month $increment + } + } + } else { + error "GRIDPLUS ERROR: (gpnav) Widget \"$name\" is not text or calendar." + } +} + +#=======================================================================# +# PROC : ::gridplus::gpoptions # +# PURPOSE: Set GRIDPLUS option database options. # +#=======================================================================# + +proc ::gridplus::gpoptions {args} { + + variable gpInfo + + switch -- [llength $args] { + 1 { + if {[expr [llength [lindex $args 0]] % 2] != 0} { + error "GRIDPLUS ERROR: (gpoption) Unmatched option/value." + } + foreach {option value} [lindex $args 0] { + option add *Gridplus.$option $value + } + } + 2 { + foreach {option value} $args {} + option add *Gridplus.$option $value + } + default { + error "GRIDPLUS ERROR: (gpoption) Wrong number of Args." + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gppaste # +# PURPOSE: Perform clipboard paste for item. # +#=======================================================================# + +proc ::gridplus::gppaste {{item {}}} { + + if {$item eq ""} { + set item [focus] + } + + if {[string match *.text $item] && [winfo class $item] eq "Text"} { + set textItem $item + } else { + set textItem $item.text + } + + if {[winfo exists $textItem]} { + tk_textPaste $textItem + $textItem edit modified 1 + } else { + if {! [catch {$item selection clear}]} { + $item insert insert [clipboard get] + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpselect # +# PURPOSE: Selects specified item in a tablelist/tree/calendar. # +#=======================================================================# + +proc ::gridplus::gpselect {args} { + global {} + + variable gpInfo + + set column 0 + set focus {} + set index 0 + set nocase {} + set restore 0 + set save 0 + set selectonly 0 + + set columnMatch 0 + set match {} + set sortOrder {} + + set count 1 + set option 1 + + foreach arg $args { + switch -glob -- $arg { + | {set columnMatch 1; set option 0} + -first {if {$option} {set index 1; set match 0}} + -focus {if {$option} {set focus "-focus"}} + -index {if {$option} {set index 1}} + -last {if {$option} {set index 1; set match "end"}} + -max {if {$option} {set sortOrder "decreasing"}} + -min {if {$option} {set sortOrder "increasing"}} + -restore {if {$option} {set restore 1}} + -row {if {$option} {set index 1}} + -save {if {$option} {set save 1}} + -selectonly {if {$option} {set selectonly 1}} + -- {set option 0} + default { + if {$option && [string match -* $arg]} { + error "GRIDPLUS ERROR: (gpselect) Invalid option ($arg)." + } + switch -- $count { + 1 {set name $arg; incr count} + 2 {set arg2 $arg; incr count} + 3 {set arg3 $arg; incr count} + } + } + } + } + + switch -- $count { + 3 {set match $arg2} + 4 {if {$columnMatch} { + set column $arg2 + set match $arg3 + } else { + set match $arg2 + set column $arg3} + } + } + + if {[winfo exists $name.tablelist]} { + if {$save} { + if {[$name.tablelist cget -selectmode] ni "browse single"} { + error "GRIDPLUS ERROR: (gpselect) Current selection save only allowed when tablelist selectmode is \"browse\" or \"single\"." + } + if {$match eq ""} { + set gpInfo($name:savedSelection) [$name.tablelist curselection] + } else { + set columnIndex [::gridplus::gpTablelistColumnIndex $name $match gpselect] + set gpInfo($name:savedSelection) [list [lindex [$name.tablelist get [$name.tablelist curselection]] $columnIndex] $columnIndex] + } + return + } + + if {$restore} { + if {[info exists gpInfo($name:savedSelection)]} { + if {[llength $gpInfo($name:savedSelection)] == 1} { + gpselect {*}$focus -index $name $gpInfo($name:savedSelection) + } else { + gpselect {*}$focus $name [lindex $gpInfo($name:savedSelection) 0] [lindex $gpInfo($name:savedSelection) 1] + } + } else { + error "GRIDPLUS ERROR: (gpselect) No selection saved for \"$name\"." + } + return + } + + if {$sortOrder ne ""} { + set columnIndex [::gridplus::gpTablelistColumnIndex $name $match gpselect] + set sortMode [$name.tablelist columncget $columnIndex -sortmode] + if {$sortMode eq "asciinocase"} { + set sortMode "ascii" + set nocase "-nocase" + } + set selectMatch [lindex [lsort {*}$nocase -$sortMode -$sortOrder -index $columnIndex [set [$name.tablelist itemlistvar]]] "0 $columnIndex"] + gpselect {*}$focus $name -- $selectMatch $columnIndex + return + } + + $name.tablelist selection clear 0 end + + if {$index} { + set row $match + if {$row ne "end" && $row >= [$name.tablelist size]} { + set row "end" + } + } else { + set columnIndex [::gridplus::gpTablelistColumnIndex $name $column gpselect] + set row [lsearch -exact [$name.tablelist getcolumn $columnIndex] $match] + if {$row == -1} { + error "GRIDPLUS ERROR: (gpselect) Tablelist line with match \"$match\" not found." + } + } + + $name.tablelist selection set $row + $name.tablelist activate $row + $name.tablelist see $row + + if {$gpInfo($name:action) eq "single"} { + ::gridplus::gpTablelistSelect $name $row $gpInfo($name:window) $gpInfo($name:validate) $gpInfo($name:command) + } else { + ::gridplus::gpTablelistSelect $name $row $gpInfo($name:window) $gpInfo($name:validate) {} + } + + if {$focus eq "-focus"} { + after idle focus [$name.tablelist bodypath] + $name.tablelist see $row + } + } elseif {[winfo exists $name.tree]} { + if {! [catch {$name.tree selection set $match}]} { + if {$gpInfo($name:action) eq "single"} { + ::gridplus::gpTreeSelect $name $gpInfo($name:window) $gpInfo($name:validate) $gpInfo($name:command) + } else { + ::gridplus::gpTreeSelect $name $gpInfo($name:window) $gpInfo($name:validate) {} + } + + if {$focus eq "-focus"} { + after idle focus $name.tree + $name.tree see $match + } + } else { + error "GRIDPLUS ERROR: (gpselect) Tree node \"$match\" not found." + } + } elseif {[winfo exists $name.calendar]} { + if {$match ne ""} { + foreach {month day year} [::gridplus::gpFormatDate $match internal] {} + if {! [::gridplus::gpCalCheckDate $month $day $year]} { + error "GRIDPLUS ERROR: (gpselect) \"$match\" is not a valid date." + } + set gpInfo($name:selecttoday) 1 + ::gridplus::gpCalendarDisplay $name $day $month $year + } else { + if {$gpInfo($name:variable) ne ""} { + set variable $gpInfo($name:variable) + } else { + set variable $name + } + + if {! $selectonly} { + set ($variable) {} + } + + if {[info exists gpInfo($name:selected)] && $gpInfo($name:selected) ne ""} { + $gpInfo($name:selected) configure -bg $gpInfo($name:bg) -fg $gpInfo($name:fg) + unset gpInfo($name:selected) + unset gpInfo($name:selectedday) + unset gpInfo($name:selectedmonth) + unset gpInfo($name:selectedyear) + } + } + } else { + error "GRIDPLUS ERROR: (gpselect) Widget \"$name\" is not calendar, tablelist or tree." + } +} + +#=======================================================================# +# PROC : ::gridplus::gpset # +# PURPOSE: Set GRIDPLUS "variable(s)". # +#=======================================================================# + +proc ::gridplus::gpset {args} { + global {} + + variable gpInfo + + update idletasks + + switch -- [llength $args] { + 1 { + if {[expr [llength [lindex $args 0]] % 2] != 0} { + error "GRIDPLUS ERROR: (gpset) Unmatched item/value." + } + foreach {item value} [lindex $args 0] { + if {[winfo exists $item.text]} { + $item.text delete 1.0 end + $item.text insert end $value + set ($item) $value + } elseif {[winfo exists $item.calendar]} { + ::gridplus::gpset -calendar $item $value + } else { + set ($item) $value + } + } + } + 2 { + set item [lindex $args 0] + set value [lindex $args 1] + if {[winfo exists $item.tablelist]} { + unset -nocomplain ($item) + $item.tablelist delete 0 end + foreach line $value { + ::gridplus::gpTablelistInsert $item end $line 1 + } + if {$gpInfo($item:columnsort)} { + if {$gpInfo($item:maintainsort) && [info exists gpInfo($item:lastsortcolumn)]} { + $item.tablelist sortbycolumn $gpInfo($item:lastsortcolumn) -$gpInfo($item:lastsortorder) + } else { + $item.tablelist sortbycolumn $gpInfo($item:firstcolumn) -$gpInfo($item:sortorder) + } + } + if {$gpInfo($item:selectfirst) && ! [info exists gpInfo($item:savedSelection)]} { + $item.tablelist selection set 0 + $item.tablelist activate 0 + set ($item) [$item.tablelist get 0] + } + } elseif {[winfo exists $item.text]} { + set textState [$item.text cget -state] + $item.text configure -state normal + if {$gpInfo($item:tags)} { + $item.text delete 1.0 end + ::gridplus::gpParseTags $item $value end + $item.text tag raise sel + } else { + $item.text delete 1.0 end + $item.text insert end $value + $item.text edit modified 0 + set ($item) $value + } + $item.text configure -state $textState + } elseif {[winfo exists $item.tree]} { + ::gridplus::gpTreeSet $item $value + } elseif {[winfo exists $item.calendar]} { + ::gridplus::gpselect $item $value + } elseif {[winfo exists $item] && [winfo class $item] eq "TCombobox" && ! [info exists gpInfo($item:datecommand)]} { + $item configure -value $value + } else { + set ($item) $value + } + } + 3 { + set option [lindex $args 0] + set item [lindex $args 1] + set value [lindex $args 2] + switch -- $option { + -| {::gridplus::gpset $item [::gridplus::gpDedent $value]} + -names {::gridplus::gpTablelistSetColumns $item -name $value} + -titles {::gridplus::gpTablelistSetColumns $item -title $value} + default {::gridplus::gpselect $item $value $option} + } + } + default { + error "GRIDPLUS ERROR: (gpset) Wrong number of Args." + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpunset # +# PURPOSE: Unset GRIDPLUS "variable(s)". # +#=======================================================================# + +proc ::gridplus::gpunset {args} { + global {} + + foreach pattern $args { + foreach item [array names {} $pattern] { + if {[info exists ($item)]} { + unset ($item) + } + if {[winfo exists $item.tablelist]} { + $item.tablelist delete 0 end + } elseif {[winfo exists $item.text]} { + $item.text delete 1.0 end + } elseif {[winfo exists $item.tree]} { + $item.tree configure -state normal + $item.tree delete 1.0 end + $item.tree configure -state disabled + } + } + } +} + +#=======================================================================# +# PROC : ::gridplus::gpupdate # +# PURPOSE: Updates specified row in a tablelist. # +#=======================================================================# + +proc ::gridplus::gpupdate {args} { + global {} + + variable gpInfo + + set focus 0 + set index 0 + set select 0 + + set column 0 + set current 0 + set match {} + set target {} + set value {} + + set count 1 + set option 1 + + foreach arg $args { + switch -glob -- $arg { + | {set option 0} + -focus {if {$option} {set focus 1}} + -index {if {$option} {set index 1}} + -row {if {$option} {set index 1}} + -select {if {$option} {set select 1}} + -- {set option 0} + default { + if {$option && [string match -* $arg]} { + error "GRIDPLUS ERROR: (gpupdate) Invalid option ($arg)." + } + switch -- $count { + 1 {set name $arg; incr count} + 2 {set arg2 $arg; incr count} + 3 {set arg3 $arg; incr count} + 4 {set arg4 $arg; incr count} + 5 {set arg5 $arg; incr count} + } + } + } + } + + set currentSelection [$name.tablelist curselection] + + switch -- $count { + 3 {set index 1 + set current 1 + set match $currentSelection + set value $arg2 + # gpupdate .mytable {row data} + } + 4 {if {$index} { + set match $arg2 + set value $arg3 + # gpupdate .mytable -row 99 {row data} + } else { + set index 1 + set current 1 + set match $currentSelection + set target $arg2 + set value $arg3 + # gpupdate .mytable | mytarget "value" + } + } + 5 {if {$index} { + set match $arg2 + set target $arg3 + set value $arg4 + # gpupdate .mytable -row 99 | mytarget "value" + } else { + set column $arg2 + set match $arg3 + set value $arg4 + # gpupdate .mytable | mycolumn "my match" | {row data} + } + } + 6 {set column $arg2 + set match $arg3 + set target $arg4 + set value $arg5 + # gpupdate .mytable | mycolumn "my match" | mytarget "value" + } + default { + error "GRIDPLUS ERROR: (gpupdate) Invalid number of Args." + } + } + + if {[winfo exists $name.tablelist]} { + if {$current && [$name.tablelist cget -selectmode] ni "browse single"} { + error "GRIDPLUS ERROR: (gpupdate) Current record update only allowed when tablelist selectmode is \"browse\" or \"single\"." + } + $name.tablelist selection clear 0 end + if {$index} { + set row $match + if {$row ne "end" && $row >= [$name.tablelist size]} { + set row "end" + } + } else { + set columnIndex [::gridplus::gpTablelistColumnIndex $name $column gpupdate] + set row [lsearch -exact [$name.tablelist getcolumn $columnIndex] $match] + if {$row == -1} { + error "GRIDPLUS ERROR: (gpupdate) Tablelist row with match \"$match\" not found." + } + } + + if {$target ne ""} { + set targetIndex [::gridplus::gpTablelistColumnIndex $name $target gpupdate] + set value [lreplace [$name.tablelist get $row] $targetIndex $targetIndex $value] + } + + ::gridplus::gpTablelistInsert $name $row $value 0 1 + + if {$select} { + gpselect $name -row $row + } elseif {$currentSelection ne ""} { + gpselect $name -row $currentSelection + } + if {$focus} { + after idle focus [$name.tablelist bodypath] + $name.tablelist see $row + } + } else { + error "GRIDPLUS ERROR: (gpupdate) Widget \"$name\" is not tablelist." + } +} + +#=======================================================================# +# PROC : ::gridplus::= # +# PURPOSE: Return specified (widget) option. # +#=======================================================================# + +proc ::gridplus::= {value key {default {}}} { + + if {[dict exists $value $key]} { + return [dict get $value $key] + } else { + return $default + } +} + +#=======================================================================# +# PROC : ::gridplus::=% # +# PURPOSE: Return state for widget group. # +#=======================================================================# + +proc ::gridplus::=% {name state {flag {}}} { + + variable gpInfo + + if {[info exists gpInfo($name:group)] && [info exists gpInfo($gpInfo($name:group))]} { + + set state $gpInfo($gpInfo($name:group)) + + if {$flag eq "!" && $state eq "disabled"} { + return "readonly" + } else { + return $state + } + } + + return $state +} + +#=======================================================================# +# PROC : ::gridplus::=: # +# PURPOSE: Create icon and return image name. # +#=======================================================================# + +proc ::gridplus::=: {icon} { + upvar 1 options options + + if {[lsearch [image names] ::icon::$icon] < 0} { + return "::icon::[::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $icon]" + } else { + return "::icon::$icon" + } +} + +#=======================================================================# +# PROC : ::gridplus::=? # +# PURPOSE: Check if widget option has been set. # +#=======================================================================# + +proc ::gridplus::=? {value key} { + return [dict exists $value $key] +} + +#=======================================================================# +# PROC : ::gridplus::=@ # +# PURPOSE: Return default for widget. # +#=======================================================================# + +proc ::gridplus::=@ {name {default {}}} { + + variable gpInfo + + if {[info exists gpInfo(default:$name)]} { + return $gpInfo(default:$name) + } else { + return $default + } +} + +#=======================================================================# +# PROC : ::gridplus::=< # +# PURPOSE: Return specified widget option -or- default. # +#=======================================================================# + +proc ::gridplus::=< {option {default {}}} { + + set value [option get . "Gridplus.$option" -] + + if {$value eq ""} { + return $default + } else { + return $value + } +} + +#=======================================================================# +# End of Script: gridplus.tcl # +#=======================================================================# diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index 492bd94c..e453bfbf 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -296,6 +296,27 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } + proc test1_punkargs_any {args} { + set argd [punk::args::parse $args withdef { + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" + @opts -anyopts 0 + -return -default string -type any + -frametype -default \uFFEF -type any + -show_edge -default \uFFEF -type any + -show_seps -default \uFFEF -type any + -join -type none -multiple 1 + -x -default "" -type any + -y -default b -type any + -z -default c -type any + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + @values + }] + return [tcl::dict::get $argd opts] + } + punk::args::define { @id -id ::argparsingtest::test1_punkargs_by_id @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @@ -318,7 +339,6 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } - } proc test1_punkargs_parsecache {args} { set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs_by_id] return [tcl::dict::get $argd opts] diff --git a/src/modules/gridplus-buildversion.txt b/src/modules/gridplus-buildversion.txt new file mode 100644 index 00000000..f1c9d334 --- /dev/null +++ b/src/modules/gridplus-buildversion.txt @@ -0,0 +1,3 @@ +2.12b0 +#First line must be a tm version number +#all other lines are ignored. diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 8c28bf55..20994481 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu @values -min 0 -max 0 }] proc sgr_cache {args} { - set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache] + set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 8be6f9d9..e5843d54 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args { variable id_cache_rawdef set defspace "" if {[dict exists $rawdef_cache_about $args]} { - set cinfo [dict get $rawdef_cache_about $args] + set cinfo [dict get $rawdef_cache_about $args] set id [dict get $cinfo -id] set is_dynamic [dict get $cinfo -dynamic] if {[dict exists $cinfo -defspace]} { @@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args { #test the rawdef for @dynamic directive proc rawdef_is_dynamic {rawdef} { #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}] if {$flagged_dynamic} { return true } @@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args { #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" set maxloop 10 ;#failsafe - while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} { + while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} { #looks like a script - haven't gone up far enough? #(e.g patternpunk oo system: >punk . poses -invalidoption) incr call_level -1 @@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args { if {$use_table} { append errmsg \n } else { - if {($returntype in {table tableobject}) && !$has_textblock} { + if {!$has_textblock && ($returntype in {table tableobject})} { append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n } else { append errmsg \n @@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args { variable parse_cache [dict create] proc parse {args} { #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef if {[llength $args] < 3} { #error "punk::args::parse - invalid call. < 3 args" punk::args::parse $args -cache 1 withid ::punk::args::parse @@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args { } } #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals + #set values $opts_and_vals #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + #set tailtype [lindex $values 0] ;#withid|withdef + #set tailargs [lrange $values 1 end] + set tailtype [lpop opts_and_vals 0] - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} #Default the -errorstyle to standard # (slow on unhappy path - but probably clearest for playing with new APIs interactively) @@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args { } switch -- $tailtype { withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] + #JJJ + #set id [lindex $opts_and_vals 0] + set deflist [raw_def [lindex $opts_and_vals 0]] if {[llength $deflist] == 0} { + if {[llength $opts_and_vals] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } error "punk::args::parse - no such id: $id" } } withdef { - set deflist $tailargs + set deflist $opts_and_vals if {[llength $deflist] < 1} { error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" } default { error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" @@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args { proc get_dict {deflist rawargs args} { #see arg_error regarding considerations around unhappy-path performance - if {![punk::args::lib::string_is_dict $args]} { - error "punk::args::get_dict args must be a dict of option value pairs" - } set defaults [dict create\ -form *\ ] + #if {![punk::args::lib::string_is_dict $args]} { + # error "punk::args::get_dict args must be a dict of option value pairs" + #} set proc_opts [dict merge $defaults $args] dict for {k v} $proc_opts { switch -- $k { @@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args { #define will either return a permanently cached argspecs (-dynamic 0) - or # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info # ----------------------------------------------- # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars + #tcl::dict::with argspecs {} ;#turn keys into vars #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names # ----------------------------------------------- + #we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with + set FORMS [dict get $argspecs FORMS] + set form_names [dict get $argspecs form_names] + + set opt_form [dict get $proc_opts -form] if {$opt_form eq "*"} { set selected_forms $form_names @@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args { #todo - handle multiple fids? set fid [lindex $selected_forms 0] set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + # formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED + # LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED + # LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES + # OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS + # VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS + # VAL_CHECKS_DEFAULTS FORMDISPLAY + + #tcl::dict::with formdict {} + ##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + #individual var extraction is faster than 'dict with' - even though we need nearly every key + set ARG_INFO [dict get $formdict ARG_INFO] + set ARG_CHECKS [dict get $formdict ARG_CHECKS] + + set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS] + set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED] + set LEADER_NAMES [dict get $formdict LEADER_NAMES] + set LEADER_MIN [dict get $formdict LEADER_MIN] + set LEADER_MAX [dict get $formdict LEADER_MAX] + set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO] + set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED] + set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS] + set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS] + + set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS] + set OPT_REQUIRED [dict get $formdict OPT_REQUIRED] + set OPT_NAMES [dict get $formdict OPT_NAMES] + set OPT_ANY [dict get $formdict OPT_ANY] + #set OPT_MIN [dict get $formdict OPT_MIN] + set OPT_MAX [dict get $formdict OPT_MAX] + #set OPT_SOLOS [dict get $formdict OPT_SOLOS] + set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] + set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] + #set OPT_GROUPS [dict get $formdict OPT_GROUPS] + + set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS] + set VAL_REQUIRED [dict get $formdict VAL_REQUIRED] + set VAL_NAMES [dict get $formdict VAL_NAMES] + set VAL_MIN [dict get $formdict VAL_MIN] + set VAL_MAX [dict get $formdict VAL_MAX] + set VAL_UNNAMED [dict get $formdict VAL_UNNAMED] + set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS] + set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS] + + set FORMDISPLAY [dict get $formdict FORMDISPLAY] + if {$VAL_MIN eq ""} { set valmin 0 #set VAL_MIN 0 @@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args { # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) # e.g -types {a ?xxx?} #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] set clause_length 0 - foreach t $typelist { + #for each t in typelist + foreach t [dict get $ARG_INFO $v -type] { if {![string match {\?*\?} $t]} { incr clause_length } @@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args { #REVIEW - what about optional members in leaders e.g -type {int ?double?} set named_leader_args_max 0 foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] + incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]] } #set id [dict get $argspecs id] @@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args { #} set can_have_leaders 1 ;#default assumption - if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} { + if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} { set can_have_leaders 0 } @@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args { if {$OPT_MAX ne "0"} { foreach t $leader_type { set raw [lindex $rawargs $tentative_idx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set flagname $raw if {[string match --* $raw]} { @@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args { # and only for the last defined leader. This should be done in the definition parsing - not here. foreach t $leader_type { set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set matchopt [::tcl::prefix::match -error {} $all_opts $raw] @@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args { set leadermin $LEADER_MIN } if {$LEADER_MAX eq ""} { - if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} { + if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} { set leadermax 0 } else { set leadermax -1 @@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args { } if {$VAL_MAX eq ""} { - if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} { + if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} { set valmax 0 } else { set valmax -1 @@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args { #assert leadermax leadermin are numeric #assert - remaining_rawargs has been reduced by leading positionals - set opts [dict create] ;#don't set to OPT_DEFAULTS here + #beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true) + #set opts [dict create] ;#don't set to OPT_DEFAULTS here + set opts [list] + set leaders [list] set arglist {} @@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args { #valmin, valmax #puts stderr "remaining_rawargs: $remaining_rawargs" #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { + if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} { #contains at least one possible flag set maxidx [expr {[llength $remaining_rawargs] -1}] if {$valmax == -1} { @@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args { break } set a [lindex $remaining_rawargs $i] - switch -glob -- $a { - -- { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } - --* { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= 2} { + #only allow longopt-style = for double leading dash longopts + #--*= 2} { + if {$eposn > 2 && [string match --* $a]} { #only allow longopt-style = for double leading dash longopts #--*=>>>==== $opts" + #puts ">>>>====opts: $opts" set seen_pks [list] #treating opts as list for this loop. foreach optset $OPT_NAMES { @@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $leadername -optional]} { puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?" incr ldridx -1 set leadername_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$leadername ni $leadernames_received} { #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." @@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could use break? continue } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { + if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset leaders_dict $leadername @@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $valname -optional]} { #error 333 puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" incr validx -1 set valname_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$valname ni $valnames_received} { #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." @@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could break? continue } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { + if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset values_dict $vname @@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args { #puts " >>>>>>> ---lookup_optset :$lookup_optset" #puts "---argstate:$argstate" #JJJ argname_or_ident; ident example: -increasing|-SORTOPTION + + #review - ensure all possible keys present in thisarg_keys + + set pkoverride [Dict_getdef $argstate -parsekey ""] + tcl::dict::for {argname_or_ident value_group} $opts_and_values { # #parsekey: key used in resulting leaders opts values dictionaries @@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args { #get full option name such as -fg|-foreground from non-alias name such as -foreground #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined set argname [dict get $lookup_optset $argname_or_ident] - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args { } } else { set argname $argname_or_ident - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args { #an example argname_or_compound for the above might be: -path|--filename # where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] + #using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict + set typelist [tcl::dict::get $thisarg -type] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + #set validationtransform [tcl::dict::get $thisarg -validationtransform] + set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { set defaultval [tcl::dict::get $thisarg -default] } - set typelist [tcl::dict::get $thisarg -type] set clause_size [llength $typelist] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set validationtransform [tcl::dict::get $thisarg -validationtransform] #JJJJ @@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args { set vlist_original $vlist ;#retain for possible final strip_ansi #review - validationtransform - if {$is_validate_ansistripped} { + if {[llength $vlist] && $is_validate_ansistripped} { #validate_ansistripped 1 package require punk::ansi set vlist_check [list] @@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args { set vlist_typelist_validate [list] #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$parsekey in $receivednames && $has_choices} { + if {$has_choices && $parsekey in $receivednames} { #-choices must also work with -multiple #todo -choicelabels set choiceprefix [tcl::dict::get $thisarg -choiceprefix] @@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args { set vlist [list] set vlist_check_validate [list] } else { - if {[llength $vlist] && $has_default} { + if {$has_default && [llength $vlist]} { #defaultval here is a value for the entire clause. (clause usually length 1) #J2 #set vlist_validate [list] #set vlist_check_validate [list] - set tp [dict get $thisarg -type] - set clause_size [llength $tp] + #set tp [dict get $thisarg -type] + set clause_size [llength $typelist] foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist { #JJJJ #REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation? @@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args { } } - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach clause_value $vlist { - foreach e $clause_value { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + if {[llength $vlist]} { + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {!$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach clause_value $vlist { + foreach e $clause_value { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } } } } - } - #puts "argname:$argname v:$v is_default:$is_default" - #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value - #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. - #arguments that are at their default are not subject to type and other checks + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] #$t = clause column #for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {} @@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args { } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident $stripped_list - } - option { - tcl::dict::set opts $argname_or_ident $stripped_list - } - value { - tcl::dict::set values_dict $argname_or_ident $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {$is_multiple} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident $stripped_list + } + option { + tcl::dict::set opts $argname_or_ident $stripped_list + } + value { + tcl::dict::set values_dict $argname_or_ident $stripped_list + } } - value { - tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } } } } + } + } set finalopts [dict create] diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 3ef677be..ed881786 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -1329,7 +1329,7 @@ namespace eval punk::console { "Omit or pass empty string to query current echo state." }] proc echo {args} { - set argd [punk::args::parse $args withid ::punk::console::local::echo] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo] set onoff [dict get $argd values onoff] set is_windows [string equal "windows" $::tcl_platform(platform)] @@ -1835,7 +1835,7 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc dec_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -1881,7 +1881,7 @@ namespace eval punk::console { } #todo - should accept multiple mode nums/names at once proc dec_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1927,7 +1927,7 @@ namespace eval punk::console { }] } proc dec_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1990,7 +1990,7 @@ namespace eval punk::console { }] } proc dec_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode] lassign [dict values $argd] leaders opts values received set console [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2061,7 +2061,7 @@ namespace eval punk::console { "Match code or name" }] proc dec_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes] lassign [dict values $argd] leaders opts values received set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2241,7 +2241,7 @@ namespace eval punk::console { }] } proc ansi_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode] lassign [dict values $argd] leaders opts values received set console [dict get $opts -console] set num_or_name [dict get $values mode] @@ -2314,7 +2314,7 @@ namespace eval punk::console { }] } proc ansi_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2361,7 +2361,7 @@ namespace eval punk::console { }] } proc ansi_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2427,7 +2427,7 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc ansi_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2469,7 +2469,7 @@ namespace eval punk::console { "Match code or name" }] proc ansi_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes] lassign [dict values $argd] leaders opts values received set terminal [dict get $opts -console] set passthrough [dict get $opts -passthrough] @@ -2716,7 +2716,7 @@ namespace eval punk::console { name -type string }] proc dec_request_setting {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_request_setting] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting] lassign [dict values $argd] leaders opts values set console [dict get $opts -console] set name [dict get $values name] diff --git a/src/modules/punk/imap4-999999.0a1.0.tm b/src/modules/punk/imap4-999999.0a1.0.tm index 8ef1ccd1..ede4704c 100644 --- a/src/modules/punk/imap4-999999.0a1.0.tm +++ b/src/modules/punk/imap4-999999.0a1.0.tm @@ -2750,7 +2750,7 @@ tcl::namespace::eval punk::imap4 { @values -min 0 -max 0 }] proc NOOP {args} { - set argd [punk::args::parse $args withid ::punk::imap4::NOOP] + set argd [punk::args::parse $args -cache 1 withid ::punk::imap4::NOOP] set chan [dict get $argd leaders chan] punk::imap4::proto::simplecmd $chan NOOP } diff --git a/src/modules/punk/netbox-999999.0a1.0.tm b/src/modules/punk/netbox-999999.0a1.0.tm index 8e387202..ad7469dc 100644 --- a/src/modules/punk/netbox-999999.0a1.0.tm +++ b/src/modules/punk/netbox-999999.0a1.0.tm @@ -1363,7 +1363,7 @@ tcl::namespace::eval punk::netbox { @values -min 0 -max 0 }] proc _datafile {args} { - set argd [punk::args::parse $args withid ::punk::netbox::_datafile] + set argd [punk::args::parse $args -cache 1 withid ::punk::netbox::_datafile] lassign [dict values $argd] leaders opts values received set be_quiet [dict exists $received -quiet] diff --git a/src/modules/punk/sixel-999999.0a1.0.tm b/src/modules/punk/sixel-999999.0a1.0.tm index fef9356d..3db2202c 100644 --- a/src/modules/punk/sixel-999999.0a1.0.tm +++ b/src/modules/punk/sixel-999999.0a1.0.tm @@ -240,7 +240,7 @@ tcl::namespace::eval punk::sixel { variable device_attribute_cache set device_attribute_cache [dict create] proc can_sixel {args} { - set argd [punk::args::parse $args withid ::punk::sixel::can_sixel] + set argd [punk::args::parse $args -cache 1 withid ::punk::sixel::can_sixel] lassign [dict values $argd] leaders opts values received set terminal [dict get $values terminal] diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 5c1406be..114157b4 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -4815,7 +4815,7 @@ tcl::namespace::eval textblock { 123456789ABCDEF " -size -type integer\ - -default 15\ + -default 16\ -optional 1\ -range {1 ""} -direction -default horizontal\ @@ -4946,6 +4946,7 @@ tcl::namespace::eval textblock { for {set r 0} {$r < $size} {incr r} { append block [::join $charsubset ""] \n } + set block [tcl::string::trimright $block \n] if {[llength $colour]} { set block [a+ {*}$colour]$block$RST } @@ -7843,7 +7844,7 @@ tcl::namespace::eval textblock { } } proc frame_cache {args} { - set argd [punk::args::parse $args withid ::textblock::frame_cache] + set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache] set action [dict get $argd values action] variable frame_cache set all_values_dict [dict get $argd values] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 7bf4bf7c..9c330abb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu @values -min 0 -max 0 }] proc sgr_cache {args} { - set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache] + set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 24f98b6b..beb0bc9f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -373,9 +373,9 @@ tcl::namespace::eval ::punk::args::helpers { #Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between # the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems. - set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str] - set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str] - set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {^\{|[^\\](\{+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {[^\\](\}+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-olive} {\[|\]} $str] #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args { variable id_cache_rawdef set defspace "" if {[dict exists $rawdef_cache_about $args]} { - set cinfo [dict get $rawdef_cache_about $args] + set cinfo [dict get $rawdef_cache_about $args] set id [dict get $cinfo -id] set is_dynamic [dict get $cinfo -dynamic] if {[dict exists $cinfo -defspace]} { @@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args { #test the rawdef for @dynamic directive proc rawdef_is_dynamic {rawdef} { #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}] if {$flagged_dynamic} { return true } @@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args { #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" set maxloop 10 ;#failsafe - while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} { + while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} { #looks like a script - haven't gone up far enough? #(e.g patternpunk oo system: >punk . poses -invalidoption) incr call_level -1 @@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args { if {$use_table} { append errmsg \n } else { - if {($returntype in {table tableobject}) && !$has_textblock} { + if {!$has_textblock && ($returntype in {table tableobject})} { append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n } else { append errmsg \n @@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args { variable parse_cache [dict create] proc parse {args} { #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef if {[llength $args] < 3} { #error "punk::args::parse - invalid call. < 3 args" punk::args::parse $args -cache 1 withid ::punk::args::parse @@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args { } } #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals + #set values $opts_and_vals #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + #set tailtype [lindex $values 0] ;#withid|withdef + #set tailargs [lrange $values 1 end] + set tailtype [lpop opts_and_vals 0] - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} #Default the -errorstyle to standard # (slow on unhappy path - but probably clearest for playing with new APIs interactively) @@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args { } switch -- $tailtype { withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] + #JJJ + #set id [lindex $opts_and_vals 0] + set deflist [raw_def [lindex $opts_and_vals 0]] if {[llength $deflist] == 0} { + if {[llength $opts_and_vals] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } error "punk::args::parse - no such id: $id" } } withdef { - set deflist $tailargs + set deflist $opts_and_vals if {[llength $deflist] < 1} { error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" } default { error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" @@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args { proc get_dict {deflist rawargs args} { #see arg_error regarding considerations around unhappy-path performance - if {![punk::args::lib::string_is_dict $args]} { - error "punk::args::get_dict args must be a dict of option value pairs" - } set defaults [dict create\ -form *\ ] + #if {![punk::args::lib::string_is_dict $args]} { + # error "punk::args::get_dict args must be a dict of option value pairs" + #} set proc_opts [dict merge $defaults $args] dict for {k v} $proc_opts { switch -- $k { @@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args { #define will either return a permanently cached argspecs (-dynamic 0) - or # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info # ----------------------------------------------- # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars + #tcl::dict::with argspecs {} ;#turn keys into vars #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names # ----------------------------------------------- + #we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with + set FORMS [dict get $argspecs FORMS] + set form_names [dict get $argspecs form_names] + + set opt_form [dict get $proc_opts -form] if {$opt_form eq "*"} { set selected_forms $form_names @@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args { #todo - handle multiple fids? set fid [lindex $selected_forms 0] set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + # formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED + # LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED + # LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES + # OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS + # VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS + # VAL_CHECKS_DEFAULTS FORMDISPLAY + + #tcl::dict::with formdict {} + ##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + #individual var extraction is faster than 'dict with' - even though we need nearly every key + set ARG_INFO [dict get $formdict ARG_INFO] + set ARG_CHECKS [dict get $formdict ARG_CHECKS] + + set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS] + set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED] + set LEADER_NAMES [dict get $formdict LEADER_NAMES] + set LEADER_MIN [dict get $formdict LEADER_MIN] + set LEADER_MAX [dict get $formdict LEADER_MAX] + set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO] + set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED] + set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS] + set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS] + + set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS] + set OPT_REQUIRED [dict get $formdict OPT_REQUIRED] + set OPT_NAMES [dict get $formdict OPT_NAMES] + set OPT_ANY [dict get $formdict OPT_ANY] + #set OPT_MIN [dict get $formdict OPT_MIN] + set OPT_MAX [dict get $formdict OPT_MAX] + #set OPT_SOLOS [dict get $formdict OPT_SOLOS] + set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] + set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] + #set OPT_GROUPS [dict get $formdict OPT_GROUPS] + + set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS] + set VAL_REQUIRED [dict get $formdict VAL_REQUIRED] + set VAL_NAMES [dict get $formdict VAL_NAMES] + set VAL_MIN [dict get $formdict VAL_MIN] + set VAL_MAX [dict get $formdict VAL_MAX] + set VAL_UNNAMED [dict get $formdict VAL_UNNAMED] + set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS] + set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS] + + set FORMDISPLAY [dict get $formdict FORMDISPLAY] + if {$VAL_MIN eq ""} { set valmin 0 #set VAL_MIN 0 @@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args { # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) # e.g -types {a ?xxx?} #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] set clause_length 0 - foreach t $typelist { + #for each t in typelist + foreach t [dict get $ARG_INFO $v -type] { if {![string match {\?*\?} $t]} { incr clause_length } @@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args { #REVIEW - what about optional members in leaders e.g -type {int ?double?} set named_leader_args_max 0 foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] + incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]] } #set id [dict get $argspecs id] @@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args { #} set can_have_leaders 1 ;#default assumption - if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} { + if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} { set can_have_leaders 0 } @@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args { if {$OPT_MAX ne "0"} { foreach t $leader_type { set raw [lindex $rawargs $tentative_idx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set flagname $raw if {[string match --* $raw]} { @@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args { # and only for the last defined leader. This should be done in the definition parsing - not here. foreach t $leader_type { set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set matchopt [::tcl::prefix::match -error {} $all_opts $raw] @@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args { set leadermin $LEADER_MIN } if {$LEADER_MAX eq ""} { - if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} { + if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} { set leadermax 0 } else { set leadermax -1 @@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args { } if {$VAL_MAX eq ""} { - if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} { + if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} { set valmax 0 } else { set valmax -1 @@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args { #assert leadermax leadermin are numeric #assert - remaining_rawargs has been reduced by leading positionals - set opts [dict create] ;#don't set to OPT_DEFAULTS here + #beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true) + #set opts [dict create] ;#don't set to OPT_DEFAULTS here + set opts [list] + set leaders [list] set arglist {} @@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args { #valmin, valmax #puts stderr "remaining_rawargs: $remaining_rawargs" #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { + if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} { #contains at least one possible flag set maxidx [expr {[llength $remaining_rawargs] -1}] if {$valmax == -1} { @@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args { break } set a [lindex $remaining_rawargs $i] - switch -glob -- $a { - -- { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } - --* { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= 2} { + #only allow longopt-style = for double leading dash longopts + #--*= 2} { + if {$eposn > 2 && [string match --* $a]} { #only allow longopt-style = for double leading dash longopts #--*=>>>==== $opts" + #puts ">>>>====opts: $opts" set seen_pks [list] #treating opts as list for this loop. foreach optset $OPT_NAMES { @@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $leadername -optional]} { puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?" incr ldridx -1 set leadername_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$leadername ni $leadernames_received} { #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." @@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could use break? continue } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { + if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset leaders_dict $leadername @@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $valname -optional]} { #error 333 puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" incr validx -1 set valname_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$valname ni $valnames_received} { #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." @@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could break? continue } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { + if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset values_dict $vname @@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args { #puts " >>>>>>> ---lookup_optset :$lookup_optset" #puts "---argstate:$argstate" #JJJ argname_or_ident; ident example: -increasing|-SORTOPTION + + #review - ensure all possible keys present in thisarg_keys + + set pkoverride [Dict_getdef $argstate -parsekey ""] + tcl::dict::for {argname_or_ident value_group} $opts_and_values { # #parsekey: key used in resulting leaders opts values dictionaries @@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args { #get full option name such as -fg|-foreground from non-alias name such as -foreground #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined set argname [dict get $lookup_optset $argname_or_ident] - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args { } } else { set argname $argname_or_ident - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args { #an example argname_or_compound for the above might be: -path|--filename # where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] + #using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict + set typelist [tcl::dict::get $thisarg -type] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + #set validationtransform [tcl::dict::get $thisarg -validationtransform] + set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { set defaultval [tcl::dict::get $thisarg -default] } - set typelist [tcl::dict::get $thisarg -type] set clause_size [llength $typelist] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set validationtransform [tcl::dict::get $thisarg -validationtransform] #JJJJ @@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args { set vlist_original $vlist ;#retain for possible final strip_ansi #review - validationtransform - if {$is_validate_ansistripped} { + if {[llength $vlist] && $is_validate_ansistripped} { #validate_ansistripped 1 package require punk::ansi set vlist_check [list] @@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args { set vlist_typelist_validate [list] #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$parsekey in $receivednames && $has_choices} { + if {$has_choices && $parsekey in $receivednames} { #-choices must also work with -multiple #todo -choicelabels set choiceprefix [tcl::dict::get $thisarg -choiceprefix] @@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args { set vlist [list] set vlist_check_validate [list] } else { - if {[llength $vlist] && $has_default} { + if {$has_default && [llength $vlist]} { #defaultval here is a value for the entire clause. (clause usually length 1) #J2 #set vlist_validate [list] #set vlist_check_validate [list] - set tp [dict get $thisarg -type] - set clause_size [llength $tp] + #set tp [dict get $thisarg -type] + set clause_size [llength $typelist] foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist { #JJJJ #REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation? @@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args { } } - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach clause_value $vlist { - foreach e $clause_value { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + if {[llength $vlist]} { + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {!$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach clause_value $vlist { + foreach e $clause_value { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } } } } - } - #puts "argname:$argname v:$v is_default:$is_default" - #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value - #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. - #arguments that are at their default are not subject to type and other checks + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] #$t = clause column #for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {} @@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args { } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident $stripped_list - } - option { - tcl::dict::set opts $argname_or_ident $stripped_list - } - value { - tcl::dict::set values_dict $argname_or_ident $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {$is_multiple} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident $stripped_list + } + option { + tcl::dict::set opts $argname_or_ident $stripped_list + } + value { + tcl::dict::set values_dict $argname_or_ident $stripped_list + } } - value { - tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } } } } + } + } set finalopts [dict create] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index e3eca525..3d487b87 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -126,7 +126,8 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- proc example {str} { set str [string trimleft $str \n] - set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] + #set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] + set block [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"] #puts $result return $result diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index ff5c2904..c64720d2 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -702,6 +702,27 @@ namespace eval punk::console { -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" + -passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels { + none\ + { ANSI sent without any passthrough wrapping. + A terminal multiplexer such as tmux,screen,zellij may + not pass the request through to the underlying terminal(s) + This is the recommended/normal value for the option.} + tmux\ + { Wrap ANSI sequence with tmux passthrough sequence. + \x1bPtmux\;\x1b\\ + Note that a tmux session could be connected to multiple + terminals (perhaps of different types) - in which case multiple + responses may be received in a non-deterministic order. + Passthrough should generally be avoided except for debug/test + purposes. + } + auto\ + { Use existence of ::env(TMUX) to detect tmux and + send tmux passthrough sequence. + Not recommended except for debug/test purposes. + } + } -expected_ms -default 300 -type integer -help\ "Expected number of ms for response from terminal. 100ms is usually plenty for a local terminal and a @@ -731,6 +752,7 @@ namespace eval punk::console { set expected [dict get $opts -expected_ms] set ignoreok [dict get $opts -ignoreok] set returntype [dict get $opts -return] + set passthrough [dict get $opts -passthrough] set query [dict get $values query] set capturingendregex [dict get $values capturingendregex] @@ -784,7 +806,7 @@ namespace eval punk::console { set runningid [lindex $queue 0] if {$runningid ne $callid} { set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) - update ;#REVIEW - probably a bad idea + update ;#REVIEW - possibly a bad idea after 10 set runningid [lindex $queue 0] ;#jn test } @@ -836,6 +858,17 @@ namespace eval punk::console { } #write before console enableRaw vs after?? #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + + switch -- $passthrough { + auto { + if {[info exists ::env(TMUX)]} { + set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" + } + } + tmux { + set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" + } + } puts -nonewline $output $query;flush $output chan configure $input -blocking 0 @@ -847,8 +880,10 @@ namespace eval punk::console { #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features #------------------ # 1) faster - races? + #first read will read 3 bytes JJJJ $this_handler $input $callid $capturingendregex - $this_handler $input $callid $capturingendregex + #JJJJ + #$this_handler $input $callid $capturingendregex if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } @@ -1047,7 +1082,11 @@ namespace eval punk::console { upvar ::punk::console::ansi_response_tsclock tsclock #endregex should explicitly have a trailing $ - set status [catch {read $chan 1} bytes] + if {[string length $chunks($callid)] == 0} { + set status [catch {read $chan 3} bytes] + } else { + set status [catch {read $chan 1} bytes] + } if { $status != 0 } { # Error on the channel chan event $chan readable {} @@ -1290,7 +1329,7 @@ namespace eval punk::console { "Omit or pass empty string to query current echo state." }] proc echo {args} { - set argd [punk::args::parse $args withid ::punk::console::local::echo] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo] set onoff [dict get $argd values onoff] set is_windows [string equal "windows" $::tcl_platform(platform)] @@ -1343,6 +1382,7 @@ namespace eval punk::console { @opts -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -expected_ms -type integer -default 500 -help\ "Number of ms to wait for response" @values -min 1 -max 1 @@ -1356,11 +1396,12 @@ namespace eval punk::console { lassign [dict values $argd] leaders opts values received set request [dict get $values request] set inoutchannels [dict get $opts -terminal] + set passthrough [dict get $opts -passthrough] set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload set ts_start [clock millis] - set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] + set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels -passthrough $passthrough $request $capturingregex] set ts_end [clock millis] puts stderr $response set out "" @@ -1781,6 +1822,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -multiple 0 -help\ "integer for DEC mode, or name as in the dict: @@ -1793,10 +1835,11 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc dec_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode] lassign [dict values $argd] leaders opts values - set terminal [dict get $opts -console] - set mode [dict get $values mode] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set mode [dict get $values mode] if {[string is integer -strict $mode]} { set m $mode @@ -1810,7 +1853,7 @@ namespace eval punk::console { } set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[?$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex] return $payload } @@ -1838,7 +1881,7 @@ namespace eval punk::console { } #todo - should accept multiple mode nums/names at once proc dec_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1884,7 +1927,7 @@ namespace eval punk::console { }] } proc dec_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1931,6 +1974,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -refresh -type none -help\ "Force a re-test of the mode." -return -type string -choices {dict result} -default result -choicelabels { @@ -1946,9 +1990,10 @@ namespace eval punk::console { }] } proc dec_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode] lassign [dict values $argd] leaders opts values received - set console [dict get $opts -console] + set console [dict get $opts -console] + set passthrough [dict get $opts -passthrough] set num_or_name [dict get $values mode] set do_refresh [dict exists $received -refresh] set return [dict get $opts -return] @@ -1964,21 +2009,23 @@ namespace eval punk::console { } } variable dec_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" if {$do_refresh} { - if {[dict exists $dec_has_mode_cache $console $m]} { - dict unset dec_has_mode_cache $console $m + if {[dict exists $dec_has_mode_cache $cachekey $m]} { + dict unset dec_has_mode_cache $cachekey $m } } - if {![dict exists $dec_has_mode_cache $console $m]} { + if {![dict exists $dec_has_mode_cache $cachekey $m]} { set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[?$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex] #set has_mode [expr {$payload != 0}] #we can use the payload result as the response as non-zero responses evaluate to true set has_mode $payload if {$has_mode ne ""} { - dict set dec_has_mode_cache $console $m $has_mode + dict set dec_has_mode_cache $cachekey $m $has_mode set source "query" } else { #don't cache an empty/failed response - review @@ -1986,7 +2033,7 @@ namespace eval punk::console { set source "failedquery" } } else { - set has_mode [dict get $dec_has_mode_cache $console $m] + set has_mode [dict get $dec_has_mode_cache $cachekey $m] set source "cache" } if {$return eq "dict"} { @@ -2004,6 +2051,7 @@ namespace eval punk::console { {Show table of DEC modes with basic information.} @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -test -type none -help\ "Test current value/support for each mode" -supported -type none -help\ @@ -2013,10 +2061,11 @@ namespace eval punk::console { "Match code or name" }] proc dec_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes] lassign [dict values $argd] leaders opts values received - set terminal [dict get $opts -console] - set do_test [dict exists $received -test] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set do_test [dict exists $received -test] set only_supported [dict exists $received -supported] if {[dict exists $values match]} { set matches [dict get $values match] @@ -2074,7 +2123,7 @@ namespace eval punk::console { set RST "" if {$do_test} { #dec_has_mode can be cached - in which case only 0|3|4 can be relied upon without re-querying - set hasmode_dict [dec_has_mode -console $terminal -return dict $code] + set hasmode_dict [dec_has_mode -console $terminal -passthrough $passthrough -return dict $code] switch -- [dict get $hasmode_dict result] { 0 { if {$only_supported} { @@ -2089,7 +2138,7 @@ namespace eval punk::console { 1 - 2 { if {[dict get $hasmode_dict source] eq "cache"} { #a terminal query is required - set testresult [dec_get_mode -console $terminal $code] + set testresult [dec_get_mode -console $terminal -passthrough $passthrough $code] } else { set testresult [dict get $hasmode_dict result] if {![string is integer -strict $testresult]} { @@ -2135,7 +2184,7 @@ namespace eval punk::console { } else { if {$only_supported} { #dec_has_mode still queries terminal - but is cached if a response was received - if {[dec_has_mode -console $terminal $code] == 0} { + if {[dec_has_mode -console $terminal -passthrough $passthrough $code] == 0} { continue } } @@ -2184,6 +2233,7 @@ namespace eval punk::console { source indicates whether the result came from query or cache." } + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -help\ "integer for ANSI mode, or name as in the dict: @@ -2191,12 +2241,13 @@ namespace eval punk::console { }] } proc ansi_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode] lassign [dict values $argd] leaders opts values received - set console [dict get $opts -console] + set console [dict get $opts -console] set num_or_name [dict get $values mode] - set return [dict get $opts -return] - set do_refresh [dict exists $received -refresh] + set return [dict get $opts -return] + set passthrough [dict get $opts -passthrough] + set do_refresh [dict exists $received -refresh] if {[string is integer -strict $num_or_name]} { set m $num_or_name @@ -2209,20 +2260,22 @@ namespace eval punk::console { } } variable ansi_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" if {$do_refresh} { - if {[dict exists $ansi_has_mode_cache $console $m]} { - dict unset ansi_has_mode_cache $console $m + if {[dict exists $ansi_has_mode_cache $cachekey $m]} { + dict unset ansi_has_mode_cache $cachekey $m } } - if {![dict exists $ansi_has_mode_cache $console $m]} { + if {![dict exists $ansi_has_mode_cache $cachekey $m]} { set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex] #set has_mode [expr {$payload != 0}] set has_mode $payload if {$has_mode ne ""} { - dict set ansi_has_mode_cache $console $m $has_mode + dict set ansi_has_mode_cache $cachekey $m $has_mode set source "query" } else { #don't cache an empty/failed response - review @@ -2230,7 +2283,7 @@ namespace eval punk::console { set source "failedquery" } } else { - set has_mode [dict get $ansi_has_mode_cache $console $m] + set has_mode [dict get $ansi_has_mode_cache $cachekey $m] set source "cache" } if {$return eq "dict"} { @@ -2261,7 +2314,7 @@ namespace eval punk::console { }] } proc ansi_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2308,7 +2361,7 @@ namespace eval punk::console { }] } proc ansi_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2361,6 +2414,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -multiple 0 -help\ "integer for ANSI mode, or name as in the dict: @@ -2373,10 +2427,11 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc ansi_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode] lassign [dict values $argd] leaders opts values - set terminal [dict get $opts -console] - set mode [dict get $values mode] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set mode [dict get $values mode] if {[string is integer -strict $mode]} { set m $mode @@ -2390,7 +2445,7 @@ namespace eval punk::console { } set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex] return $payload } #todo ansi_unset_mode @@ -2404,6 +2459,7 @@ namespace eval punk::console { {Show table of ANSI modes with basic information.} @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -test -type none -help\ "Test current value/support for each mode" -supported -type none -help\ @@ -2413,10 +2469,11 @@ namespace eval punk::console { "Match code or name" }] proc ansi_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes] lassign [dict values $argd] leaders opts values received - set terminal [dict get $opts -console] - set do_test [dict exists $received -test] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set do_test [dict exists $received -test] if {[dict exists $values match]} { set matches [dict get $values match] } else { @@ -2500,7 +2557,7 @@ namespace eval punk::console { set reset_state_colour "" set RST "" if {$do_test} { - set hasmode_dict [ansi_has_mode -console $terminal -return dict $code] + set hasmode_dict [ansi_has_mode -console $terminal -passthrough $passthrough -return dict $code] switch -- [dict get $hasmode_dict result] { 0 { if {$only_supported} { @@ -2515,7 +2572,7 @@ namespace eval punk::console { 1 - 2 { if {[dict get $hasmode_dict source] eq "cache"} { #a terminal query is required - set testresult [ansi_get_mode -console $terminal $code] + set testresult [ansi_get_mode -console $terminal -passthrough $passthrough $code] } else { set testresult [dict get $hasmode_dict result] if {![string is integer -strict $testresult]} { @@ -2561,7 +2618,7 @@ namespace eval punk::console { } else { if {$only_supported} { #ansi_has_mode still queries terminal - but is cached if a response was received - if {[ansi_has_mode -console $terminal $code] == 0} { + if {[ansi_has_mode -console $terminal -passthrough $passthrough $code] == 0} { continue } } @@ -2659,7 +2716,7 @@ namespace eval punk::console { name -type string }] proc dec_request_setting {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_request_setting] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting] lassign [dict values $argd] leaders opts values set console [dict get $opts -console] set name [dict get $values name] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 2a1d9370..883f82de 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns { set a [a+ bold purple] set e [a+ bold yellow] set p [a+ bold white] - set c_nat [a+ web-gray] ;#native - set c_int [a+ web-orange] ;#interps - set c_cor [a+ web-hotpink] ;#coroutines + #set c_nat [a+ web-gray] ;#native + set c_nat [a+ term-silver] ;#native + set c_int [a+ term-orange1] ;#interps + set c_cor [a+ term-hotpink] ;#coroutines set c_ooo [a+ bold cyan] ;#object - set c_ooc [a+ web-aquamarine] ;#class - set c_ooO [a+ web-dodgerblue] ;#privateObject - set c_ooC [a+ web-lightskyblue] ;#privateClass - set c_zst [a+ web-yellow] ;#zlibstreams + #set c_ooc [a+ web-aquamarine] ;#class + set c_ooc [a+ term-aqua] ;#class + #set c_ooO [a+ web-dodgerblue] ;#privateObject + set c_ooO [a+ term-purple-c] ;#privateObject + #set c_ooC [a+ web-lightskyblue] ;#privateClass + set c_ooC [a+ term-cornflowerblue] ;#privateClass + set c_zst [a+ term-yellow] ;#zlibstreams set a1 [a][a+ cyan] foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 { @@ -6629,16 +6633,16 @@ y" {return quirkykeyscript} switch -- $syntax { basic { #rudimentary colourising only - set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] + set argl [punk::ansi::grepstr -return all -highlight term-teal {\{|\}} $argl] - set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. - set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon + set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. + set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon ##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] - set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body] - set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body] - set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body] + set body [punk::ansi::grepstr -return all -highlight term-teal {^(\{)|[^\\](\{+)} $body] + set body [punk::ansi::grepstr -return all -highlight term-teal {[^\\](\}+)} $body] + set body [punk::ansi::grepstr -return all -highlight term-orange {\[|\]} $body] } default { set is_highlighted 0 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index abef420d..36db6d56 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock { } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span @@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock { } else { if {$span eq "0"} { if {$remaining eq "0"} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" } else { incr remaining -1 @@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock { if {$remaining eq "0"} { #ok for new span value of any or > 0 if {$span ne "any" && $span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span @@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock { incr remaining -1 } } else { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" } } @@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock { $htable add_row [list "$hnum " $h "${width}x${height}" $s] incr hnum } - $htable configure_column 0 -ansibase [a+ web-dimgray] + $htable configure_column 0 -ansibase [a+ term-grey] tcl::dict::set col_header_tables $col $htable set colwidths [$htable column_widths] set icol 0 @@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock { set ecat [tcl::dict::create] set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] + #set ansi [a+ {*}$fc web-black Web-gold] + set ansi [a+ {*}$fc term-black Term-gold1] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { tcl::dict::set ecat $e $val @@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock { set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + set ansi [a+ {*}$fc term-black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val @@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock { set cat [list Li Na K Rb Cs Fr] #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set ansi [a+ {*}$fc term-black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock { set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set ansi [a+ {*}$fc term-black Term-salmon1] + set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + #set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc term-black Term-lightsteelblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock { set cat [list B Si Ge As Sb Te At] #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc black Brightcyan] + set ansi [a+ {*}$fc term-black Term-skyblue1] + set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + #set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc term-black Term-purple-c] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + #set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc term-black Term-plum1] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val @@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + #set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc term-black Term-silver] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4807,7 +4815,7 @@ tcl::namespace::eval textblock { 123456789ABCDEF " -size -type integer\ - -default 15\ + -default 16\ -optional 1\ -range {1 ""} -direction -default horizontal\ @@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock { the colour stripes will be oriented in this direction. " + -noreset -type none @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names @@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock { proc testblock {args} { set argd [punk::args::parse $args withid ::textblock::testblock] - set colour [dict get $argd values colour] - set size [dict get $argd opts -size] + lassign [dict values $argd] leaders opts values received + set colour [dict get $values colour] + set size [dict get $opts -size] + set noreset [dict exists $received -noreset] set rainbow_list [list] lappend rainbow_list {30 47} ;#black White @@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock { set longbows [concat {*}[lrepeat $numsets $rainbow_list]] set rainbow_list [lrange $longbows 0 $size-1] } - if {"noreset" in $colour} { + if {$noreset} { set RST "" } else { set RST [a] @@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock { set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } - if {"noreset" in $colour} { + if {$noreset} { return [textblock::join_basic -ansiresets 0 -- {*}$clist] } else { #return [textblock::join_basic -- {*}$clist] @@ -4935,6 +4946,7 @@ tcl::namespace::eval textblock { for {set r 0} {$r < $size} {incr r} { append block [::join $charsubset ""] \n } + set block [tcl::string::trimright $block \n] if {[llength $colour]} { set block [a+ {*}$colour]$block$RST } @@ -5642,22 +5654,22 @@ tcl::namespace::eval textblock { set headers [list] set blocks [list] - lappend blocks "[textblock::testblock 4 rainbow]" + lappend blocks "[textblock::testblock -size 4 rainbow]" lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend blocks "[textblock::testblock -size 4 rainbow][a]" lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]" lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]" lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]" lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-green]" lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] @@ -5665,13 +5677,13 @@ tcl::namespace::eval textblock { proc pad_example2 {} { set headers [list] set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a]" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-green]" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] @@ -6113,14 +6125,15 @@ tcl::namespace::eval textblock { proc welcome_test {} { package require punk::ansi package require patternpunk - set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]] + set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]] # Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com set table [[textblock::spantest] print] - set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + #set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ term-yellow][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock -size 15 rainbow] set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents] } @@ -7831,7 +7844,7 @@ tcl::namespace::eval textblock { } } proc frame_cache {args} { - set argd [punk::args::parse $args withid ::textblock::frame_cache] + set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache] set action [dict get $argd values action] variable frame_cache set all_values_dict [dict get $argd values] @@ -8350,13 +8363,14 @@ tcl::namespace::eval textblock { set usecache 0 #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] + set cache_key [a+ Term-red term-white]$cache_key[a] } if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { #colourise cache_key to warn if {$actual_contentwidth == 0} { #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] + #set cache_key [a+ Web-steelblue term-black]$cache_key[a] + set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a] } else { #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { @@ -8366,13 +8380,13 @@ tcl::namespace::eval textblock { } if {$actual_contentwidth < $cache_patternwidth} { set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] + set cache_key [a+ Term-orange1 term-black]$cache_key[a] } elseif {$actual_contentwidth == $cache_patternwidth} { #set usecache 1 } else { #actual_contentwidth > pattern set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] + set cache_key [a+ Term-red term-black]$cache_key[a] } } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 7bf4bf7c..9c330abb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu @values -min 0 -max 0 }] proc sgr_cache {args} { - set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache] + set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 24f98b6b..beb0bc9f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -373,9 +373,9 @@ tcl::namespace::eval ::punk::args::helpers { #Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between # the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems. - set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str] - set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str] - set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {^\{|[^\\](\{+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {[^\\](\}+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-olive} {\[|\]} $str] #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args { variable id_cache_rawdef set defspace "" if {[dict exists $rawdef_cache_about $args]} { - set cinfo [dict get $rawdef_cache_about $args] + set cinfo [dict get $rawdef_cache_about $args] set id [dict get $cinfo -id] set is_dynamic [dict get $cinfo -dynamic] if {[dict exists $cinfo -defspace]} { @@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args { #test the rawdef for @dynamic directive proc rawdef_is_dynamic {rawdef} { #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}] if {$flagged_dynamic} { return true } @@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args { #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" set maxloop 10 ;#failsafe - while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} { + while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} { #looks like a script - haven't gone up far enough? #(e.g patternpunk oo system: >punk . poses -invalidoption) incr call_level -1 @@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args { if {$use_table} { append errmsg \n } else { - if {($returntype in {table tableobject}) && !$has_textblock} { + if {!$has_textblock && ($returntype in {table tableobject})} { append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n } else { append errmsg \n @@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args { variable parse_cache [dict create] proc parse {args} { #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef if {[llength $args] < 3} { #error "punk::args::parse - invalid call. < 3 args" punk::args::parse $args -cache 1 withid ::punk::args::parse @@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args { } } #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals + #set values $opts_and_vals #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + #set tailtype [lindex $values 0] ;#withid|withdef + #set tailargs [lrange $values 1 end] + set tailtype [lpop opts_and_vals 0] - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} #Default the -errorstyle to standard # (slow on unhappy path - but probably clearest for playing with new APIs interactively) @@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args { } switch -- $tailtype { withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] + #JJJ + #set id [lindex $opts_and_vals 0] + set deflist [raw_def [lindex $opts_and_vals 0]] if {[llength $deflist] == 0} { + if {[llength $opts_and_vals] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } error "punk::args::parse - no such id: $id" } } withdef { - set deflist $tailargs + set deflist $opts_and_vals if {[llength $deflist] < 1} { error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" } default { error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" @@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args { proc get_dict {deflist rawargs args} { #see arg_error regarding considerations around unhappy-path performance - if {![punk::args::lib::string_is_dict $args]} { - error "punk::args::get_dict args must be a dict of option value pairs" - } set defaults [dict create\ -form *\ ] + #if {![punk::args::lib::string_is_dict $args]} { + # error "punk::args::get_dict args must be a dict of option value pairs" + #} set proc_opts [dict merge $defaults $args] dict for {k v} $proc_opts { switch -- $k { @@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args { #define will either return a permanently cached argspecs (-dynamic 0) - or # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info # ----------------------------------------------- # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars + #tcl::dict::with argspecs {} ;#turn keys into vars #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names # ----------------------------------------------- + #we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with + set FORMS [dict get $argspecs FORMS] + set form_names [dict get $argspecs form_names] + + set opt_form [dict get $proc_opts -form] if {$opt_form eq "*"} { set selected_forms $form_names @@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args { #todo - handle multiple fids? set fid [lindex $selected_forms 0] set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + # formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED + # LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED + # LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES + # OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS + # VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS + # VAL_CHECKS_DEFAULTS FORMDISPLAY + + #tcl::dict::with formdict {} + ##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + #individual var extraction is faster than 'dict with' - even though we need nearly every key + set ARG_INFO [dict get $formdict ARG_INFO] + set ARG_CHECKS [dict get $formdict ARG_CHECKS] + + set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS] + set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED] + set LEADER_NAMES [dict get $formdict LEADER_NAMES] + set LEADER_MIN [dict get $formdict LEADER_MIN] + set LEADER_MAX [dict get $formdict LEADER_MAX] + set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO] + set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED] + set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS] + set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS] + + set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS] + set OPT_REQUIRED [dict get $formdict OPT_REQUIRED] + set OPT_NAMES [dict get $formdict OPT_NAMES] + set OPT_ANY [dict get $formdict OPT_ANY] + #set OPT_MIN [dict get $formdict OPT_MIN] + set OPT_MAX [dict get $formdict OPT_MAX] + #set OPT_SOLOS [dict get $formdict OPT_SOLOS] + set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] + set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] + #set OPT_GROUPS [dict get $formdict OPT_GROUPS] + + set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS] + set VAL_REQUIRED [dict get $formdict VAL_REQUIRED] + set VAL_NAMES [dict get $formdict VAL_NAMES] + set VAL_MIN [dict get $formdict VAL_MIN] + set VAL_MAX [dict get $formdict VAL_MAX] + set VAL_UNNAMED [dict get $formdict VAL_UNNAMED] + set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS] + set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS] + + set FORMDISPLAY [dict get $formdict FORMDISPLAY] + if {$VAL_MIN eq ""} { set valmin 0 #set VAL_MIN 0 @@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args { # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) # e.g -types {a ?xxx?} #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] set clause_length 0 - foreach t $typelist { + #for each t in typelist + foreach t [dict get $ARG_INFO $v -type] { if {![string match {\?*\?} $t]} { incr clause_length } @@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args { #REVIEW - what about optional members in leaders e.g -type {int ?double?} set named_leader_args_max 0 foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] + incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]] } #set id [dict get $argspecs id] @@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args { #} set can_have_leaders 1 ;#default assumption - if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} { + if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} { set can_have_leaders 0 } @@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args { if {$OPT_MAX ne "0"} { foreach t $leader_type { set raw [lindex $rawargs $tentative_idx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set flagname $raw if {[string match --* $raw]} { @@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args { # and only for the last defined leader. This should be done in the definition parsing - not here. foreach t $leader_type { set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set matchopt [::tcl::prefix::match -error {} $all_opts $raw] @@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args { set leadermin $LEADER_MIN } if {$LEADER_MAX eq ""} { - if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} { + if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} { set leadermax 0 } else { set leadermax -1 @@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args { } if {$VAL_MAX eq ""} { - if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} { + if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} { set valmax 0 } else { set valmax -1 @@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args { #assert leadermax leadermin are numeric #assert - remaining_rawargs has been reduced by leading positionals - set opts [dict create] ;#don't set to OPT_DEFAULTS here + #beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true) + #set opts [dict create] ;#don't set to OPT_DEFAULTS here + set opts [list] + set leaders [list] set arglist {} @@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args { #valmin, valmax #puts stderr "remaining_rawargs: $remaining_rawargs" #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { + if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} { #contains at least one possible flag set maxidx [expr {[llength $remaining_rawargs] -1}] if {$valmax == -1} { @@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args { break } set a [lindex $remaining_rawargs $i] - switch -glob -- $a { - -- { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } - --* { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= 2} { + #only allow longopt-style = for double leading dash longopts + #--*= 2} { + if {$eposn > 2 && [string match --* $a]} { #only allow longopt-style = for double leading dash longopts #--*=>>>==== $opts" + #puts ">>>>====opts: $opts" set seen_pks [list] #treating opts as list for this loop. foreach optset $OPT_NAMES { @@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $leadername -optional]} { puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?" incr ldridx -1 set leadername_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$leadername ni $leadernames_received} { #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." @@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could use break? continue } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { + if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset leaders_dict $leadername @@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $valname -optional]} { #error 333 puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" incr validx -1 set valname_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$valname ni $valnames_received} { #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." @@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could break? continue } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { + if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset values_dict $vname @@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args { #puts " >>>>>>> ---lookup_optset :$lookup_optset" #puts "---argstate:$argstate" #JJJ argname_or_ident; ident example: -increasing|-SORTOPTION + + #review - ensure all possible keys present in thisarg_keys + + set pkoverride [Dict_getdef $argstate -parsekey ""] + tcl::dict::for {argname_or_ident value_group} $opts_and_values { # #parsekey: key used in resulting leaders opts values dictionaries @@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args { #get full option name such as -fg|-foreground from non-alias name such as -foreground #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined set argname [dict get $lookup_optset $argname_or_ident] - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args { } } else { set argname $argname_or_ident - set pkoverride [Dict_getdef $argstate -parsekey ""] + #set pkoverride [Dict_getdef $argstate -parsekey ""] if {$pkoverride ne ""} { set parsekey $pkoverride } else { @@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args { #an example argname_or_compound for the above might be: -path|--filename # where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] + #using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict + set typelist [tcl::dict::get $thisarg -type] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + #set validationtransform [tcl::dict::get $thisarg -validationtransform] + set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { set defaultval [tcl::dict::get $thisarg -default] } - set typelist [tcl::dict::get $thisarg -type] set clause_size [llength $typelist] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set validationtransform [tcl::dict::get $thisarg -validationtransform] #JJJJ @@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args { set vlist_original $vlist ;#retain for possible final strip_ansi #review - validationtransform - if {$is_validate_ansistripped} { + if {[llength $vlist] && $is_validate_ansistripped} { #validate_ansistripped 1 package require punk::ansi set vlist_check [list] @@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args { set vlist_typelist_validate [list] #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$parsekey in $receivednames && $has_choices} { + if {$has_choices && $parsekey in $receivednames} { #-choices must also work with -multiple #todo -choicelabels set choiceprefix [tcl::dict::get $thisarg -choiceprefix] @@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args { set vlist [list] set vlist_check_validate [list] } else { - if {[llength $vlist] && $has_default} { + if {$has_default && [llength $vlist]} { #defaultval here is a value for the entire clause. (clause usually length 1) #J2 #set vlist_validate [list] #set vlist_check_validate [list] - set tp [dict get $thisarg -type] - set clause_size [llength $tp] + #set tp [dict get $thisarg -type] + set clause_size [llength $typelist] foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist { #JJJJ #REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation? @@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args { } } - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach clause_value $vlist { - foreach e $clause_value { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + if {[llength $vlist]} { + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {!$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach clause_value $vlist { + foreach e $clause_value { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } } } } - } - #puts "argname:$argname v:$v is_default:$is_default" - #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value - #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. - #arguments that are at their default are not subject to type and other checks + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] #$t = clause column #for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {} @@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args { } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident $stripped_list - } - option { - tcl::dict::set opts $argname_or_ident $stripped_list - } - value { - tcl::dict::set values_dict $argname_or_ident $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {$is_multiple} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident $stripped_list + } + option { + tcl::dict::set opts $argname_or_ident $stripped_list + } + value { + tcl::dict::set values_dict $argname_or_ident $stripped_list + } } - value { - tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] + } } } } + } + } set finalopts [dict create] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index e3eca525..3d487b87 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -126,7 +126,8 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- proc example {str} { set str [string trimleft $str \n] - set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] + #set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] + set block [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"] #puts $result return $result diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index ff5c2904..c64720d2 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -702,6 +702,27 @@ namespace eval punk::console { -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" + -passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels { + none\ + { ANSI sent without any passthrough wrapping. + A terminal multiplexer such as tmux,screen,zellij may + not pass the request through to the underlying terminal(s) + This is the recommended/normal value for the option.} + tmux\ + { Wrap ANSI sequence with tmux passthrough sequence. + \x1bPtmux\;\x1b\\ + Note that a tmux session could be connected to multiple + terminals (perhaps of different types) - in which case multiple + responses may be received in a non-deterministic order. + Passthrough should generally be avoided except for debug/test + purposes. + } + auto\ + { Use existence of ::env(TMUX) to detect tmux and + send tmux passthrough sequence. + Not recommended except for debug/test purposes. + } + } -expected_ms -default 300 -type integer -help\ "Expected number of ms for response from terminal. 100ms is usually plenty for a local terminal and a @@ -731,6 +752,7 @@ namespace eval punk::console { set expected [dict get $opts -expected_ms] set ignoreok [dict get $opts -ignoreok] set returntype [dict get $opts -return] + set passthrough [dict get $opts -passthrough] set query [dict get $values query] set capturingendregex [dict get $values capturingendregex] @@ -784,7 +806,7 @@ namespace eval punk::console { set runningid [lindex $queue 0] if {$runningid ne $callid} { set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) - update ;#REVIEW - probably a bad idea + update ;#REVIEW - possibly a bad idea after 10 set runningid [lindex $queue 0] ;#jn test } @@ -836,6 +858,17 @@ namespace eval punk::console { } #write before console enableRaw vs after?? #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + + switch -- $passthrough { + auto { + if {[info exists ::env(TMUX)]} { + set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" + } + } + tmux { + set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" + } + } puts -nonewline $output $query;flush $output chan configure $input -blocking 0 @@ -847,8 +880,10 @@ namespace eval punk::console { #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features #------------------ # 1) faster - races? + #first read will read 3 bytes JJJJ $this_handler $input $callid $capturingendregex - $this_handler $input $callid $capturingendregex + #JJJJ + #$this_handler $input $callid $capturingendregex if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } @@ -1047,7 +1082,11 @@ namespace eval punk::console { upvar ::punk::console::ansi_response_tsclock tsclock #endregex should explicitly have a trailing $ - set status [catch {read $chan 1} bytes] + if {[string length $chunks($callid)] == 0} { + set status [catch {read $chan 3} bytes] + } else { + set status [catch {read $chan 1} bytes] + } if { $status != 0 } { # Error on the channel chan event $chan readable {} @@ -1290,7 +1329,7 @@ namespace eval punk::console { "Omit or pass empty string to query current echo state." }] proc echo {args} { - set argd [punk::args::parse $args withid ::punk::console::local::echo] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo] set onoff [dict get $argd values onoff] set is_windows [string equal "windows" $::tcl_platform(platform)] @@ -1343,6 +1382,7 @@ namespace eval punk::console { @opts -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -expected_ms -type integer -default 500 -help\ "Number of ms to wait for response" @values -min 1 -max 1 @@ -1356,11 +1396,12 @@ namespace eval punk::console { lassign [dict values $argd] leaders opts values received set request [dict get $values request] set inoutchannels [dict get $opts -terminal] + set passthrough [dict get $opts -passthrough] set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload set ts_start [clock millis] - set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] + set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels -passthrough $passthrough $request $capturingregex] set ts_end [clock millis] puts stderr $response set out "" @@ -1781,6 +1822,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -multiple 0 -help\ "integer for DEC mode, or name as in the dict: @@ -1793,10 +1835,11 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc dec_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode] lassign [dict values $argd] leaders opts values - set terminal [dict get $opts -console] - set mode [dict get $values mode] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set mode [dict get $values mode] if {[string is integer -strict $mode]} { set m $mode @@ -1810,7 +1853,7 @@ namespace eval punk::console { } set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[?$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex] return $payload } @@ -1838,7 +1881,7 @@ namespace eval punk::console { } #todo - should accept multiple mode nums/names at once proc dec_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1884,7 +1927,7 @@ namespace eval punk::console { }] } proc dec_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1931,6 +1974,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -refresh -type none -help\ "Force a re-test of the mode." -return -type string -choices {dict result} -default result -choicelabels { @@ -1946,9 +1990,10 @@ namespace eval punk::console { }] } proc dec_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode] lassign [dict values $argd] leaders opts values received - set console [dict get $opts -console] + set console [dict get $opts -console] + set passthrough [dict get $opts -passthrough] set num_or_name [dict get $values mode] set do_refresh [dict exists $received -refresh] set return [dict get $opts -return] @@ -1964,21 +2009,23 @@ namespace eval punk::console { } } variable dec_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" if {$do_refresh} { - if {[dict exists $dec_has_mode_cache $console $m]} { - dict unset dec_has_mode_cache $console $m + if {[dict exists $dec_has_mode_cache $cachekey $m]} { + dict unset dec_has_mode_cache $cachekey $m } } - if {![dict exists $dec_has_mode_cache $console $m]} { + if {![dict exists $dec_has_mode_cache $cachekey $m]} { set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[?$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex] #set has_mode [expr {$payload != 0}] #we can use the payload result as the response as non-zero responses evaluate to true set has_mode $payload if {$has_mode ne ""} { - dict set dec_has_mode_cache $console $m $has_mode + dict set dec_has_mode_cache $cachekey $m $has_mode set source "query" } else { #don't cache an empty/failed response - review @@ -1986,7 +2033,7 @@ namespace eval punk::console { set source "failedquery" } } else { - set has_mode [dict get $dec_has_mode_cache $console $m] + set has_mode [dict get $dec_has_mode_cache $cachekey $m] set source "cache" } if {$return eq "dict"} { @@ -2004,6 +2051,7 @@ namespace eval punk::console { {Show table of DEC modes with basic information.} @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -test -type none -help\ "Test current value/support for each mode" -supported -type none -help\ @@ -2013,10 +2061,11 @@ namespace eval punk::console { "Match code or name" }] proc dec_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes] lassign [dict values $argd] leaders opts values received - set terminal [dict get $opts -console] - set do_test [dict exists $received -test] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set do_test [dict exists $received -test] set only_supported [dict exists $received -supported] if {[dict exists $values match]} { set matches [dict get $values match] @@ -2074,7 +2123,7 @@ namespace eval punk::console { set RST "" if {$do_test} { #dec_has_mode can be cached - in which case only 0|3|4 can be relied upon without re-querying - set hasmode_dict [dec_has_mode -console $terminal -return dict $code] + set hasmode_dict [dec_has_mode -console $terminal -passthrough $passthrough -return dict $code] switch -- [dict get $hasmode_dict result] { 0 { if {$only_supported} { @@ -2089,7 +2138,7 @@ namespace eval punk::console { 1 - 2 { if {[dict get $hasmode_dict source] eq "cache"} { #a terminal query is required - set testresult [dec_get_mode -console $terminal $code] + set testresult [dec_get_mode -console $terminal -passthrough $passthrough $code] } else { set testresult [dict get $hasmode_dict result] if {![string is integer -strict $testresult]} { @@ -2135,7 +2184,7 @@ namespace eval punk::console { } else { if {$only_supported} { #dec_has_mode still queries terminal - but is cached if a response was received - if {[dec_has_mode -console $terminal $code] == 0} { + if {[dec_has_mode -console $terminal -passthrough $passthrough $code] == 0} { continue } } @@ -2184,6 +2233,7 @@ namespace eval punk::console { source indicates whether the result came from query or cache." } + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -help\ "integer for ANSI mode, or name as in the dict: @@ -2191,12 +2241,13 @@ namespace eval punk::console { }] } proc ansi_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode] lassign [dict values $argd] leaders opts values received - set console [dict get $opts -console] + set console [dict get $opts -console] set num_or_name [dict get $values mode] - set return [dict get $opts -return] - set do_refresh [dict exists $received -refresh] + set return [dict get $opts -return] + set passthrough [dict get $opts -passthrough] + set do_refresh [dict exists $received -refresh] if {[string is integer -strict $num_or_name]} { set m $num_or_name @@ -2209,20 +2260,22 @@ namespace eval punk::console { } } variable ansi_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" if {$do_refresh} { - if {[dict exists $ansi_has_mode_cache $console $m]} { - dict unset ansi_has_mode_cache $console $m + if {[dict exists $ansi_has_mode_cache $cachekey $m]} { + dict unset ansi_has_mode_cache $cachekey $m } } - if {![dict exists $ansi_has_mode_cache $console $m]} { + if {![dict exists $ansi_has_mode_cache $cachekey $m]} { set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex] #set has_mode [expr {$payload != 0}] set has_mode $payload if {$has_mode ne ""} { - dict set ansi_has_mode_cache $console $m $has_mode + dict set ansi_has_mode_cache $cachekey $m $has_mode set source "query" } else { #don't cache an empty/failed response - review @@ -2230,7 +2283,7 @@ namespace eval punk::console { set source "failedquery" } } else { - set has_mode [dict get $ansi_has_mode_cache $console $m] + set has_mode [dict get $ansi_has_mode_cache $cachekey $m] set source "cache" } if {$return eq "dict"} { @@ -2261,7 +2314,7 @@ namespace eval punk::console { }] } proc ansi_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2308,7 +2361,7 @@ namespace eval punk::console { }] } proc ansi_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2361,6 +2414,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -multiple 0 -help\ "integer for ANSI mode, or name as in the dict: @@ -2373,10 +2427,11 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc ansi_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode] lassign [dict values $argd] leaders opts values - set terminal [dict get $opts -console] - set mode [dict get $values mode] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set mode [dict get $values mode] if {[string is integer -strict $mode]} { set m $mode @@ -2390,7 +2445,7 @@ namespace eval punk::console { } set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex] return $payload } #todo ansi_unset_mode @@ -2404,6 +2459,7 @@ namespace eval punk::console { {Show table of ANSI modes with basic information.} @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -test -type none -help\ "Test current value/support for each mode" -supported -type none -help\ @@ -2413,10 +2469,11 @@ namespace eval punk::console { "Match code or name" }] proc ansi_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes] lassign [dict values $argd] leaders opts values received - set terminal [dict get $opts -console] - set do_test [dict exists $received -test] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set do_test [dict exists $received -test] if {[dict exists $values match]} { set matches [dict get $values match] } else { @@ -2500,7 +2557,7 @@ namespace eval punk::console { set reset_state_colour "" set RST "" if {$do_test} { - set hasmode_dict [ansi_has_mode -console $terminal -return dict $code] + set hasmode_dict [ansi_has_mode -console $terminal -passthrough $passthrough -return dict $code] switch -- [dict get $hasmode_dict result] { 0 { if {$only_supported} { @@ -2515,7 +2572,7 @@ namespace eval punk::console { 1 - 2 { if {[dict get $hasmode_dict source] eq "cache"} { #a terminal query is required - set testresult [ansi_get_mode -console $terminal $code] + set testresult [ansi_get_mode -console $terminal -passthrough $passthrough $code] } else { set testresult [dict get $hasmode_dict result] if {![string is integer -strict $testresult]} { @@ -2561,7 +2618,7 @@ namespace eval punk::console { } else { if {$only_supported} { #ansi_has_mode still queries terminal - but is cached if a response was received - if {[ansi_has_mode -console $terminal $code] == 0} { + if {[ansi_has_mode -console $terminal -passthrough $passthrough $code] == 0} { continue } } @@ -2659,7 +2716,7 @@ namespace eval punk::console { name -type string }] proc dec_request_setting {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_request_setting] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting] lassign [dict values $argd] leaders opts values set console [dict get $opts -console] set name [dict get $values name] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 2a1d9370..883f82de 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns { set a [a+ bold purple] set e [a+ bold yellow] set p [a+ bold white] - set c_nat [a+ web-gray] ;#native - set c_int [a+ web-orange] ;#interps - set c_cor [a+ web-hotpink] ;#coroutines + #set c_nat [a+ web-gray] ;#native + set c_nat [a+ term-silver] ;#native + set c_int [a+ term-orange1] ;#interps + set c_cor [a+ term-hotpink] ;#coroutines set c_ooo [a+ bold cyan] ;#object - set c_ooc [a+ web-aquamarine] ;#class - set c_ooO [a+ web-dodgerblue] ;#privateObject - set c_ooC [a+ web-lightskyblue] ;#privateClass - set c_zst [a+ web-yellow] ;#zlibstreams + #set c_ooc [a+ web-aquamarine] ;#class + set c_ooc [a+ term-aqua] ;#class + #set c_ooO [a+ web-dodgerblue] ;#privateObject + set c_ooO [a+ term-purple-c] ;#privateObject + #set c_ooC [a+ web-lightskyblue] ;#privateClass + set c_ooC [a+ term-cornflowerblue] ;#privateClass + set c_zst [a+ term-yellow] ;#zlibstreams set a1 [a][a+ cyan] foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 { @@ -6629,16 +6633,16 @@ y" {return quirkykeyscript} switch -- $syntax { basic { #rudimentary colourising only - set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] + set argl [punk::ansi::grepstr -return all -highlight term-teal {\{|\}} $argl] - set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. - set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon + set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. + set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon ##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] - set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body] - set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body] - set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body] + set body [punk::ansi::grepstr -return all -highlight term-teal {^(\{)|[^\\](\{+)} $body] + set body [punk::ansi::grepstr -return all -highlight term-teal {[^\\](\}+)} $body] + set body [punk::ansi::grepstr -return all -highlight term-orange {\[|\]} $body] } default { set is_highlighted 0 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm index abef420d..36db6d56 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock { } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span @@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock { } else { if {$span eq "0"} { if {$remaining eq "0"} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" } else { incr remaining -1 @@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock { if {$remaining eq "0"} { #ok for new span value of any or > 0 if {$span ne "any" && $span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span @@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock { incr remaining -1 } } else { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" } } @@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock { $htable add_row [list "$hnum " $h "${width}x${height}" $s] incr hnum } - $htable configure_column 0 -ansibase [a+ web-dimgray] + $htable configure_column 0 -ansibase [a+ term-grey] tcl::dict::set col_header_tables $col $htable set colwidths [$htable column_widths] set icol 0 @@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock { set ecat [tcl::dict::create] set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] + #set ansi [a+ {*}$fc web-black Web-gold] + set ansi [a+ {*}$fc term-black Term-gold1] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { tcl::dict::set ecat $e $val @@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock { set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + set ansi [a+ {*}$fc term-black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val @@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock { set cat [list Li Na K Rb Cs Fr] #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set ansi [a+ {*}$fc term-black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock { set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set ansi [a+ {*}$fc term-black Term-salmon1] + set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + #set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc term-black Term-lightsteelblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock { set cat [list B Si Ge As Sb Te At] #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc black Brightcyan] + set ansi [a+ {*}$fc term-black Term-skyblue1] + set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + #set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc term-black Term-purple-c] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + #set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc term-black Term-plum1] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val @@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + #set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc term-black Term-silver] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4807,7 +4815,7 @@ tcl::namespace::eval textblock { 123456789ABCDEF " -size -type integer\ - -default 15\ + -default 16\ -optional 1\ -range {1 ""} -direction -default horizontal\ @@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock { the colour stripes will be oriented in this direction. " + -noreset -type none @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names @@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock { proc testblock {args} { set argd [punk::args::parse $args withid ::textblock::testblock] - set colour [dict get $argd values colour] - set size [dict get $argd opts -size] + lassign [dict values $argd] leaders opts values received + set colour [dict get $values colour] + set size [dict get $opts -size] + set noreset [dict exists $received -noreset] set rainbow_list [list] lappend rainbow_list {30 47} ;#black White @@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock { set longbows [concat {*}[lrepeat $numsets $rainbow_list]] set rainbow_list [lrange $longbows 0 $size-1] } - if {"noreset" in $colour} { + if {$noreset} { set RST "" } else { set RST [a] @@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock { set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } - if {"noreset" in $colour} { + if {$noreset} { return [textblock::join_basic -ansiresets 0 -- {*}$clist] } else { #return [textblock::join_basic -- {*}$clist] @@ -4935,6 +4946,7 @@ tcl::namespace::eval textblock { for {set r 0} {$r < $size} {incr r} { append block [::join $charsubset ""] \n } + set block [tcl::string::trimright $block \n] if {[llength $colour]} { set block [a+ {*}$colour]$block$RST } @@ -5642,22 +5654,22 @@ tcl::namespace::eval textblock { set headers [list] set blocks [list] - lappend blocks "[textblock::testblock 4 rainbow]" + lappend blocks "[textblock::testblock -size 4 rainbow]" lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend blocks "[textblock::testblock -size 4 rainbow][a]" lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]" lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]" lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]" lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-green]" lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] @@ -5665,13 +5677,13 @@ tcl::namespace::eval textblock { proc pad_example2 {} { set headers [list] set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a]" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-green]" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] @@ -6113,14 +6125,15 @@ tcl::namespace::eval textblock { proc welcome_test {} { package require punk::ansi package require patternpunk - set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]] + set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]] # Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com set table [[textblock::spantest] print] - set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + #set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ term-yellow][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock -size 15 rainbow] set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents] } @@ -7831,7 +7844,7 @@ tcl::namespace::eval textblock { } } proc frame_cache {args} { - set argd [punk::args::parse $args withid ::textblock::frame_cache] + set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache] set action [dict get $argd values action] variable frame_cache set all_values_dict [dict get $argd values] @@ -8350,13 +8363,14 @@ tcl::namespace::eval textblock { set usecache 0 #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] + set cache_key [a+ Term-red term-white]$cache_key[a] } if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { #colourise cache_key to warn if {$actual_contentwidth == 0} { #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] + #set cache_key [a+ Web-steelblue term-black]$cache_key[a] + set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a] } else { #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { @@ -8366,13 +8380,13 @@ tcl::namespace::eval textblock { } if {$actual_contentwidth < $cache_patternwidth} { set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] + set cache_key [a+ Term-orange1 term-black]$cache_key[a] } elseif {$actual_contentwidth == $cache_patternwidth} { #set usecache 1 } else { #actual_contentwidth > pattern set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] + set cache_key [a+ Term-red term-black]$cache_key[a] } } } diff --git a/src/vendormodules_tcl8/Thread-2.8.9.tm b/src/vendormodules_tcl8/Thread-2.8.9.tm deleted file mode 100644 index 45c8b5c6..00000000 Binary files a/src/vendormodules_tcl8/Thread-2.8.9.tm and /dev/null differ diff --git a/src/vendormodules_tcl8/Thread/platform/win32_x86_64_tcl8-2.8.9.tm b/src/vendormodules_tcl8/Thread/platform/win32_x86_64_tcl8-2.8.9.tm deleted file mode 100644 index d50bcf4a..00000000 Binary files a/src/vendormodules_tcl8/Thread/platform/win32_x86_64_tcl8-2.8.9.tm and /dev/null differ diff --git a/src/vendormodules_tcl8/include_modules.config b/src/vendormodules_tcl8/include_modules.config index 36700230..5ab45fa2 100644 --- a/src/vendormodules_tcl8/include_modules.config +++ b/src/vendormodules_tcl8/include_modules.config @@ -1,7 +1,10 @@ + + +# c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread\ +# c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread::platform::win32_x86_64_tcl8 + set local_modules [list\ - c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread\ - c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread::platform::win32_x86_64_tcl8\ ] diff --git a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm index 5e8d1a25..bf00d48a 100644 --- a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm @@ -296,6 +296,27 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } + proc test1_punkargs_any {args} { + set argd [punk::args::parse $args withdef { + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" + @opts -anyopts 0 + -return -default string -type any + -frametype -default \uFFEF -type any + -show_edge -default \uFFEF -type any + -show_seps -default \uFFEF -type any + -join -type none -multiple 1 + -x -default "" -type any + -y -default b -type any + -z -default c -type any + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + @values + }] + return [tcl::dict::get $argd opts] + } + punk::args::define { @id -id ::argparsingtest::test1_punkargs_by_id @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @@ -318,7 +339,6 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } - } proc test1_punkargs_parsecache {args} { set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs_by_id] return [tcl::dict::get $argd opts] diff --git a/src/vfs/_vfscommon.vfs/modules/gridplus-2.12b0.tm b/src/vfs/_vfscommon.vfs/modules/gridplus-2.12b0.tm new file mode 100644 index 00000000..1eb475a1 Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/gridplus-2.12b0.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 7bf4bf7c..9c330abb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu @values -min 0 -max 0 }] proc sgr_cache {args} { - set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache] + set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm index 24f98b6b..1a18006b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm @@ -373,9 +373,9 @@ tcl::namespace::eval ::punk::args::helpers { #Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between # the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems. - set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str] - set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str] - set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {^\{|[^\\](\{+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {[^\\](\}+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-olive} {\[|\]} $str] #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args { variable id_cache_rawdef set defspace "" if {[dict exists $rawdef_cache_about $args]} { - set cinfo [dict get $rawdef_cache_about $args] + set cinfo [dict get $rawdef_cache_about $args] set id [dict get $cinfo -id] set is_dynamic [dict get $cinfo -dynamic] if {[dict exists $cinfo -defspace]} { @@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args { #test the rawdef for @dynamic directive proc rawdef_is_dynamic {rawdef} { #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}] if {$flagged_dynamic} { return true } @@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args { #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" set maxloop 10 ;#failsafe - while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} { + while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} { #looks like a script - haven't gone up far enough? #(e.g patternpunk oo system: >punk . poses -invalidoption) incr call_level -1 @@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args { if {$use_table} { append errmsg \n } else { - if {($returntype in {table tableobject}) && !$has_textblock} { + if {!$has_textblock && ($returntype in {table tableobject})} { append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n } else { append errmsg \n @@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args { variable parse_cache [dict create] proc parse {args} { #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef if {[llength $args] < 3} { #error "punk::args::parse - invalid call. < 3 args" punk::args::parse $args -cache 1 withid ::punk::args::parse @@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args { } } #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals + #set values $opts_and_vals #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + #set tailtype [lindex $values 0] ;#withid|withdef + #set tailargs [lrange $values 1 end] + set tailtype [lpop opts_and_vals 0] - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} #Default the -errorstyle to standard # (slow on unhappy path - but probably clearest for playing with new APIs interactively) @@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args { } switch -- $tailtype { withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] + #JJJ + #set id [lindex $opts_and_vals 0] + set deflist [raw_def [lindex $opts_and_vals 0]] if {[llength $deflist] == 0} { + if {[llength $opts_and_vals] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } error "punk::args::parse - no such id: $id" } } withdef { - set deflist $tailargs + set deflist $opts_and_vals if {[llength $deflist] < 1} { error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" } default { error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" @@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args { proc get_dict {deflist rawargs args} { #see arg_error regarding considerations around unhappy-path performance - if {![punk::args::lib::string_is_dict $args]} { - error "punk::args::get_dict args must be a dict of option value pairs" - } set defaults [dict create\ -form *\ ] + #if {![punk::args::lib::string_is_dict $args]} { + # error "punk::args::get_dict args must be a dict of option value pairs" + #} set proc_opts [dict merge $defaults $args] dict for {k v} $proc_opts { switch -- $k { @@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args { #define will either return a permanently cached argspecs (-dynamic 0) - or # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + #argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info # ----------------------------------------------- # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars + #tcl::dict::with argspecs {} ;#turn keys into vars #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names # ----------------------------------------------- + #we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with + set FORMS [dict get $argspecs FORMS] + set form_names [dict get $argspecs form_names] + + set opt_form [dict get $proc_opts -form] if {$opt_form eq "*"} { set selected_forms $form_names @@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args { #todo - handle multiple fids? set fid [lindex $selected_forms 0] set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + # formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED + # LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED + # LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES + # OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS + # VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS + # VAL_CHECKS_DEFAULTS FORMDISPLAY + + #tcl::dict::with formdict {} + ##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + #individual var extraction is faster than 'dict with' - even though we need nearly every key + set ARG_INFO [dict get $formdict ARG_INFO] + set ARG_CHECKS [dict get $formdict ARG_CHECKS] + + set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS] + set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED] + set LEADER_NAMES [dict get $formdict LEADER_NAMES] + set LEADER_MIN [dict get $formdict LEADER_MIN] + set LEADER_MAX [dict get $formdict LEADER_MAX] + set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO] + set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED] + set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS] + set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS] + + set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS] + set OPT_REQUIRED [dict get $formdict OPT_REQUIRED] + set OPT_NAMES [dict get $formdict OPT_NAMES] + set OPT_ANY [dict get $formdict OPT_ANY] + #set OPT_MIN [dict get $formdict OPT_MIN] + set OPT_MAX [dict get $formdict OPT_MAX] + #set OPT_SOLOS [dict get $formdict OPT_SOLOS] + set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] + set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] + #set OPT_GROUPS [dict get $formdict OPT_GROUPS] + + set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS] + set VAL_REQUIRED [dict get $formdict VAL_REQUIRED] + set VAL_NAMES [dict get $formdict VAL_NAMES] + set VAL_MIN [dict get $formdict VAL_MIN] + set VAL_MAX [dict get $formdict VAL_MAX] + set VAL_UNNAMED [dict get $formdict VAL_UNNAMED] + set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS] + set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS] + + set FORMDISPLAY [dict get $formdict FORMDISPLAY] + if {$VAL_MIN eq ""} { set valmin 0 #set VAL_MIN 0 @@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args { # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) # e.g -types {a ?xxx?} #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] set clause_length 0 - foreach t $typelist { + #for each t in typelist + foreach t [dict get $ARG_INFO $v -type] { if {![string match {\?*\?} $t]} { incr clause_length } @@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args { #REVIEW - what about optional members in leaders e.g -type {int ?double?} set named_leader_args_max 0 foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] + incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]] } #set id [dict get $argspecs id] @@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args { #} set can_have_leaders 1 ;#default assumption - if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} { + if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} { set can_have_leaders 0 } @@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args { if {$OPT_MAX ne "0"} { foreach t $leader_type { set raw [lindex $rawargs $tentative_idx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set flagname $raw if {[string match --* $raw]} { @@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args { # and only for the last defined leader. This should be done in the definition parsing - not here. foreach t $leader_type { set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { + if {[string match -* $raw] && [string match {\?*\?} $t]} { #review - limitation of optional leaders is they can't be same value as any defined flags/opts set matchopt [::tcl::prefix::match -error {} $all_opts $raw] @@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args { set leadermin $LEADER_MIN } if {$LEADER_MAX eq ""} { - if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} { + if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} { set leadermax 0 } else { set leadermax -1 @@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args { } if {$VAL_MAX eq ""} { - if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} { + if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} { set valmax 0 } else { set valmax -1 @@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args { #assert leadermax leadermin are numeric #assert - remaining_rawargs has been reduced by leading positionals - set opts [dict create] ;#don't set to OPT_DEFAULTS here + #beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true) + #set opts [dict create] ;#don't set to OPT_DEFAULTS here + set opts [list] + set leaders [list] set arglist {} @@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args { break } set a [lindex $remaining_rawargs $i] - switch -glob -- $a { - -- { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } - --* { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= 2} { + #only allow longopt-style = for double leading dash longopts + #--*= 2} { + if {$eposn > 2 && [string match --* $a]} { #only allow longopt-style = for double leading dash longopts #--*=>>>==== $opts" + #puts ">>>>====opts: $opts" set seen_pks [list] #treating opts as list for this loop. foreach optset $OPT_NAMES { @@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $leadername -optional]} { puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?" incr ldridx -1 set leadername_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$leadername ni $leadernames_received} { #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." @@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could use break? continue } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { + if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset leaders_dict $leadername @@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args { set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { + if {$consumed == 0} { + if {[tcl::dict::get $argstate $valname -optional]} { #error 333 puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" incr validx -1 set valname_multiple "" incr nameidx continue - } - } else { - #required named arg - if {$consumed == 0} { + } else { + #required named arg if {$valname ni $valnames_received} { #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." @@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args { #review - always trailing - could break? continue } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { + if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} { #remove the name with empty-string default we used to establish fixed order of names #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. dict unset values_dict $vname @@ -8923,6 +8963,9 @@ tcl::namespace::eval punk::args { #puts " >>>>>>> ---lookup_optset :$lookup_optset" #puts "---argstate:$argstate" #JJJ argname_or_ident; ident example: -increasing|-SORTOPTION + + #review - ensure all possible keys present in thisarg_keys + tcl::dict::for {argname_or_ident value_group} $opts_and_values { # #parsekey: key used in resulting leaders opts values dictionaries @@ -8972,21 +9015,24 @@ tcl::namespace::eval punk::args { #an example argname_or_compound for the above might be: -path|--filename # where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] + #using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict + set typelist [tcl::dict::get $thisarg -type] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + #set validationtransform [tcl::dict::get $thisarg -validationtransform] + set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { set defaultval [tcl::dict::get $thisarg -default] } - set typelist [tcl::dict::get $thisarg -type] set clause_size [llength $typelist] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set validationtransform [tcl::dict::get $thisarg -validationtransform] #JJJJ @@ -9076,7 +9122,7 @@ tcl::namespace::eval punk::args { set vlist_typelist_validate [list] #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$parsekey in $receivednames && $has_choices} { + if {$has_choices && $parsekey in $receivednames} { #-choices must also work with -multiple #todo -choicelabels set choiceprefix [tcl::dict::get $thisarg -choiceprefix] @@ -9333,13 +9379,13 @@ tcl::namespace::eval punk::args { set vlist [list] set vlist_check_validate [list] } else { - if {[llength $vlist] && $has_default} { + if {$has_default && [llength $vlist]} { #defaultval here is a value for the entire clause. (clause usually length 1) #J2 #set vlist_validate [list] #set vlist_check_validate [list] - set tp [dict get $thisarg -type] - set clause_size [llength $tp] + #set tp [dict get $thisarg -type] + set clause_size [llength $typelist] foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist { #JJJJ #REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation? @@ -9388,7 +9434,7 @@ tcl::namespace::eval punk::args { #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { + if {!$is_allow_ansi && [llength $vlist]} { #allow_ansi 0 package require punk::ansi #do not run ta::detect on a list @@ -9452,7 +9498,7 @@ tcl::namespace::eval punk::args { if {$is_strip_ansi} { set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { + if {$is_multiple} { switch -- [tcl::dict::get $thisarg -ARGTYPE] { leader { tcl::dict::set leaders_dict $argname_or_ident $stripped_list diff --git a/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm index 33b00209..fe83d038 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm @@ -116,13 +116,13 @@ tcl::namespace::eval punk::blockletter { set default_frametype {vl \u00a0 hl \u00a0 tlc \u00a0 trc \u00a0 blc \u00a0 brc \u00a0} # colours in order for T c l T k - set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange] + #set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange] set logo_letter_colours [list Red Green Blue Purple Yellow] punk::args::define [tstr -return string { @id -id ::punk::blockletter::logo -frametype -default {${$default_frametype}} - -outlinecolour -default "web-white" + -outlinecolour -default "term-white" -backgroundcolour -default {} -help "e.g Web-white This argument is the name as accepted by punk::ansi::a+" @values -min 0 -max 0 @@ -220,8 +220,8 @@ tcl::namespace::eval punk::blockletter { punk::args::define [tstr -return string { @id -id ::punk::blockletter::text - -bgcolour -default "Web-red" - -bordercolour -default "web-white" + -bgcolour -default "Term-red" + -bordercolour -default "term-white" -frametype -default {${$default_frametype}} @values -min 1 -max 1 str -help "Text to convert to blockletters @@ -286,9 +286,9 @@ tcl::namespace::eval punk::blockletter::lib { @id -id ::punk::blockletter::lib::block -height -default 2 -width -default 4 - -frametype -default {${$::punk::blockletter::default_frametype}} - -bgcolour -default "Web-red" - -bordercolour -default "web-white" + -frametype -default {${$::punk::blockletter::default_frametype}} + -bgcolour -default "Term-red" + -bordercolour -default "term-white" @values -min 0 -max 0 }] proc block {args} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm index ff5c2904..c64720d2 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm @@ -702,6 +702,27 @@ namespace eval punk::console { -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" + -passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels { + none\ + { ANSI sent without any passthrough wrapping. + A terminal multiplexer such as tmux,screen,zellij may + not pass the request through to the underlying terminal(s) + This is the recommended/normal value for the option.} + tmux\ + { Wrap ANSI sequence with tmux passthrough sequence. + \x1bPtmux\;\x1b\\ + Note that a tmux session could be connected to multiple + terminals (perhaps of different types) - in which case multiple + responses may be received in a non-deterministic order. + Passthrough should generally be avoided except for debug/test + purposes. + } + auto\ + { Use existence of ::env(TMUX) to detect tmux and + send tmux passthrough sequence. + Not recommended except for debug/test purposes. + } + } -expected_ms -default 300 -type integer -help\ "Expected number of ms for response from terminal. 100ms is usually plenty for a local terminal and a @@ -731,6 +752,7 @@ namespace eval punk::console { set expected [dict get $opts -expected_ms] set ignoreok [dict get $opts -ignoreok] set returntype [dict get $opts -return] + set passthrough [dict get $opts -passthrough] set query [dict get $values query] set capturingendregex [dict get $values capturingendregex] @@ -784,7 +806,7 @@ namespace eval punk::console { set runningid [lindex $queue 0] if {$runningid ne $callid} { set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) - update ;#REVIEW - probably a bad idea + update ;#REVIEW - possibly a bad idea after 10 set runningid [lindex $queue 0] ;#jn test } @@ -836,6 +858,17 @@ namespace eval punk::console { } #write before console enableRaw vs after?? #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + + switch -- $passthrough { + auto { + if {[info exists ::env(TMUX)]} { + set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" + } + } + tmux { + set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" + } + } puts -nonewline $output $query;flush $output chan configure $input -blocking 0 @@ -847,8 +880,10 @@ namespace eval punk::console { #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features #------------------ # 1) faster - races? + #first read will read 3 bytes JJJJ $this_handler $input $callid $capturingendregex - $this_handler $input $callid $capturingendregex + #JJJJ + #$this_handler $input $callid $capturingendregex if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } @@ -1047,7 +1082,11 @@ namespace eval punk::console { upvar ::punk::console::ansi_response_tsclock tsclock #endregex should explicitly have a trailing $ - set status [catch {read $chan 1} bytes] + if {[string length $chunks($callid)] == 0} { + set status [catch {read $chan 3} bytes] + } else { + set status [catch {read $chan 1} bytes] + } if { $status != 0 } { # Error on the channel chan event $chan readable {} @@ -1290,7 +1329,7 @@ namespace eval punk::console { "Omit or pass empty string to query current echo state." }] proc echo {args} { - set argd [punk::args::parse $args withid ::punk::console::local::echo] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo] set onoff [dict get $argd values onoff] set is_windows [string equal "windows" $::tcl_platform(platform)] @@ -1343,6 +1382,7 @@ namespace eval punk::console { @opts -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -expected_ms -type integer -default 500 -help\ "Number of ms to wait for response" @values -min 1 -max 1 @@ -1356,11 +1396,12 @@ namespace eval punk::console { lassign [dict values $argd] leaders opts values received set request [dict get $values request] set inoutchannels [dict get $opts -terminal] + set passthrough [dict get $opts -passthrough] set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload set ts_start [clock millis] - set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] + set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels -passthrough $passthrough $request $capturingregex] set ts_end [clock millis] puts stderr $response set out "" @@ -1781,6 +1822,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -multiple 0 -help\ "integer for DEC mode, or name as in the dict: @@ -1793,10 +1835,11 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc dec_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode] lassign [dict values $argd] leaders opts values - set terminal [dict get $opts -console] - set mode [dict get $values mode] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set mode [dict get $values mode] if {[string is integer -strict $mode]} { set m $mode @@ -1810,7 +1853,7 @@ namespace eval punk::console { } set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[?$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex] return $payload } @@ -1838,7 +1881,7 @@ namespace eval punk::console { } #todo - should accept multiple mode nums/names at once proc dec_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1884,7 +1927,7 @@ namespace eval punk::console { }] } proc dec_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -1931,6 +1974,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -refresh -type none -help\ "Force a re-test of the mode." -return -type string -choices {dict result} -default result -choicelabels { @@ -1946,9 +1990,10 @@ namespace eval punk::console { }] } proc dec_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode] lassign [dict values $argd] leaders opts values received - set console [dict get $opts -console] + set console [dict get $opts -console] + set passthrough [dict get $opts -passthrough] set num_or_name [dict get $values mode] set do_refresh [dict exists $received -refresh] set return [dict get $opts -return] @@ -1964,21 +2009,23 @@ namespace eval punk::console { } } variable dec_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" if {$do_refresh} { - if {[dict exists $dec_has_mode_cache $console $m]} { - dict unset dec_has_mode_cache $console $m + if {[dict exists $dec_has_mode_cache $cachekey $m]} { + dict unset dec_has_mode_cache $cachekey $m } } - if {![dict exists $dec_has_mode_cache $console $m]} { + if {![dict exists $dec_has_mode_cache $cachekey $m]} { set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[?$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex] #set has_mode [expr {$payload != 0}] #we can use the payload result as the response as non-zero responses evaluate to true set has_mode $payload if {$has_mode ne ""} { - dict set dec_has_mode_cache $console $m $has_mode + dict set dec_has_mode_cache $cachekey $m $has_mode set source "query" } else { #don't cache an empty/failed response - review @@ -1986,7 +2033,7 @@ namespace eval punk::console { set source "failedquery" } } else { - set has_mode [dict get $dec_has_mode_cache $console $m] + set has_mode [dict get $dec_has_mode_cache $cachekey $m] set source "cache" } if {$return eq "dict"} { @@ -2004,6 +2051,7 @@ namespace eval punk::console { {Show table of DEC modes with basic information.} @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -test -type none -help\ "Test current value/support for each mode" -supported -type none -help\ @@ -2013,10 +2061,11 @@ namespace eval punk::console { "Match code or name" }] proc dec_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes] lassign [dict values $argd] leaders opts values received - set terminal [dict get $opts -console] - set do_test [dict exists $received -test] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set do_test [dict exists $received -test] set only_supported [dict exists $received -supported] if {[dict exists $values match]} { set matches [dict get $values match] @@ -2074,7 +2123,7 @@ namespace eval punk::console { set RST "" if {$do_test} { #dec_has_mode can be cached - in which case only 0|3|4 can be relied upon without re-querying - set hasmode_dict [dec_has_mode -console $terminal -return dict $code] + set hasmode_dict [dec_has_mode -console $terminal -passthrough $passthrough -return dict $code] switch -- [dict get $hasmode_dict result] { 0 { if {$only_supported} { @@ -2089,7 +2138,7 @@ namespace eval punk::console { 1 - 2 { if {[dict get $hasmode_dict source] eq "cache"} { #a terminal query is required - set testresult [dec_get_mode -console $terminal $code] + set testresult [dec_get_mode -console $terminal -passthrough $passthrough $code] } else { set testresult [dict get $hasmode_dict result] if {![string is integer -strict $testresult]} { @@ -2135,7 +2184,7 @@ namespace eval punk::console { } else { if {$only_supported} { #dec_has_mode still queries terminal - but is cached if a response was received - if {[dec_has_mode -console $terminal $code] == 0} { + if {[dec_has_mode -console $terminal -passthrough $passthrough $code] == 0} { continue } } @@ -2184,6 +2233,7 @@ namespace eval punk::console { source indicates whether the result came from query or cache." } + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -help\ "integer for ANSI mode, or name as in the dict: @@ -2191,12 +2241,13 @@ namespace eval punk::console { }] } proc ansi_has_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode] lassign [dict values $argd] leaders opts values received - set console [dict get $opts -console] + set console [dict get $opts -console] set num_or_name [dict get $values mode] - set return [dict get $opts -return] - set do_refresh [dict exists $received -refresh] + set return [dict get $opts -return] + set passthrough [dict get $opts -passthrough] + set do_refresh [dict exists $received -refresh] if {[string is integer -strict $num_or_name]} { set m $num_or_name @@ -2209,20 +2260,22 @@ namespace eval punk::console { } } variable ansi_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" if {$do_refresh} { - if {[dict exists $ansi_has_mode_cache $console $m]} { - dict unset ansi_has_mode_cache $console $m + if {[dict exists $ansi_has_mode_cache $cachekey $m]} { + dict unset ansi_has_mode_cache $cachekey $m } } - if {![dict exists $ansi_has_mode_cache $console $m]} { + if {![dict exists $ansi_has_mode_cache $cachekey $m]} { set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex] #set has_mode [expr {$payload != 0}] set has_mode $payload if {$has_mode ne ""} { - dict set ansi_has_mode_cache $console $m $has_mode + dict set ansi_has_mode_cache $cachekey $m $has_mode set source "query" } else { #don't cache an empty/failed response - review @@ -2230,7 +2283,7 @@ namespace eval punk::console { set source "failedquery" } } else { - set has_mode [dict get $ansi_has_mode_cache $console $m] + set has_mode [dict get $ansi_has_mode_cache $cachekey $m] set source "cache" } if {$return eq "dict"} { @@ -2261,7 +2314,7 @@ namespace eval punk::console { }] } proc ansi_set_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2308,7 +2361,7 @@ namespace eval punk::console { }] } proc ansi_unset_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode] lassign [dict values $argd] leaders opts values set terminal [dict get $opts -console] set modes [dict get $values mode] ;#multiple @@ -2361,6 +2414,7 @@ namespace eval punk::console { } @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} @values -min 1 -max 1 mode -type {int|string} -multiple 0 -help\ "integer for ANSI mode, or name as in the dict: @@ -2373,10 +2427,11 @@ namespace eval punk::console { # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc ansi_get_mode {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode] lassign [dict values $argd] leaders opts values - set terminal [dict get $opts -console] - set mode [dict get $values mode] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set mode [dict get $values mode] if {[string is integer -strict $mode]} { set m $mode @@ -2390,7 +2445,7 @@ namespace eval punk::console { } set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[$m\$p" - set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex] + set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex] return $payload } #todo ansi_unset_mode @@ -2404,6 +2459,7 @@ namespace eval punk::console { {Show table of ANSI modes with basic information.} @opts -console -type list -minsize 2 -default {stdin stdout} + ${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} -test -type none -help\ "Test current value/support for each mode" -supported -type none -help\ @@ -2413,10 +2469,11 @@ namespace eval punk::console { "Match code or name" }] proc ansi_modes {args} { - set argd [punk::args::parse $args withid ::punk::console::ansi_modes] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes] lassign [dict values $argd] leaders opts values received - set terminal [dict get $opts -console] - set do_test [dict exists $received -test] + set terminal [dict get $opts -console] + set passthrough [dict get $opts -passthrough] + set do_test [dict exists $received -test] if {[dict exists $values match]} { set matches [dict get $values match] } else { @@ -2500,7 +2557,7 @@ namespace eval punk::console { set reset_state_colour "" set RST "" if {$do_test} { - set hasmode_dict [ansi_has_mode -console $terminal -return dict $code] + set hasmode_dict [ansi_has_mode -console $terminal -passthrough $passthrough -return dict $code] switch -- [dict get $hasmode_dict result] { 0 { if {$only_supported} { @@ -2515,7 +2572,7 @@ namespace eval punk::console { 1 - 2 { if {[dict get $hasmode_dict source] eq "cache"} { #a terminal query is required - set testresult [ansi_get_mode -console $terminal $code] + set testresult [ansi_get_mode -console $terminal -passthrough $passthrough $code] } else { set testresult [dict get $hasmode_dict result] if {![string is integer -strict $testresult]} { @@ -2561,7 +2618,7 @@ namespace eval punk::console { } else { if {$only_supported} { #ansi_has_mode still queries terminal - but is cached if a response was received - if {[ansi_has_mode -console $terminal $code] == 0} { + if {[ansi_has_mode -console $terminal -passthrough $passthrough $code] == 0} { continue } } @@ -2659,7 +2716,7 @@ namespace eval punk::console { name -type string }] proc dec_request_setting {args} { - set argd [punk::args::parse $args withid ::punk::console::dec_request_setting] + set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting] lassign [dict values $argd] leaders opts values set console [dict get $opts -console] set name [dict get $values name] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm index 82672d11..aa30e454 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm @@ -2750,7 +2750,7 @@ tcl::namespace::eval punk::imap4 { @values -min 0 -max 0 }] proc NOOP {args} { - set argd [punk::args::parse $args withid ::punk::imap4::NOOP] + set argd [punk::args::parse $args -cache 1 withid ::punk::imap4::NOOP] set chan [dict get $argd leaders chan] punk::imap4::proto::simplecmd $chan NOOP } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm index ae61d932..e5033e18 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm @@ -1363,7 +1363,7 @@ tcl::namespace::eval punk::netbox { @values -min 0 -max 0 }] proc _datafile {args} { - set argd [punk::args::parse $args withid ::punk::netbox::_datafile] + set argd [punk::args::parse $args -cache 1 withid ::punk::netbox::_datafile] lassign [dict values $argd] leaders opts values received set be_quiet [dict exists $received -quiet] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 2a1d9370..883f82de 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns { set a [a+ bold purple] set e [a+ bold yellow] set p [a+ bold white] - set c_nat [a+ web-gray] ;#native - set c_int [a+ web-orange] ;#interps - set c_cor [a+ web-hotpink] ;#coroutines + #set c_nat [a+ web-gray] ;#native + set c_nat [a+ term-silver] ;#native + set c_int [a+ term-orange1] ;#interps + set c_cor [a+ term-hotpink] ;#coroutines set c_ooo [a+ bold cyan] ;#object - set c_ooc [a+ web-aquamarine] ;#class - set c_ooO [a+ web-dodgerblue] ;#privateObject - set c_ooC [a+ web-lightskyblue] ;#privateClass - set c_zst [a+ web-yellow] ;#zlibstreams + #set c_ooc [a+ web-aquamarine] ;#class + set c_ooc [a+ term-aqua] ;#class + #set c_ooO [a+ web-dodgerblue] ;#privateObject + set c_ooO [a+ term-purple-c] ;#privateObject + #set c_ooC [a+ web-lightskyblue] ;#privateClass + set c_ooC [a+ term-cornflowerblue] ;#privateClass + set c_zst [a+ term-yellow] ;#zlibstreams set a1 [a][a+ cyan] foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 { @@ -6629,16 +6633,16 @@ y" {return quirkykeyscript} switch -- $syntax { basic { #rudimentary colourising only - set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] + set argl [punk::ansi::grepstr -return all -highlight term-teal {\{|\}} $argl] - set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. - set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon + set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. + set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon ##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] - set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body] - set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body] - set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body] + set body [punk::ansi::grepstr -return all -highlight term-teal {^(\{)|[^\\](\{+)} $body] + set body [punk::ansi::grepstr -return all -highlight term-teal {[^\\](\}+)} $body] + set body [punk::ansi::grepstr -return all -highlight term-orange {\[|\]} $body] } default { set is_highlighted 0 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm index cb5721d0..b1b4df80 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm @@ -240,7 +240,7 @@ tcl::namespace::eval punk::sixel { variable device_attribute_cache set device_attribute_cache [dict create] proc can_sixel {args} { - set argd [punk::args::parse $args withid ::punk::sixel::can_sixel] + set argd [punk::args::parse $args -cache 1 withid ::punk::sixel::can_sixel] lassign [dict values $argd] leaders opts values received set terminal [dict get $values terminal] diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm index abef420d..36db6d56 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock { } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span @@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock { } else { if {$span eq "0"} { if {$remaining eq "0"} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" } else { incr remaining -1 @@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock { if {$remaining eq "0"} { #ok for new span value of any or > 0 if {$span ne "any" && $span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span @@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock { incr remaining -1 } } else { - lset spanview $sidx [a+ web-red]$span[a] + lset spanview $sidx [a+ term-red]$span[a] error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" } } @@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock { $htable add_row [list "$hnum " $h "${width}x${height}" $s] incr hnum } - $htable configure_column 0 -ansibase [a+ web-dimgray] + $htable configure_column 0 -ansibase [a+ term-grey] tcl::dict::set col_header_tables $col $htable set colwidths [$htable column_widths] set icol 0 @@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock { set ecat [tcl::dict::create] set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] + #set ansi [a+ {*}$fc web-black Web-gold] + set ansi [a+ {*}$fc term-black Term-gold1] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { tcl::dict::set ecat $e $val @@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock { set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + set ansi [a+ {*}$fc term-black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val @@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock { set cat [list Li Na K Rb Cs Fr] #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set ansi [a+ {*}$fc term-black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock { set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set ansi [a+ {*}$fc term-black Term-salmon1] + set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + #set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc term-black Term-lightsteelblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock { set cat [list B Si Ge As Sb Te At] #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc black Brightcyan] + set ansi [a+ {*}$fc term-black Term-skyblue1] + set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + #set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc term-black Term-purple-c] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + #set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc term-black Term-plum1] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val @@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + #set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc term-black Term-silver] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4807,7 +4815,7 @@ tcl::namespace::eval textblock { 123456789ABCDEF " -size -type integer\ - -default 15\ + -default 16\ -optional 1\ -range {1 ""} -direction -default horizontal\ @@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock { the colour stripes will be oriented in this direction. " + -noreset -type none @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names @@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock { proc testblock {args} { set argd [punk::args::parse $args withid ::textblock::testblock] - set colour [dict get $argd values colour] - set size [dict get $argd opts -size] + lassign [dict values $argd] leaders opts values received + set colour [dict get $values colour] + set size [dict get $opts -size] + set noreset [dict exists $received -noreset] set rainbow_list [list] lappend rainbow_list {30 47} ;#black White @@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock { set longbows [concat {*}[lrepeat $numsets $rainbow_list]] set rainbow_list [lrange $longbows 0 $size-1] } - if {"noreset" in $colour} { + if {$noreset} { set RST "" } else { set RST [a] @@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock { set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } - if {"noreset" in $colour} { + if {$noreset} { return [textblock::join_basic -ansiresets 0 -- {*}$clist] } else { #return [textblock::join_basic -- {*}$clist] @@ -4935,6 +4946,7 @@ tcl::namespace::eval textblock { for {set r 0} {$r < $size} {incr r} { append block [::join $charsubset ""] \n } + set block [tcl::string::trimright $block \n] if {[llength $colour]} { set block [a+ {*}$colour]$block$RST } @@ -5642,22 +5654,22 @@ tcl::namespace::eval textblock { set headers [list] set blocks [list] - lappend blocks "[textblock::testblock 4 rainbow]" + lappend blocks "[textblock::testblock -size 4 rainbow]" lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend blocks "[textblock::testblock -size 4 rainbow][a]" lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]" lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]" lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]" lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-green]" lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] @@ -5665,13 +5677,13 @@ tcl::namespace::eval textblock { proc pad_example2 {} { set headers [list] set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a]" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-green]" lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] @@ -6113,14 +6125,15 @@ tcl::namespace::eval textblock { proc welcome_test {} { package require punk::ansi package require patternpunk - set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]] + set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]] # Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com set table [[textblock::spantest] print] - set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + #set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ term-yellow][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock -size 15 rainbow] set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents] } @@ -7831,7 +7844,7 @@ tcl::namespace::eval textblock { } } proc frame_cache {args} { - set argd [punk::args::parse $args withid ::textblock::frame_cache] + set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache] set action [dict get $argd values action] variable frame_cache set all_values_dict [dict get $argd values] @@ -8350,13 +8363,14 @@ tcl::namespace::eval textblock { set usecache 0 #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] + set cache_key [a+ Term-red term-white]$cache_key[a] } if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { #colourise cache_key to warn if {$actual_contentwidth == 0} { #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] + #set cache_key [a+ Web-steelblue term-black]$cache_key[a] + set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a] } else { #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { @@ -8366,13 +8380,13 @@ tcl::namespace::eval textblock { } if {$actual_contentwidth < $cache_patternwidth} { set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] + set cache_key [a+ Term-orange1 term-black]$cache_key[a] } elseif {$actual_contentwidth == $cache_patternwidth} { #set usecache 1 } else { #actual_contentwidth > pattern set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] + set cache_key [a+ Term-red term-black]$cache_key[a] } } } diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/jpegtclstub.lib b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/jpegtclstub.lib new file mode 100644 index 00000000..e5198298 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/jpegtclstub.lib differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pkgIndex.tcl new file mode 100644 index 00000000..f1a9b1e2 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pkgIndex.tcl @@ -0,0 +1,76 @@ +# -*- tcl -*- Tcl package index file +# --- --- --- Handcrafted, final generation by configure. + +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded tkimg 2.1.0 [list load [file join $dir tcl9tkimg210.dll]] +} else { + package ifneeded tkimg 2.1.0 [list load [file join $dir tkimg210t.dll]] +} +# Compatibility hack. When asking for the old name of the package +# then load all format handlers and base libraries provided by tkImg. +# Actually we ask only for the format handlers, the required base +# packages will be loaded automatically through the usual package +# mechanism. + +# When reading images without specifying it's format (option -format), +# the available formats are tried in reversed order as listed here. +# Therefore file formats with some "magic" identifier, which can be +# recognized safely, should be added at the end of this list. + +package ifneeded Img 2.1.0 { + package require img::window + package require img::tga + package require img::ico + package require img::pcx + package require img::sgi + package require img::sun + package require img::xbm + package require img::xpm + package require img::jpeg + package require img::png + package require img::tiff + package require img::bmp + package require img::ppm + package require img::pixmap + package provide Img 2.1.0 +} + +package ifneeded img::bmp 2.1.0 [list load [file join $dir tcl9tkimgbmp210.dll]] +package ifneeded img::dted 2.1.0 [list load [file join $dir tcl9tkimgdted210.dll]] +package ifneeded img::flir 2.1.0 [list load [file join $dir tcl9tkimgflir210.dll]] +package ifneeded img::gif 2.1.0 [list load [file join $dir tcl9tkimggif210.dll]] +package ifneeded img::ico 2.1.0 [list load [file join $dir tcl9tkimgico210.dll]] +if {[package vsatisfies [package provide Tcl] 9.0]} { +package ifneeded jpegtcl 9.6.0 [list load [file join $dir tcl9jpegtcl960.dll]] +} else { +package ifneeded jpegtcl 9.6.0 [list load [file join $dir jpegtcl960t.dll]] +} +package ifneeded img::jpeg 2.1.0 [list load [file join $dir tcl9tkimgjpeg210.dll]] +if {[package vsatisfies [package provide Tcl] 9.0]} { +package ifneeded zlibtcl 1.3.1 [list load [file join $dir tcl9zlibtcl131.dll]] +} else { +package ifneeded zlibtcl 1.3.1 [list load [file join $dir zlibtcl131t.dll]] +} +if {[package vsatisfies [package provide Tcl] 9.0]} { +package ifneeded pngtcl 1.6.48 [list load [file join $dir tcl9pngtcl1648.dll]] +} else { +package ifneeded pngtcl 1.6.48 [list load [file join $dir pngtcl1648t.dll]] +} +if {[package vsatisfies [package provide Tcl] 9.0]} { +package ifneeded tifftcl 4.7.0 [list load [file join $dir tcl9tifftcl470.dll]] +} else { +package ifneeded tifftcl 4.7.0 [list load [file join $dir tifftcl470t.dll]] +} +package ifneeded img::pcx 2.1.0 [list load [file join $dir tcl9tkimgpcx210.dll]] +package ifneeded img::pixmap 2.1.0 [list load [file join $dir tcl9tkimgpixmap210.dll]] +package ifneeded img::png 2.1.0 [list load [file join $dir tcl9tkimgpng210.dll]] +package ifneeded img::ppm 2.1.0 [list load [file join $dir tcl9tkimgppm210.dll]] +package ifneeded img::ps 2.1.0 [list load [file join $dir tcl9tkimgps210.dll]] +package ifneeded img::raw 2.1.0 [list load [file join $dir tcl9tkimgraw210.dll]] +package ifneeded img::sgi 2.1.0 [list load [file join $dir tcl9tkimgsgi210.dll]] +package ifneeded img::sun 2.1.0 [list load [file join $dir tcl9tkimgsun210.dll]] +package ifneeded img::tga 2.1.0 [list load [file join $dir tcl9tkimgtga210.dll]] +package ifneeded img::tiff 2.1.0 [list load [file join $dir tcl9tkimgtiff210.dll]] +package ifneeded img::window 2.1.0 [list load [file join $dir tcl9tkimgwindow210.dll]] +package ifneeded img::xbm 2.1.0 [list load [file join $dir tcl9tkimgxbm210.dll]] +package ifneeded img::xpm 2.1.0 [list load [file join $dir tcl9tkimgxpm210.dll]] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pngtclstub.lib b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pngtclstub.lib new file mode 100644 index 00000000..d4dc5b29 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pngtclstub.lib differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9jpegtcl960.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9jpegtcl960.dll new file mode 100644 index 00000000..31c6b51b Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9jpegtcl960.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9pngtcl1648.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9pngtcl1648.dll new file mode 100644 index 00000000..f46f8f9b Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9pngtcl1648.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tifftcl470.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tifftcl470.dll new file mode 100644 index 00000000..0a3333f2 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tifftcl470.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimg210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimg210.dll new file mode 100644 index 00000000..17b78eac Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimg210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgbmp210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgbmp210.dll new file mode 100644 index 00000000..24ee85d6 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgbmp210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgdted210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgdted210.dll new file mode 100644 index 00000000..170970a5 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgdted210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgflir210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgflir210.dll new file mode 100644 index 00000000..a9e56bc1 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgflir210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimggif210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimggif210.dll new file mode 100644 index 00000000..372b1a68 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimggif210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgico210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgico210.dll new file mode 100644 index 00000000..399ce0a4 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgico210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgjpeg210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgjpeg210.dll new file mode 100644 index 00000000..a7c935e6 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgjpeg210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpcx210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpcx210.dll new file mode 100644 index 00000000..f229e9c7 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpcx210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpixmap210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpixmap210.dll new file mode 100644 index 00000000..5081e12a Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpixmap210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpng210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpng210.dll new file mode 100644 index 00000000..565f4d79 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpng210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgppm210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgppm210.dll new file mode 100644 index 00000000..a2e17f33 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgppm210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgps210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgps210.dll new file mode 100644 index 00000000..9d55daf4 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgps210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgraw210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgraw210.dll new file mode 100644 index 00000000..ad0cddf4 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgraw210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsgi210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsgi210.dll new file mode 100644 index 00000000..39427578 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsgi210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsun210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsun210.dll new file mode 100644 index 00000000..5d4b3825 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsun210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtga210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtga210.dll new file mode 100644 index 00000000..21c7df53 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtga210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtiff210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtiff210.dll new file mode 100644 index 00000000..1ea3fa5b Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtiff210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgwindow210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgwindow210.dll new file mode 100644 index 00000000..6862369a Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgwindow210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxbm210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxbm210.dll new file mode 100644 index 00000000..3ae9e715 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxbm210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxpm210.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxpm210.dll new file mode 100644 index 00000000..852badbf Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxpm210.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9zlibtcl131.dll b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9zlibtcl131.dll new file mode 100644 index 00000000..f4768164 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9zlibtcl131.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tifftclstub.lib b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tifftclstub.lib new file mode 100644 index 00000000..0c9766cd Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tifftclstub.lib differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tkimgstub.lib b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tkimgstub.lib new file mode 100644 index 00000000..aed547d1 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tkimgstub.lib differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/zlibtclstub.lib b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/zlibtclstub.lib new file mode 100644 index 00000000..08ebe103 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/zlibtclstub.lib differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl new file mode 100644 index 00000000..7829e612 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl @@ -0,0 +1 @@ + package ifneeded TclCurl 8.15.0 "[list load [file join $dir tcl9TclCurl8150.dll] Tclcurl]; [list source [file join $dir tclcurl.tcl]]" diff --git a/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll new file mode 100644 index 00000000..042e6b22 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html new file mode 100644 index 00000000..b803d528 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html @@ -0,0 +1,3151 @@ +Manpage of TclCurl + +

TclCurl

+Section: Easy inteface (3)
Updated: 03 October 2011
+  +
+

NAME

+ +TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP, +LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax. +  +

SYNOPSIS

+ +curl::init + +

+curlHandle configure ?options? + +

+curlHandle perform + +

+curlHandle getinfo curlinfo_option + +

+curlhandle cleanup + +

+curlhandle reset + +

+curlHandle duhandle + +

+curlHandle pause + +

+curlHandle resume + +

+curl::transfer ?options? + +

+curl::version + +

+curl::escape url + +

+curl::unescape url + +

+curl::curlConfig option + +

+curl::versioninfo option + +

+curl::easystrerror errorCode + +

+  +

DESCRIPTION

+ +The TclCurl extension gives Tcl programmers access to the libcurl +library written by Daniel Stenberg, with it you can download urls, +upload them and many other neat tricks. + +  +

curl::init

+ +This procedure must be the first one to call, it returns a +curlHandle + +that you need to use to invoke TclCurl procedures. The init calls intializes +curl and this call MUST have a corresponding call to +cleanup + +when the operation is completed. +You should perform all your sequential file transfers using the same +curlHandle. This enables TclCurl to use persistant connections when +possible. +

+RETURN VALUE + +

+curlHandle + +to use. +  +

curlHandle configure ?options?

+ +

+configure + +is called to set the options for the transfer. Most operations in TclCurl +have default actions, and by using the appropriate options you can +make them behave differently (as documented). All options are set with +the option followed by a parameter. +

+Notes: + +the options set with this procedure are valid for the +forthcoming data transfers that are performed when you invoke +perform + +

+The options are not reset between transfers (except where noted), so if +you want subsequent transfers with different options, you must change them +between the transfers. You can optionally reset all options back to the internal +default with curlHandle reset. +

+curlHandle + +is the return code from the +curl::init + +call. +

+

+OPTIONS + +

+  +

Behaviour options

+ +

+

+
-verbose + +
+Set the parameter to 1 to get the library to display a lot of verbose +information about its operations. Very useful for libcurl and/or protocol +debugging and understanding. +

+You hardly ever want this set in production use, you will almost always want +this when you debug/report problems. Another neat option for debugging is +-debugproc + +

+

-header + +
+A 1 tells the extension to include the headers in the body output. This is +only relevant for protocols that actually have headers preceding the data (like HTTP). +

+

-noprogress + +
+A 1 tells the extension to turn on the progress meter +completely. It will also prevent the progessproc from getting called. +

+

-nosignal + +
+A 1 tells TclCurl not use any functions that install signal +handlers or any functions that cause signals to be sent to the process. This +option is mainly here to allow multi-threaded unix applications to still +set/use all timeout options etc, without risking getting signals. +

+If this option is set and libcurl has been built with the standard name resolver, +timeouts will not occur while the name resolve takes place. Consider building +libcurl with c-ares support to enable asynchronous DNS lookups, which enables +nice timeouts for name resolves without signals. +

+Setting nosignal to 1 makes libcurl NOT ask the system to ignore +SIGPIPE signals, which otherwise are sent by the system when trying to send +data to a socket which is closed in the other end. libcurl makes an effort to +never cause such SIGPIPEs to trigger, but some operating systems have no way +to avoid them and even on those that have there are some corner cases when +they may still happen, contrary to our desire. In addition, using +ntlm_Wb authentication could cause a SIGCHLD signal to be raised. +

+

-wildcard + +
+Set this option to 1 if you want to transfer multiple files according to a +file name pattern. The pattern can be specified as part of the +-url option, using an fnmatch-like pattern (Shell Pattern +Matching) in the last part of URL (file name). +

+By default, TClCurl uses its internal wildcard matching implementation. You +can provide your own matching function by the -fnmatchproc option. +

+This feature is only supported by the FTP download for now. +

+A brief introduction of its syntax follows: +

+
+
* - ASTERISK
+ftp://example.com/some/path/*.txt (for all txt's from the root directory) +
+
+ +
+
+
? - QUESTION MARK
+Question mark matches any (exactly one) character. +

+ftp://example.com/some/path/photo?.jpeg +

+
+ +
+
+
[ - BRACKET EXPRESSION
+The left bracket opens a bracket expression. The question mark and asterisk have +no special meaning in a bracket expression. Each bracket expression ends by the +right bracket and matches exactly one character. Some examples follow: +

+[a-zA-Z0-9] or [f-gF-G] - character interval +

+[abc] - character enumeration +

+[^abc] or [!abc] - negation +

+[[:name:]] class expression. Supported classes are +alnum,lower, space, alpha, digit, print, +upper, blank, graph, xdigit. +

+[][-!^] - special case - matches only '-', ']', '[', '!' or '^'. These +characters have no special purpose. +

+[\[\]\\] - escape syntax. Matches '[', ']' or '\'. +

+Using the rules above, a file name pattern can be constructed: +

+ftp://example.com/some/path/[a-z[:upper:]\\].jpeg +

+
+ +
+

+ +

+  +

Callback options

+ +

+

+
-writeproc + +
+Use it to set a Tcl procedure that will be invoked by TclCurl as soon as +there is received data that needs to be saved. The procedure will receive +a single parameter with the data to be saved. +

+NOTE: you will be passed as much data as possible in all invokes, but you +cannot possibly make any assumptions. It may be nothing if the file is +empty or it may be thousands of bytes. +

+

-file + +
+File in which the transfered data will be saved. +

+

-readproc + +
+Sets a Tcl procedure to be called by TclCurl as soon as it needs to read +data in order to send it to the peer. The procedure has to take one +parameter, which will contain the maximun numbers of bytes to read. It +should return the actual number of bytes read, or '0' if you want to +stop the transfer. +

+If you stop the current transfer by returning 0 "pre-maturely" (i.e before +the server expected it, like when you've said you will upload N bytes and +you upload less than N bytes), you may experience that the server "hangs" +waiting for the rest of the data that won't come. +

+Bugs: when doing TFTP uploads, you must return the exact amount of data +that the callback wants, or it will be considered the final packet by the +server end and the transfer will end there. +

+

-infile + +
+File from which the data will be transfered. +

+

-progressproc + +
+Name of the Tcl procedure that will invoked by TclCurl with a frequent +interval during operation (roughly once per second or sooner), no matter if data +is being transfered or not. Unknown/unused +argument values passed to the callback will be set to zero (like if you +only download data, the upload size will remain 0), the prototype of the +procedure must be: +

+proc ProgressCallback {dltotal dlnow ultotal ulnow} + +

+In order to this option to work you have to set the noprogress +option to '0'. Setting this option to the empty string will restore the +original progress function. +

+If you transfer data with the multi interface, this procedure will not be +called during periods of idleness unless you call the appropriate procedure +that performs transfers. +

+You can pause and resume a transfer from within this procedure using the +pause and resume commands. +

+

-writeheader + +
+Pass a the file name to be used to write the header part of the received data to. +The headers are guaranteed to be written one-by-one to this file and +only complete lines are written. Parsing headers should be easy enough using +this. +

+See also the headervar option to get the headers into an array. +

+

-debugproc + +
+Name of the procedure that will receive the debug data produced by the +-verbose + +option, it should match the following prototype: +

+debugProc {infoType data} + +

+where infoType specifies what kind of information it is (0 text, +1 incoming header, 2 outgoing header, 3 incoming data, 4 outgoing data, +5 incoming SSL data, 6 outgoing SSL data). +

+

-chunkbgnproc + +
+Name of the procedure that will be called before a file will be transfered by +ftp, it should match the following prototype: +

+ChunkBgnProc {remains} + +

+

+Where remains is the number of files left to be transfered (or skipped) +

+This callback makes sense only when using the -wildcard option. +

+

-chunkbgnvar + +
+Name of the variable in the global scope that will contain the data of the file about +to be transfered. If you don't use this option '::fileData' will be used. +

+The available data is: filename, filetype (file, directory, symlink, device block, device char, +named pipe, socket, door or error if it couldn't be identified), time, perm, uid, gid, +size, hardlinks and flags. +

+

-chunkendproc + +
+Name of the procedure that will be called after a file is transfered (or skipped) +by ftp, it should match the following prototype: +

+ChunkEndProc {} + +

+It should return '0' if everyhting is fine and '1' if some error occurred. +

+

-fnmatchProc + +
+Name of the procedure that will be called instead of the internal wildcard +matching function, it should match the following prototype: +

+FnMatchProc {pattern string} + +

+Returns '0' if it matches, '1' if it doesn't. +

+

+  +

Error Options

+ +

+

+
-errorbuffer + +
+Pass a variable name where TclCurl may store human readable error +messages in. This may be more helpful than just the return code from the +command. +

+

-stderr + +
+Pass a file name as parameter. This is the stream to use internally instead +of stderr when reporting errors. +
-failonerror + +
+A 1 parameter tells the extension to fail silently if the HTTP code +returned is equal or larger than 400. The default action would be to return +the page normally, ignoring that code. +

+This method is not fail-safe and there are occasions where non-successful response +codes will slip through, especially when authentication is involved +(response codes 401 and 407). +

+You might get some amounts of headers transferred before this situation is detected, +like for when a "100-continue" is received as a response to a POST/PUT and a 401 +or 407 is received immediately afterwards. +

+

+  +

Network options

+ +

+

+
-url + +
+The actual URL to deal with. +

+If the given URL lacks the protocol part ("http://" or "ftp://" etc), it will +attempt to guess which protocol to use based on the given host name. If the +given protocol of the set URL is not supported, TclCurl will return the +unsupported protocol error when you call perform. Use +curl::versioninfo for detailed info on which protocols are supported. +

+Starting with version 7.22.0, the fragment part of the URI will not be send as +part of the path, which was the case previously. +

+NOTE: this is the one option required to be set before perform is called. +

+

-protocols + +
+Pass a list in lowecase of protocols to limit what protocols TclCurl may use in the transfer. This +allows you to have a TclCurl built to support a wide range of protocols but still limit +specific transfers to only be allowed to use a subset of them. +

+Accepted protocols are 'http', 'https', 'ftp', 'ftps', 'scp', 'sftp', 'telnet', 'ldap', + +and 'all'. +

+

-redirprotocols + +
+Pass a list in lowercase of accepted protocols to limit what protocols TclCurl may use in a transfer +that it follows to in a redirect when -followlocation is enabled. This allows you +to limit specific transfers to only be allowed to use a subset of protocols in redirections. +

+By default TclCurl will allow all protocols except for FILE and SCP. This is a difference +compared to pre-7.19.4 versions which unconditionally would follow to all protocols supported. +

+

-proxy + +
+If you need to use a http proxy to access the outside world, set the +proxy string with this option. To specify port number in this string, +append :[port] to the end of the host name. The proxy string may be +prefixed with [protocol]:// since any such prefix will be ignored. +

+When you tell the extension to use a HTTP proxy, TclCurl will +transparently convert operations to HTTP even if you specify a FTP +URL etc. This may have an impact on what other features of the library +you can use, such as +quote + +and similar FTP specifics that will not work unless you tunnel through +the HTTP proxy. Such tunneling is activated with +proxytunnel + +

+TclCurl respects the environment variables http_proxy, ftp_proxy, +all_proxy etc, if any of those are set. The use of this option does +however override any possibly set environment variables. +

+Setting the proxy string to "" (an empty string) will explicitly disable +the use of a proxy, even if there is an environment variable set for it. +

+The proxy host string can be specified the exact same way as the proxy +environment variables, include protocol prefix (http://) and embedded +user + password. +

+Since 7.22.0, the proxy string may be specified with a protocol:// prefix to +specify alternative proxy protocols. Use socks4://, socks4a://, socks5:// or +socks5h:// (the last one to enable socks5 and asking the proxy to do the resolving) +to request the specific SOCKS version +to be used. No protocol specified, http:// and all others will be treated as +HTTP proxies. +

+

-proxyport + +
+Use this option to set the proxy port to use unless it is specified in +the proxy string by -proxy. If not specified, TclCurl will default +-to using port 1080 for proxies. +

+

-proxytype + +
+Pass the type of the proxy. Available options are 'http', 'http1.0', 'socks4', 'socks4a', +
man2html: unable to open or read file + +
+ +

+If you set it to http1.0, it will only affect how libcurl speaks to a proxy +when CONNECT is used. The HTTP version used for "regular" HTTP requests is instead +controled with httpversion. +

+

-noproxy + +
+Pass a string, a comma-separated list of hosts which do not use a proxy, if one +is specified. The only wildcard is a single * character, which matches all hosts, +and effectively disables the proxy. Each name in this list is matched as either +a domain which contains the hostname, or the hostname itself. For example, local.com +would match local.com, local.com:80, and www.local.com, but not http://www.notlocal.com. +

+

-httpproxytunnel + +
+Set the parameter to 1 to get the extension to tunnel all non-HTTP +operations through the given HTTP proxy. Do note that there is a big +difference between using a proxy and tunneling through it. If you don't know what +this means, you probably don't want this tunnel option. +

+

-socks5gssapiservice + +
+Pass thee name of the service. The default service name for a SOCKS5 server is +rcmd/server-fqdn. This option allows you to change it. +

+

-socks5gssapinec + +
+Pass a 1 to enable or 0 to disable. As part of the gssapi negotiation a protection +mode is negotiated. The rfc1961 says in section 4.3/4.4 it should be protected, but +the NEC reference implementation does not. If enabled, this option allows the +unprotected exchange of the protection mode negotiation. +

+

-interface + +
+Pass the interface name to use as outgoing +network interface. The name can be an interface name, an IP address or a host +name. +

+

-localport + +
+This sets the local port number of the socket used for connection. This can +be used in combination with -interface and you are recommended to use +localportrange as well when this is set. Valid port numbers +are 1 - 65535. +

+

-localportrange + +
+This is the number of attempts TclCurl should do to find a working local port +number. It starts with the given -localport and adds +one to the number for each retry. Setting this value to 1 or below will make +TclCurl do only one try for each port number. Port numbers by nature +are a scarce resource that will be busy at times so setting this value to something +too low might cause unnecessary connection setup failures. +

+

-dnscachetimeout + +
+Pass the timeout in seconds. Name resolves will be kept in memory for this number +of seconds. Set to '0' to completely disable caching, or '-1' to make the +cached entries remain forever. By default, TclCurl caches this info for 60 seconds. +

+The name resolve functions of various libc implementations don't re-read name +server information unless explicitly told so (for example, by calling +
 res_init(3)). This may cause TclCurl to keep using the older server even +if DHCP has updated the server info, and this may look like a DNS cache issue. +

+

-dnsuseglobalcache + +
+If the value passed is 1, it tells TclCurl to use a global DNS cache that +will survive between curl handles creations and deletions. This is not thread-safe +as it uses a global varible. +

+WARNING: this option is considered obsolete. Stop using it. Switch over +to using the share interface instead! See tclcurl_share. +

+

-buffersize + +
+Pass your prefered size for the receive buffer in TclCurl. The main point of this +would be that the write callback gets called more often and with smaller chunks. +This is just treated as a request, not an order. You cannot be guaranteed to +actually get the given size. +

+

-port + +
+

+Pass the number specifying what remote port to connect to, instead of the one specified +in the URL or the default port for the used protocol. +

+

-tcpnodelay + +
+

+Pass a number to specify whether the TCP_NODELAY option should be set or cleared (1 = set, 0 = clear). +The option is cleared by default. This will have no effect after the connection has been established. +

+Setting this option will disable TCP's Nagle algorithm. The purpose of this algorithm is to try to +minimize the number of small packets on the network (where "small packets" means TCP segments less +than the Maximum Segment Size (MSS) for the network). +

+Maximizing the amount of data sent per TCP segment is good because it amortizes the overhead of the +send. However, in some cases (most notably telnet or rlogin) small segments may need to be sent without +delay. This is less efficient than sending larger amounts of data at a time, and can contribute to +congestion on the network if overdone. +

+

-addressscope + +
+Pass a number specifying the scope_id value to use when connecting to IPv6 link-local or site-local +addresses. +

+

+  +

Names and Passwords options

+ +

+

+
-netrc + +
+A 1 parameter tells the extension to scan your +~/.netrc + +file to find user name and password for the remote site you are about to +access. Do note that TclCurl does not verify that the file has the correct +properties set (as the standard unix ftp client does), and that only machine +name, user name and password is taken into account (init macros and similar +things are not supported). +

+You can set it to the following values: +

+
+
optional + +
+The use of your ~/.netrc file is optional, and information in the URL is to +be preferred. The file will be scanned with the host and user name (to find +the password only) or with the host only, to find the first user name and +password after that machine, which ever information is not specified in +the URL. +

+Undefined values of the option will have this effect. +

ignored + +
+The extension will ignore the file and use only the information in the URL. +This is the default. +
required + +
+This value tells the library that use of the file is required, to ignore +the information in the URL, and to search the file with the host only. +
+
+ +

+

-netrcfile + +
+Pass a string containing the full path name to the file you want to use as .netrc +file. For the option to work, you have to set the netrc option to +required. If this option is omitted, and netrc is set, TclCurl +will attempt to find the a .netrc file in the current user's home directory. +

+

-userpwd + +
+Pass a string as parameter, which should be [username]:[password] to use for +the connection. Use -httpauth to decide authentication method. +

+When using NTLM, you can set domain by prepending it to the user name and +separating the domain and name with a forward (/) or backward slash (\). Like +this: "domain/user:password" or "domain\user:password". Some HTTP servers (on +Windows) support this style even for Basic authentication. +

+When using HTTP and -followlocation, TclCurl might perform several +requests to possibly different hosts. TclCurl will only send this user and +password information to hosts using the initial host name (unless +-unrestrictedauth is set), so if TclCurl follows locations to other +hosts it will not send the user and password to those. This is enforced to +prevent accidental information leakage. +

+

-proxyuserpwd + +
+Pass a string as parameter, which should be [username]:[password] to use for +the connection to the HTTP proxy. +

+

-username + +
+Pass a string with the user name to use for the transfer. It sets the user name +to be used in protocol authentication. You should not use this option together +with the (older) -userpwd option. +

+In order to specify the password to be used in conjunction with the user name +use the -password option. +

+

-password + +
+Pass a string with the password to use for the transfer. +

+It should be used in conjunction with the -username option. +

+

-proxyusername + +
+Pass a string with the user name to use for the transfer while connecting to Proxy. +

+It should be used in same way as the -proxyuserpwd is used, except that it +allows the username to contain a colon, like in the following example: +"sip:user@example.com". +

+Note the -proxyusername option is an alternative way to set the user name +while connecting to Proxy. It doesn't make sense to use them together. +

+

-proxypassword + +
+Pass a string with the password to use for the transfer while connecting to Proxy. It +is meant to use together with -proxyusername. +

+

-httpauth + +
+Set to the authentication method you want, the available ones are: +
+
+
basic + +
+HTTP Basic authentication. This is the default choice, and the only +method that is in widespread use and supported virtually everywhere. +It sends the user name and password over the network in plain text, +easily captured by others. +

+

digest + +
+HTTP Digest authentication. Digest authentication is a more secure +way to do authentication over public networks than the regular +old-fashioned Basic method. +

+

digestie + +
+HTTP Digest authentication with an IE flavor. TclCurl will use a special +"quirk" that IE is known to have used before version 7 and that some +servers require the client to use. +

+

gssnegotiate + +
+HTTP GSS-Negotiate authentication. The GSS-Negotiate method, also known as +plain "Negotiate",was designed by Microsoft and is used in their web +applications. It is primarily meant as a support for Kerberos5 authentication +but may be also used along with another authentication methods. +

+

ntlm + +
+HTTP NTLM authentication. A proprietary protocol invented and used by Microsoft. +It uses a challenge-response and hash concept similar to Digest, to prevent the +password from being eavesdropped. +

+

ntlmwb + +
+NTLM delegating to winbind helper. Authentication is performed by a separate +binary application that is executed when needed. The name of the application is +specified at libcurl's compile time but is typically /usr/bin/ntlm_auth. +

+Note that libcurl will fork when necessary to run the winbind application and kill +it when complete, calling waitpid() to await its exit when done. On POSIX operating +systems, killing the process will cause a SIGCHLD signal to be raised +(regardless of whether -nosignal is set). This behavior is subject to change +in future versions of libcurl. +

+

any + +
+TclCurl will automatically select the one it finds most secure. +

+

anysafe + +
+It may use anything but basic, TclCurl will automaticly select the +one it finds most secure. +
+
+ +

+

Use it to tell TclCurl which authentication method(s) you want it to use for TLS authentication.
+
+
+
tlsauthsrp + +
+
+TLS-SRP authentication. Secure Remote Password authentication for TLS is +defined in RFC 5054 and provides mutual authentication if both sides have a +shared secret. To use TLS-SRP, you must also set the +-tlsauthusername and -tlsauthpassword options. +

+You need to build libcurl with GnuTLS or OpenSSL with TLS-SRP support for this +to work. +

+
+ +

+

-tlsauthusername + +
+Pass a string with the username to use for the TLS authentication method specified +with the -tlsauthtype option. Requires that the -tlsauthpassword option +also be set. +

+

-tlsauthpassword + +
+Pass a string with the password to use for the TLS authentication method specified +with the -tlsauthtype option. Requires that the -tlsauthusername option +also be set. +

+

-proxyauth + +
+Use it to tell TclCurl which authentication method(s) you want it to use for +your proxy authentication. Note that for some methods, this will induce an +extra network round-trip. Set the actual name and password with the +proxyuserpwd option. +

+The methods are those listed above for the httpauth option. As of this +writing, only Basic and NTLM work. +

+

+  +

HTTP options

+ +

+

+
-autoreferer + +
+Pass an 1 parameter to enable this. When enabled, TclCurl will +automatically set the Referer: field in requests where it follows a Location: +redirect. +

+

-encoding + +
+Sets the contents of the Accept-Encoding: header sent in an HTTP +request, and enables decoding of a response when a Content-Encoding: +header is received. Three encodings are supported: identity, +which does nothing, deflate which requests the server to +compress its response using the zlib algorithm, and gzip which +requests the gzip algorithm. Use all to send an +Accept-Encoding: header containing all supported encodings. +

+This is a request, not an order; the server may or may not do it. This +option must be set or else any unsolicited +encoding done by the server is ignored. See the special file +lib/README.encoding in libcurl docs for details. +

+

-transferencoding + +
+Adds a request for compressed Transfer Encoding in the outgoing HTTP +request. If the server supports this and so desires, it can respond with the +HTTP resonse sent using a compressed Transfer-Encoding that will be +automatically uncompressed by TclCurl on receival. +

+Transfer-Encoding differs slightly from the Content-Encoding you ask for with +-encoding in that a Transfer-Encoding is strictly meant to +be for the transfer and thus MUST be decoded before the data arrives in the +client. Traditionally, Transfer-Encoding has been much less used and supported +by both HTTP clients and HTTP servers. +

+

-followlocation + +
+An 1 tells the library to follow any +Location: header + +that the server sends as part of a HTTP header. +

+This means that the extension will re-send the same request on the new location +and follow new Location: headers all the way until no more such headers are +returned. -maxredirs can be used to limit the number of redirects +TclCurl will follow. +

+Since 7.19.4, TclCurl can limit what protocols it will automatically follow. +The accepted protocols are set with -redirprotocols and it excludes the FILE +protocol by default. +

+

-unrestrictedauth + +
+An 1 parameter tells the extension it can continue +to send authentication (user+password) when following +locations, even when hostname changed. Note that this +is meaningful only when setting -followlocation. +

+

-maxredirs + +
+Sets the redirection limit. If that many redirections have been followed, +the next redirect will cause an error. This option only makes sense if the +-followlocation option is used at the same time. Setting the limit +to 0 will make libcurl refuse any redirect. Set it to -1 for an infinite +number of redirects (which is the default) +

+

-post301 + +
+Controls how TclCurl acts on redirects after POSTs that get a 301 or 302 response back. +A "301" as parameter tells the TclCurl to respect RFC 2616/10.3.2 and not convert POST +requests into GET requests when following a 301 redirection. Passing a "302" makes +TclCurl maintain the request method after a 302 redirect. "all" is a convenience string +that activates both behaviours. +

+The non-RFC behaviour is ubiquitous in web browsers, so the extension does the conversion +by default to maintain consistency. However, a server may require a POST to remain a POST +after such a redirection. +

+This option is meaningful only when setting -followlocation +

+ +

-put + +
+An 1 parameter tells the extension to use HTTP PUT a file. The file to put +must be set with -infile and -infilesize. +

+This option is deprecated starting with version 0.12.1, you should use -upload. +

+This option does not limit how much data TclCurl will actually send, as that is +controlled entirely by what the read callback returns. +

+

-post + +
+An 1 parameter tells the library to do a regular HTTP post. This is a +normal application/x-www-form-urlencoded kind, which is the most commonly used +one by HTML forms. See the -postfields option for how to specify the +data to post and -postfieldsize about how to set the data size. +

+Use the -postfields option to specify what data to post and -postfieldsize +to set the data size. Optionally, you can provide data to POST using the -readproc +options. +

+You can override the default POST Content-Type: header by setting your own with +-httpheader. +

+Using POST with HTTP 1.1 implies the use of a "Expect: 100-continue" header. +You can disable this header with -httpheader as usual. +

+If you use POST to a HTTP 1.1 server, you can send data without knowing the +size before starting the POST if you use chunked encoding. You enable this +by adding a header like "Transfer-Encoding: chunked" with -httpheader. +With HTTP 1.0 or without chunked transfer, you must specify the size in the +request. +

+When setting post to an 1 value, it will automatically set +nobody to 0. +

+NOTE: if you have issued a POST request and want to make a HEAD or GET instead, you must +explicitly pick the new request type using -nobody or -httpget or similar. +

+

-postfields + +
+Pass a string as parameter, which should be the full data to post in a HTTP +POST operation. You must make sure that the data is formatted the way you +want the server to receive it. TclCurl will not convert or encode it for you. +Most web servers will assume this data to be url-encoded. +

+This is a normal application/x-www-form-urlencoded kind, +which is the most commonly used one by HTML forms. +

+If you want to do a zero-byte POST, you need to set +-postfieldsize explicitly to zero, as simply setting +-postfields to NULL or "" just effectively disables the sending +of the specified string. TclCurl will instead assume that the POST +data will be send using the read callback! +

+Using POST with HTTP 1.1 implies the use of a "Expect: 100-continue" header. +You can disable this header with -httpheader as usual. +

+Note: to make multipart/formdata posts (aka rfc1867-posts), check out +-httppost option. +

+

-postfieldsize + +
+If you want to post data to the server without letting TclCurl do a strlen() +to measure the data size, this option must be used. Also, when this option is +used, you can post fully binary data which otherwise is likely to fail. If +this size is set to zero, the library will use strlen() to get the data +size. +

+

-httppost + +
+Tells TclCurl you want a multipart/formdata HTTP POST to be made and you +instruct what data to pass on to the server through a +Tcl list. + +

+This is the only case where the data is reset after a transfer. +

+First, there are some basics you need to understand about multipart/formdata +posts. Each part consists of at least a NAME and a CONTENTS part. If the part +is made for file upload, there are also a stored CONTENT-TYPE and a +FILENAME. Below, we'll discuss on what options you use to set these +properties in the parts you want to add to your post. +

+The list must contain a 'name' tag with the name of the section followed +by a string with the name, there are three tags to indicate the value of +the section: 'value' followed by a string with the data to post, 'file' +followed by the name of the file to post and 'contenttype' with the +type of the data (text/plain, image/jpg, ...), you can also indicate a false +file name with 'filename', this is useful in case the server checks if the given +file name is valid, for example, by testing if it starts with 'c:\' as any real file +name does or if you want to include the full path of the file to post. You can also post +the content of a variable as if it were a file with the options 'bufferName' and +'buffer' or use 'filecontent' followed by a file name to read that file and +use the contents as data. +

+Should you need to specify extra headers for the form POST section, use +'contentheader' followed by a list with the headers to post. +

+Please see 'httpPost.tcl' and 'httpBufferPost.tcl' for examples. +

+If TclCurl can't set the data to post an error will be returned: +

+
+
1 + +
+If the memory allocation fails. +
2 + +
+If one option is given twice for one form. +
3 + +
+If an empty string was given. +
4 + +
+If an unknown option was used. +
5 + +
+If the some form info is not complete (or error) +
6 + +
+If an illegal option is used in an array. +
7 + +
+TclCurl has no http support. +
+
+ +

+

-referer + +
+Pass a string as parameter. It will be used to set the +referer + +header in the http request sent to the remote server. This can be used to +fool servers or scripts. You can also set any custom header with +-httpheader. + +

+

-useragent + +
+Pass a string as parameter. It will be used to set the +user-agent: + +header in the http request sent to the remote server. This can be used to fool +servers or scripts. You can also set any custom header with +-httpheader. + +

+

-httpheader + +
+Pass a +list + +with the HTTP headers to pass to the server in your request. +If you add a header that is otherwise generated +and used by TclCurl internally, your added one will be used instead. If you +add a header with no contents as in 'Accept:', the internally used header will +just get disabled. Thus, using this option you can add new headers, replace +and remove internal headers. +

+The headers included in the linked list must not be CRLF-terminated, because +TclCurl adds CRLF after each header item. Failure to comply with this will +result in strange bugs because the server will most likely ignore part of the +headers you specified. +

+The first line in a request (containing the method, usually a GET or POST) is +not a header and cannot be replaced using this option. Only the lines +following the request-line are headers. Adding this method line in this list +of headers will only cause your request to send an invalid header. +

+NOTE:The most commonly replaced headers have "shortcuts" in the options: +cookie, useragent, + +and +referer. + +

+

-http200aliases + +
+Pass a list of aliases to be treated as valid HTTP 200 responses. Some servers +respond with a custom header response line. For example, IceCast servers respond +with "ICY 200 OK". By including this string in your list of aliases, the +response will be treated as a valid HTTP header line such as "HTTP/1.0 200 OK". +

+NOTE:The alias itself is not parsed for any version strings. Before version +7.16.3, TclCurl used the value set by option httpversion, but starting with +7.16.3 the protocol is assumed to match HTTP 1.0 when an alias matched. +

+

-cookie + +
+Pass a string as parameter. It will be used to +set a cookie in the http request. The format of the string should be + +what the cookie should contain. +

+If you need to set mulitple cookies, you need to set them all using +a single option and thus you need to concatenate them all in one single string. +Set multiple cookies in one string like this: "name1=content1; name2=content2;" +etc. +

+This option sets the cookie header explictly in the outgoing request(s). +If multiple requests are done due to authentication, followed redirections or similar, +they will all get this cookie passed on. +

+Using this option multiple times will only make the latest string override +the previous ones. +

+

-cookiefile + +
+Pass a string as parameter. It should contain the name of your file holding +cookie data. The cookie data may be in netscape cookie data format or just +regular HTTP-style headers dumped to a file. +

+Given an empty or non-existing file, this option will enable cookies for this +curl handle, making it understand and parse received cookies and then use +matching cookies in future requests. +

+If you use this option multiple times, you add more files to read. +

+

-cookiejar + +
+Pass a file name in which TclCurl will dump all internally known cookies +when +curlHandle cleanup + +is called. If no cookies are known, no file will be created. +Specify "-" to have the cookies written to stdout. +

+Using this option also enables cookies for this session, so if you, for +example, follow a location it will make matching cookies get sent accordingly. +

+TclCurl will not and cannot report an error for this. Using 'verbose' +will get a warning to display, but that is the only visible feedback you get +about this possibly lethal situation. +

+

-cookiesession + +
+Pass an 1 to mark this as a new cookie "session". It will +force TclCurl to ignore all cookies it is about to load that are "session +cookies" from the previous session. By default, TclCurl always stores and +loads all cookies, independent of whether they are session cookies are not. +Session cookies are cookies without expiry date and they are meant to be +alive and existing for this "session" only. +

+

-cookielist + +
+Pass a string with a cookie. The cookie can be either in Netscape / Mozilla +format or just regular HTTP-style header (Set-Cookie: ...) format. If the +cookie engine was not enabled it will be enabled. Passing a +magic string "ALL" will erase all known cookies while "FLUSH" will write +all cookies known by TclCurl to the file specified by -cookiejar. +

+

-httpget + +
+If set to 1 forces the HTTP request to get back to GET, usable if +POST, PUT or a custom request have been used previously with the +same handle. +

+When setting httpget to 1, nobody will automatically be set to 0. +

+

-httpversion + +
+Set to one of the values decribed below, they force TclCurl to use the +specific http versions. It should only be used if you really MUST do +that because of a silly remote server. +
+
+
none + +
+We do not care about what version the library uses. TclCurl will use whatever +it thinks fit. +
1.0 + +
+Enforce HTTP 1.0 requests. +
1.1 + +
+Enforce HTTP 1.1 requests. +
2.0 + +
+Enforce HTTP version 2 requests. +
2TLS + +
+Enforce version 2 requests for HTTPS, version 1.1 for HTTP. +
2_PRIOR_KNOWLEDGE + +
+Enforce HTTP 2 requests without performing HTTP/1.1 Upgrade first. +
+
+ +

+

-ignorecontentlength + +
+Ignore the Content-Length header. This is useful for Apache 1.x (and similar +servers) which will report incorrect content length for files over 2 +gigabytes. If this option is used, TclCurl will not be able to accurately +report progress, and will simply stop the download when the server ends the +connection. +

+

-httpcontentdecoding + +
+Set to zero to disable content decoding. If set to 1 it is enabled. Note however +that TclCurl has no default content decoding but requires you to use encoding for that. +

+

-httptransferencoding + +
+Set to zero to disable transfer decoding, if set to 1 it is enabled (default). TclCurl does +chunked transfer decoding by default unless this option is set to zero. +

+

+  +

SMTP options

+ +

+

+
-mailfrom + +
+Pass a string to specify the sender address in a mail when sending an SMTP mail with TclCurl. +

+

-mailrcpt + +
+Pass a list of recipients to pass to the server in your SMTP mail request. +

+Each recipient in SMTP lingo is specified with angle brackets (<>), but should you not use an +angle bracket as first letter, TclCurl will assume you provide a single email address only and +enclose that with angle brackets for you. +

+

+  +

TFTP option

+ +

+

+
tftpblksize + +
+

+Specify the block size to use for TFTP data transmission. Valid range as per RFC 2348 is 8-65464 bytes. +The default of 512 bytes will be used if this option is not specified. The specified block size will +only be used pending support by the remote server. If the server does not return an option acknowledgement +or returns an option acknowledgement with no blksize, the default of 512 bytes will be used. +

+

+  +

FTP options

+ +

+

+
-ftpport + +
+Pass a string as parameter. It will be used to +get the IP address to use for the ftp PORT instruction. The PORT instruction +tells the remote server to connect to our specified IP address. The string may +be a plain IP address, a host name, a network interface name (under unix) or +just a '-' to let the library use your systems default IP address. Default FTP +operations are passive, and thus will not use PORT. +

+The address can be followed by a ':' to specify a port, optionally followed by a '-' +o specify a port range. If the port specified is 0, the operating system will pick +a free port. If a range is provided and all ports in the range are not available, +libcurl will report CURLE_FTP_PORT_FAILED for the handle. Invalid port/range settings +are ignored. IPv6 addresses followed by a port or portrange have to be in brackets. +IPv6 addresses without port/range specifier can be in brackets. +

+Examples with specified ports: +

+
  eth0:0   192.168.1.2:32000-33000   curl.se:32123   [::1]:1234-4567 +

+You disable PORT again and go back to using the passive version by setting this option to +an empty string. +

+

-quote + +
+Pass a list list with the FTP or SFTP commands to pass to the server prior to your +ftp request. This will be done before any other FTP commands are issued (even +before the CWD command).If you do not want to transfer any files, set +nobody to '1' and header to '0'. +

+Prefix the command with an asterisk (*) to make TclCurl continue even if the command +fails as by default TclCurl will stop. +

+Disable this operation again by setting an empty string to this option. +

+Keep in mind the commands to send must be 'raw' ftp commands, for example, to +create a directory you need to send mkd Test, not mkdir Test. +

+Valid SFTP commands are: chgrp, chmod, chown, ln, mkdir, pwd, rename, rm, +rmdir and symlink. +

+

-postquote + +
+Pass a list with the FTP commands to pass to the server after your +ftp transfer request. If you do not want to transfer any files, set +nobody to '1' and header to '0'. +

+

-prequote + +
+Pass a list of FTP or SFTP commands to pass to the server after the +transfer type is set. +

+

-dirlistonly + +
+A 1 tells the library to just list the names of files in a +directory, instead of doing a full directory listing that would include file +sizes, dates etc. It works with both FTP and SFTP urls. +

+This causes an FTP NLST command to be sent. Beware that some FTP servers list +only files in their response to NLST, they might not include subdirectories +and symbolic links. +

+Setting this option to 1 also implies a directory listing even if the URL +doesn't end with a slash, which otherwise is necessary. +

+Do NOT use this option if you also use -wildcardmatch as it will +effectively break that feature. +

+

-append + +
+A 1 parameter tells the extension to append to the remote file instead of +overwriting it. This is only useful when uploading to a ftp site. +

+

-ftpusepret + +
+Set to 1 to tell TclCurl to use the EPRT (and LPRT) command when doing +active FTP downloads (which is enabled by 'ftpport'). Using EPRT means +that it will first attempt to use EPRT and then LPRT before using PORT, if +you pass zero to this option, it will not try using EPRT or LPRT, only plain PORT. +

+

-ftpuseepvs + +
+Set to one to tell TclCurl to use the EPSV command when doing passive FTP +downloads (which it always does by default). Using EPSV means that it will +first attempt to use EPSV before using PASV, but if you pass a zero to this +option, it will not try using EPSV, only plain PASV. +

+

-ftpusepret + +
+

+Set to one to tell TclCurl to send a PRET command before PASV (and EPSV). Certain +FTP servers, mainly drftpd, require this non-standard command for directory listings +as well as up and downloads in PASV mode. Has no effect when using the active FTP +transfers mode. +

+

-ftpcreatemissingdirs + +
+If set to 1, TclCurl will attempt to create any remote directory that it +fails to CWD into. CWD is the command that changes working directory. +

+This setting also applies to SFTP-connections. TclCurl will attempt to create +the remote directory if it can't obtain a handle to the target-location. The +creation will fail if a file of the same name as the directory to create +already exists or lack of permissions prevents creation. +

+If set to 2, TclCurl will retry the CWD command again if the subsequent MKD +command fails. This is especially useful if you're doing many simultanoeus +connections against the same server and they all have this option enabled, +as then CWD may first fail but then another connection does MKD before this +connection and thus MKD fails but trying CWD works +

+

-ftpresponsetimeout + +
+Causes TclCurl to set a timeout period (in seconds) on the amount of time that +the server is allowed to take in order to generate a response message for a +command before the session is considered hung. Note that while TclCurl is waiting +for a response, this value overrides timeout. It is recommended that if used +in conjunction with timeout, you set it to a value smaller than timeout. +

+

-ftpalternativetouser + +
+Pass a string which will be used to authenticate if the usual FTP "USER user" and +"PASS password" negotiation fails. This is currently only known to be required when +connecting to Tumbleweed's Secure Transport FTPS server using client certificates for +authentication. +

+

-ftpskippasvip + +
+If set to 1, it instructs TclCurl not to use the IP address the +server suggests in its 227-response to TclCurl's PASV command when TclCurl +connects the data connection. Instead TclCurl will re-use the same IP address +it already uses for the control connection. But it will use the port number +from the 227-response. +

+This option has no effect if PORT, EPRT or EPSV is used instead of PASV. +

+

-ftpsslauth + +
+

+Pass TclCurl one of the values from below, to alter how TclCurl issues +"AUTH TLS" or "AUTH SSL" when FTP over SSL is activated (see -ftpssl). +

+You may need this option because of servers like BSDFTPD-SSL +which won't work properly when "AUTH SSL" is issued +(although the server responds fine and everything) but requires "AUTH TLS" +instead. +

+

+
+
default + +
+Allows TclCurl to decide. +
ssl + +
+Try "AUTH SSL" first, and only if that fails try "AUTH TLS". +
tls + +
+Try "AUTH TLS" first, and only if that fails try "AUTH SSL". +
+
+ +

+

-ftpsslccc + +
+Set it to make TclCurl use CCC (Clear Command Channel). It shuts down the +SSL/TLS layer after authenticating. The rest of the control channel +communication will be unencrypted. This allows NAT routers to follow the +FTP transaction. Possible values are: +

+

+
+
none + +
+Do not attempt to use CCC. +
passive + +
+Do not initiate the shutdown, wait for the server to do it. Do not send a reply. +
active + +
+Initiate the shutdown and wait for a reply. +
+
+ +

+

-ftpaccount + +
+Pass string (or "" to disable). When an FTP server asks for "account data" after +user name and password has been provided, this data is sent off using the ACCT +command. +

+

-ftpfilemethod + +
+It allows three values: +
+
+
multicwd + +
+The default, TclCurl will do a single CWD operation for each path part in the given +URL. For deep hierarchies this means very many commands. This is how RFC1738 says it +should be done. +
nocwd + +
+No CWD at all is done, TclCurl will do SIZE, RETR, STOR, etc and give a full path to +the server. +
singlecwd + +
+Make one CWD with the full target directory and then operate on the file "normally". +This is somewhat more standards compliant than 'nocwd' but without the full penalty of 'multicwd'. +
+
+ +

+

+  +

Protocol options

+ +

+

+
-transfertext + +
+A 1 tells the extension to use ASCII mode for ftp transfers, +instead of the default binary transfer. For win32 systems it does not set the +stdout to binary mode. This option can be usable when transferring text data +between systems with different views on certain characters, such as newlines +or similar. +

+NOTE: TclCurl does not do a complete ASCII conversion when doing ASCII +transfers over FTP. This is a known limitation/flaw that nobody has +rectified. TclCurl simply sets the mode to ascii and performs a standard +transfer. +

+

-proxytransfermode + +
+If set to 1, TclCurl sets the transfer mode (binary or ASCII) for FTP transfers +done via an HTTP proxy, by appending ;type=a or ;type=i to the URL. +Without this setting, or it being set to 0, the default, -transfertext has +no effect when doing FTP via a proxy. Beware that not all proxies support this feature. +

+

-crlf + +
+If set to '1', TclCurl converts Unix newlines to CRLF newlines on transfers. Disable +this option again by setting the value to '0'. +

+

-range + +
+Pass a string as parameter, which should contain the specified range you +want. It should be in the format +X-Y + +, where X or Y may be left out. HTTP +transfers also support several intervals, separated with commas as in +X-Y,N-M + +Using this kind of multiple intervals will cause the HTTP server to send the +response document in pieces (using standard MIME separation techniques). +

+Ranges only work on HTTP, FTP and FILE transfers. +

+

-resumefrom + +
+Pass the offset in number of bytes that you want the transfer to start from. +Set this option to 0 to make the transfer start from the beginning +(effectively disabling resume). +

+For FTP, set this option to -1 to make the transfer start from the end of the +target file (useful to continue an interrupted upload). +

+When doing uploads with FTP, the resume position is where in the local/source +file TclCurl should try to resume the upload from and it will then append the +source file to the remote target file. +

+

-customrequest + +
+Pass a string as parameter. It will be used instead of GET or HEAD when doing +the HTTP request. This is useful for doing DELETE or other more obscure HTTP +requests. Do not do this at will, make sure your server supports the command first. +

+Note that TclCurl will still act and assume the keyword it would use if you +do not set your custom and it will act according to that. Thus, changing this +to a HEAD when TclCurl otherwise would do a GET might cause TclCurl to act funny, +and similar. To switch to a proper HEAD, use -nobody, to switch to a proper +POST, use -post or -postfields and so on. +

+

-filetime + +
+If you pass a 1, TclCurl will attempt to get the +modification date of the remote document in this operation. This requires that +the remote server sends the time or replies to a time querying command. The +getinfo procedure with the +filetime + +argument can be used after a transfer to extract the received time (if any). +

+

-nobody + +
+A 1 tells the library not to include the body-part in the +output. This is only relevant for protocols that have a separate header and +body part. On HTTP(S) servers, this will make TclCurl do a HEAD request. +

+To change request to GET, you should use httpget. Change request +to POST with post etc. +

+

-infilesize + +
+When uploading a file to a remote site, this option should be used to tell +TclCurl what the expected size of the infile is. +

+This option is mandatory for uploading using SCP. +

+

-upload + +
+A 1 tells the library to prepare for an upload. The +-infile and -infilesize options are also interesting for uploads. +If the protocol is HTTP, uploading means using the PUT request unless you tell +TclCurl otherwise. +

+Using PUT with HTTP 1.1 implies the use of a "Expect: 100-continue" header. +You can disable this header with -httpheader as usual. +

+If you use PUT to a HTTP 1.1 server, you can upload data without knowing the +size before starting the transfer if you use chunked encoding. You enable this +by adding a header like "Transfer-Encoding: chunked" with -httpheader. +With HTTP 1.0 or without chunked transfer, you must specify the size. +

+

-maxfilesize + +
+This allows you to specify the maximum size (in bytes) of a file to download. +If the file requested is larger than this value, the transfer will not start +and error 'filesize exceeded' (63) will be returned. +

+NOTE: The file size is not always known prior to download, and for such files +this option has no effect even if the file transfer ends up being larger than +this given limit. This concerns both FTP and HTTP transfers. +

+

-timecondition + +
+This defines how the timevalue value is treated. You can set this +parameter to ifmodsince or ifunmodsince. This feature applies to +HTTP, FTP and FILE. +

+

-timevalue + +
+This should be the time in seconds since 1 jan 1970, and the time will be +used in a condition as specified with timecondition. +

+

+

+  +

Connection options

+ +

+

+
-timeout + +
+Pass the maximum time in seconds that you allow +the TclCurl transfer operation to take. Do note that normally, name lookups +may take a considerable time and that limiting the operation to less than a +few minutes risks aborting perfectly normal operations. This option will +cause libcurl to use the SIGALRM to enable time-outing system calls. +

+In unix-like systems, this might cause signals to be used unless +-nosignal is used. +

+

-timeoutms + +
+Like timeout but takes a number of milliseconds instead. If libcurl is +built to use the standard system name resolver, that part will still use +full-second resolution for timeouts. +

+

-lowspeedlimit + +
+Pass the speed in bytes per second that the transfer should be below during +lowspeedtime + +seconds for the extension to consider it too slow and abort. +

+

-lowspeedtime + +
+Pass the time in seconds that the transfer should be below the +lowspeedlimit + +for the extension to consider it too slow and abort. +

+

-maxsendspeed + +
+Pass a speed in bytes per seconds. If an upload exceeds this speed on cumulative +average during the transfer, the transfer will pause to keep the average rate less +than or equal to the parameter value. Defaults to unlimited speed. +

+

-maxrecvspeed + +
+Pass a speed in bytes per second. If a download exceeds this speed on cumulative +average during the transfer, the transfer will pause to keep the average rate less +than or equal to the parameter value. Defaults to unlimited speed. +

+

-maxconnects + +
+Sets the persistant connection cache size in all the protocols that support +persistent conecctions. The set amount will be the maximum amount of simultaneous +connections that TclCurl may cache in this easy handle. Default is 5, and there +isn't much point in changing this value unless you are perfectly aware of how this +work and changes TclCurl's behaviour. +

+When reaching the maximum limit, TclCurl closes the oldest connection in the cache +to prevent the number of open connections to increase. +

+Note: if you have already performed transfers with this curl handle, +setting a smaller +maxconnects + +than before may cause open connections to unnecessarily get closed. +

+If you add this easy handle to a multi handle, this setting is not +being acknowledged, instead you must configure the multi handle its own +maxconnects option. +

+

-connecttimeout + +
+Maximum time in seconds that you allow the +connection to the server to take. This only limits the connection phase, once +it has connected, this option is of no more use. Set to zero to disable +connection timeout (it will then only timeout on the internal timeouts). +

+In unix-like systems, this might cause signals to be used unless +-nosignal is set. +

+

-connecttimeoutms + +
+Like connecttimeout but takes a number of milliseconds instead. If libcurl +is built to use the standard system name resolver, that part will still use +full-second resolution for timeouts. +

+

-ipresolve + +
+Allows an application to select what kind of IP addresses to use when +resolving host names. This is only interesting when using host names +that resolve addresses using more than one version of IP. The allowed +values are: +
+
+
whatever + +
+Default, resolves addresses to all IP versions that your system allows. +
v4 + +
+Resolve to ipv4 addresses. +
v6 + +
+Resolve to ipv6 addresses. +
+
+ +

+

-resolve + +
+Pass a list of strings with host name resolve information to use for requests with +this handle. +

+Each single name resolve string should be written using the format +HOST:PORT:ADDRESS where HOST is the name TclCurl will try to resolve, PORT is +the port number of the service where TclCurl wants to connect to the HOST and +ADDRESS is the numerical IP address. If libcurl is built to support IPv6, +ADDRESS can be either IPv4 or IPv6 style addressing. +

+This option effectively pre-populates the DNS cache with entries for the +host+port pair so redirects and everything that operations against the +HOST+PORT will instead use your provided ADDRESS. +

+You can remove names from the DNS cache again, to stop providing these fake +resolves, by including a string in the linked list that uses the format +"-HOST:PORT". The host name must be prefixed with a dash, and the host name +and port number must exactly match what was already added previously. +

+

-usessl + +
+Pass a one of the values from below to make TclCurl use your desired level of SSL for the transfer. +This is for enabling SSL/TLS when you use FTP, SMTP, POP3, IMAP etc. +

+You can use ftps:// URLs to explicitly switch on SSL/TSL for the control +connection and the data connection. +

+Alternatively you can set the option to one of these values: +

+

+
+
nope + +
+Do not attempt to use SSL +
try + +
+Try using SSL, proceed anyway otherwise. +
control + +
+Use SSL for the control conecction or fail with "use ssl failed" (64). +
all + +
+Use SSL for all communication or fail with "use ssl failed" (64). +
+
+ +

+

+  +

SSL and security options

+ +

+

+
-sslcert + +
+Pass a string as parameter. The string should be the file name of your certificate. +The default format is "PEM" and can be changed with -sslcerttype. +

+With NSS this is the nickname of the certificate you wish to authenticate with. +If you want to use a file from the current directory, please precede it with the +"./" prefix, in order to avoid confusion with a nickname. +

+

-sslcerttype + +
+Pass a string as parameter. The string should be the format of your certificate. +Supported formats are "PEM" and "DER". +

+

-sslkey + +
+Pass a pointer to a zero terminated string as parameter. The string should be +the file name of your private key. The default format is "PEM" and can be +changed with -sslkeytype. +

+

-sslkeytype + +
+Pass a pointer to a zero terminated string as parameter. The string should be +the format of your private key. Supported formats are "PEM", "DER" and "ENG" +

+NOTE:The format "ENG" enables you to load the private key from a crypto +engine. in this case -sslkey is used as an identifier passed to +the engine. You have to set the crypto engine with -sslengine. The "DER" +format key file currently does not work because of a bug in OpenSSL. +

+

-keypasswd + +
+Pass a string as parameter. It will be used as the password required to use the +-sslkey or -sshprivatekeyfile private key. +

+You never need a pass phrase to load a certificate but you need one to load you +private key. +

+This option used to be known as -sslkeypasswd and -sslcertpasswd. +

+

-sslengine + +
+Pass a string as parameter. It will be used as the identifier for the crypto +engine you want to use for your private key. +

+NOTE:If the crypto device cannot be loaded, an error will be returned. +

+

-sslenginedefault + +
+Pass a 1 to set the actual crypto engine as the default for (asymmetric) crypto operations. +

+NOTE:If the crypto device cannot be set, an error will be returned. +

+

-sslversion + +
+Use it to set what version of SSL/TLS to use. The available options are: +
+
+
default + +
+The default action. This will attempt to figure out the remote SSL protocol version, +i.e. either SSLv3 or TLSv1 (but not SSLv2, which became disabled by default with 7.18.1). +
tlsv1 + +
+Force TLSv1 +
sslv2 + +
+Force SSLv2 +
sslv3 + +
+Force SSLv3 +
+
+ +

+

-sslverifypeer + +
+This option determines whether TclCurl verifies the authenticity of the peer's certificate. +A 1 means it verifies; zero means it doesn't. The default is 1. +

+When negotiating an SSL connection, the server sends a certificate indicating its identity. +TclCurl verifies whether the certificate is authentic, i.e. that you can trust that the +server is who the certificate says it is. This trust is based on a chain of digital signatures, +rooted in certification authority (CA) certificates you supply. +

+TclCurl uses a default bundle of CA certificates that comes with libcurl but you can specify +alternate certificates with the -cainfo or the -capath options. +

+When -sslverifypeer is nonzero, and the verification fails to prove that the certificate +is authentic, the connection fails. When the option is zero, the peer certificate verification +succeeds regardless. +

+Authenticating the certificate is not by itself very useful. You typically want to ensure +that the server, as authentically identified by its certificate, is the server you mean to +be talking to, use -sslverifyhost to control that. The check that the host name in +the certificate is valid for the host name you're connecting to is done +independently of this option. +

+

-cainfo + +
+Pass a file naming holding the certificate to verify the peer with. This only +makes sense when used in combination with the -sslverifypeer option, if +it is set to zero -cainfo need not even indicate an accessible file. +

+This option is by default set to the system path where libcurl's cacert bundle +is assumed to be stored, as established at build time. +

+When built against NSS this is the directory that the NSS certificate database +resides in. +

+

-issuercert + +
+Pass a string naming a file holding a CA certificate in PEM format. If the option +is set, an additional check against the peer certificate is performed to verify +the issuer is indeed the one associated with the certificate provided by the option. +This additional check is useful in multi-level PKI where one need to enforce the peer +certificate is from a specific branch of the tree. +
  +This option makes sense only when used in combination with the -sslverifypeer +option. Otherwise, the result of the check is not considered as failure. +

+

-capath + +
+Pass the directory holding multiple CA certificates to verify the peer with. +If libcurl is built against OpenSSL, the certificate directory must be prepared +using the openssl c_rehash utility. +This only makes sense when used in combination with the -sslverifypeer +option, if it is set to zero, -capath need not even indicate an accessible +path. +

+This option apparently does not work in Windows due to some limitation in openssl. +

+This option is OpenSSL-specific and does nothing if libcurl is built to use GnuTLS. +NSS-powered libcurl provides the option only for backward compatibility. +

+

-crlfile + +
+Pass a string naming a file with the concatenation of CRL (in PEM format) to use in +the certificate validation that occurs during the SSL exchange. +
  +When libcurl is built to use NSS or GnuTLS, there is no way to influence the use of +CRL passed to help in the verification process. When built with OpenSSL support, +X509_V_FLAG_CRL_CHECK and X509_V_FLAG_CRL_CHECK_ALL are both set, requiring CRL +check against all the elements of the certificate chain if a CRL file is passed. +
  +This option makes sense only when used in combination with the -sslverifypeer +option. +

+A specific error code (CURLE_SSL_CRL_BADFILE) is defined with the option. It is returned +when the SSL exchange fails because the CRL file cannot be loaded. A failure in certificate +verification due to a revocation information found in the CRL does not trigger this specific +error. +

+

-sslverifyhost + +
+This option determines whether TclCurl verifies that the server claims to be +who you want it to be. +

+When negotiating an SSL connection, the server sends a certificate +indicating its identity. +

+When -sslverifyhost is set to 2, that certificate must indicate +that the server is the server to which you meant to connect, or the +connection fails. +

+TclCurl considers the server the intended one when the Common Name field +or a Subject Alternate Name field in the certificate matches the host +name in the URL to which you told Curl to connect. +

+When set to 1, the certificate must contain a Common Name field, +but it does not matter what name it says. (This is not ordinarily a +useful setting). +

+When the value is 0, the connection succeeds regardless of the names in +the certificate. +

+The default value for this option is 2. +

+This option controls the identity that the server claims. The server +could be lying. To control lying, see -sslverifypeer. If libcurl is built +against NSS and -verifypeer is zero, -verifyhost is ignored. +

+

-certinfo + +
+Set to '1' to enable TclCurl's certificate chain info gatherer. With this enabled, TclCurl +(if built with OpenSSL) will extract lots of information and data about the certificates +in the certificate chain used in the SSL connection. This data can then be to extracted +after a transfer using the getinfo command and its option certinfo. +

+

-randomfile + +
+Pass a file name. The file will be used to read from to seed the random engine +for SSL. The more random the specified file is, the more secure the SSL +connection becomes. +

+

-egdsocket + +
+Pass a path name to the Entropy Gathering Daemon socket. It will be used to seed +the random engine for SSL. +

+

-sslcypherlist + +
+Pass a string holding the ciphers to use for the SSL connection. The list must +consists of one or more cipher strings separated by colons. Commas or spaces +are also acceptable separators but colons are normally used, , - and + can be +used as operators. +

+For OpenSSL and GnuTLS valid examples of cipher lists include 'RC4-SHA', 'SHA1+DES', + +

+You will find more details about cipher lists on this URL: +
    http://www.openssl.org/docs/apps/ciphers.html +

+For NSS valid examples of cipher lists include 'rsa_rc4_128_md5', 'rsa_aes_128_sha', +etc. With NSS you don't add/remove ciphers. If you use this option then all known +ciphers are disabled and only those passed in are enabled. +
  +You'll find more details about the NSS cipher lists on this URL: +
    http://directory.fedora.redhat.com/docs/mod_nss.html +

+

-sslsessionidcache + +
+Pass a 0 to disable TclCurl's use of SSL session-ID caching or a 1 to enable it. +By default all transfers are done using the cache. While nothing ever +should get hurt by attempting to reuse SSL session-IDs, there seem to be broken SSL +implementations in the wild that may require you to disable this in order for you to +succeed. +

+

-krblevel + +
+Set the kerberos security level for FTP, this also enables kerberos awareness. +This is a string, 'clear', 'safe', 'confidential' or 'private'. If the string +is set but does not match one of these, 'private' will be used. Set the string +to NULL to disable kerberos4. Set the string to "" to disable kerberos +support for FTP. +

+

-gssapidelegation + +
+Set the option to 'flag' to allow unconditional GSSAPI credential delegation. The delegation +is disabled by default since 7.21.7. Set the parameter to 'policyflag' to delegate only if +the OK-AS-DELEGATE flag is set in the service ticket in case this feature is supported by the +GSSAPI implementation and the definition of GSS_C_DELEG_POLICY_FLAG was available at compile-time. +

+

+

+  +

SSH options

+ +

+

+
-sshauthtypes + +
+The allowed types are: +

+

+
+
publickey + +
+
password + +
+
host + +
+
keyboard + +
+
any + +
+To let TclCurl pick one +
+
+ +

+

-sshhostpublickeymd5 + +
+Pass a string containing 32 hexadecimal digits. The string should be the 128 +bit MD5 cheksum of the remote host public key, and TclCurl will reject the +connection to the host unless the md5sums match. This option is only for SCP +and SFTP transfers. +

+

-publickeyfile + +
+Pass the file name for your public key. If not used, TclCurl defaults to using $HOME/.ssh/id_dsa.pub. +HOME environment variable is set, and just id_dsa in the current directory if not. +

+

-privatekeyfile + +
+Pass the file name for your private key. If not used, TclCurl defaults to using $HOME/.ssh/id_dsa.pub. +HOME environment variable is set, and just id_dsa in the current directory if not. +If the file is password-protected, set the password with -keypasswd. +

+

-sshknownhosts + +
+Pass a string holding the file name of the known_host file to use. The known_hosts +file should use the OpenSSH file format as supported by libssh2. If this file is +specified, TclCurl will only accept connections with hosts that are known and present +in that file, with a matching public key. Use -sshkeyproc to alter the default +behavior on host and key (mis)matching. +

+

-sshkeyproc + +
+Pass a the name of the procedure that will be called when the known_host matching has +been done, to allow the application to act and decide for TclCurl how to proceed. The +callback will only be called if -knownhosts is also set. +

+It gets passed a list with three elements, the first one is a list with the type of the +key from the known_hosts file and the key itself, the second is another list with +the type of the key from the remote site and the key itslef, the third tells you +what TclCurl thinks about the matching status. +

+The known key types are: "rsa", "rsa1" and "dss", in any other case "unknown" is given. +

+TclCurl opinion about how they match may be: "match", "mismatch", "missing" or "error". +

+The procedure must return: +

+
+
0 + +
+The host+key is accepted and TclCurl will append it to the known_hosts file before +continuing with the connection. This will also add the host+key combo to the known_host +pool kept in memory if it wasn't already present there. The adding of data to +the file is done by completely replacing the file with a new copy, so the permissions of +the file must allow this. +
1 + +
+The host+key is accepted, TclCurl will continue with the connection. This will also add +the host+key combo to the known_host pool kept in memory if it wasn't already present +there. +
2 + +
+The host+key is rejected. TclCurl will close the connection. +
3 + +
+The host+key is rejected, but the SSH connection is asked to be kept alive. This feature +could be used when the app wants to somehow return back and act on the host+key situation +and then retry without needing the overhead of setting it up from scratch again. +
+
+ +

+Any other value will cause the connection to be closed. +

+

+  +

Other options

+ +

+

+
-headervar + +
+Name of the Tcl array variable where TclCurl will store the headers returned +by the server. +

+

-bodyvar + +
+Name of the Tcl variable where TclCurl will store the file requested, the file +may contain text or binary data. +

+

-canceltransvar + +
+Name of a Tcl variable, in case you have defined a procedure to call with +-progressproc setting this variable to '1' will cancel the transfer. +

+

-command + +
+Executes the given command after the transfer is done, since it only works +with blocking transfers, it is pretty much useless. +

+

-share + +
+Pass a share handle as a parameter. The share handle must have been created by +a previous call to curl::shareinit. Setting this option, will make this +handle use the data from the shared handle instead of keeping the data to itself. +See tclcurl_share for details. +

+

-newfileperms + +
+Pass a number as a parameter, containing the value of the permissions that will +be assigned to newly created files on the remote server. The default value is 0644, +but any valid value can be used. The only protocols that can use this are sftp://, +scp:// and file://. +

+

-newdirectoryperms + +
+Pass a number as a parameter, containing the value of the permissions that will be +assigned to newly created directories on the remote server. The default value is 0755, +but any valid value can be used. The only protocols that can use this are sftp://, scp:// +and file://. +

+

+  +

Telnet options

+ +

+

+
-telnetoptions + +
+Pass a list with variables to pass to the telnet negotiations. The variables should be in +the format <option=value>. TclCurl supports the options 'TTYPE', 'XDISPLOC' and 'NEW_ENV'. +See the TELNET standard for details. +

+

+  +

NOT SUPPORTED

+ +Some of the options libcurl offers are not supported, I don't think them +worth supporting in TclCurl but if you need one of them don't forget to +complain: +

+CURLOPT_FRESH_CONNECT, CURLOPT_FORBID_REUSE, CURLOPT_PRIVATE, + +CURLOPT_SSL_CTX_FUNCTION, CURLOPT_SSL_CTX_DATA, CURLOPT_SSL_CTX_FUNCTION and + +CURLOPT_CONNECT_ONLY, CURLOPT_OPENSOCKETFUNCTION, CURLOPT_OPENSOCKETDATA. + +

+  +

curlHandle perform

+ +This procedure is called after the +init + +and all the +configure + +calls are made, and will perform the transfer as described in the options. +

+It must be called with the same +curlHandle curl::init call returned. +You can do any amount of calls to perform while using the same handle. If you +intend to transfer more than one file, you are even encouraged to do +so. TclCurl will then attempt to re-use the same connection for the following +transfers, thus making the operations faster, less CPU intense and using less +network resources. Just note that you will have to use +configure + +between the invokes to set options for the following perform. +

+You must never call this procedure simultaneously from two places using the +same handle. Let it return first before invoking it another time. If +you want parallel transfers, you must use several curl handles. +

+
RETURN VALUE + +
+ +errorbuffer + +was set with +configure + +there will be a readable error message. +The error codes are: +
1
+Unsupported protocol. This build of TclCurl has no support for this protocol. +
2
+Very early initialization code failed. This is likely to be and internal error +or a resource problem where something fundamental couldn't get done at init time. +
3
+URL malformat. The syntax was not correct. +
4
+A requested feature, protocol or option was not found built-in in this libcurl +due to a build-time decision. This means that a feature or option was not +enabled or explicitly disabled when libcurl was built and in order to get it +to function you have to get a rebuilt libcurl. +
5
+Couldn't resolve proxy. The given proxy host could not be resolved. +
6
+Couldn't resolve host. The given remote host was not resolved. +
7
+Failed to connect to host or proxy. +
8
+FTP weird server reply. The server sent data TclCurl couldn't parse. +The given remote server is probably not an OK FTP server. +
9
+We were denied access to the resource given in the URL. For FTP, this occurs +while trying to change to the remote directory. +
11
+FTP weird PASS reply. TclCurl couldn't parse the reply sent to the PASS request. +
13
+FTP weird PASV reply, TclCurl couldn't parse the reply sent to the PASV or EPSV +request. +
14
+FTP weird 227 format. TclCurl couldn't parse the 227-line the server sent. +
15
+FTP can't get host. Couldn't resolve the host IP we got in the 227-line. +
17
+FTP couldn't set type. Couldn't change transfer method to either binary or +ascii. +
18
+Partial file. Only a part of the file was transfered, this happens when +the server first reports an expected transfer size and then delivers data +that doesn't match the given size. +
19
+FTP couldn't RETR file, we either got a weird reply to a 'RETR' command or +a zero byte transfer. +
21
+Quote error. A custom 'QUOTE' returned error code 400 or higher (for FTP) or +otherwise indicated unsuccessful completion of the command. +
22
+HTTP returned error. This return code only appears if -failonerror is +used and the HTTP server returns an error code that is 400 or higher. +
23
+Write error. TclCurl couldn't write data to a local filesystem or an error +was returned from a write callback. +
25
+Failed upload failed. For FTP, the server typcially denied the STOR +command. The error buffer usually contains the server's explanation to this. +
26
+Read error. There was a problem reading from a local file or an error was returned +from the read callback. +
27
+Out of memory. A memory allocation request failed. This should never happen unless +something weird is going on in your computer. +
28
+Operation timeout. The specified time-out period was reached according to the +conditions. +
30
+The FTP PORT command failed, not all FTP servers support the PORT command, +try doing a transfer using PASV instead!. +
31
+FTP couldn't use REST. This command is used for resumed FTP transfers. +
33
+Range error. The server doesn't support or accept range requests. +
34
+HTTP post error. Internal post-request generation error. +
35
+SSL connect error. The SSL handshaking failed, the error buffer may have +a clue to the reason, could be certificates, passwords, ... +
36
+The download could not be resumed because the specified offset was out of the +file boundary. +
37
+A file given with FILE:// couldn't be read. Did you checked the permissions? +
38
+LDAP cannot bind. LDAP bind operation failed. +
39
+LDAP search failed. +
41
+A required zlib function was not found. +
42
+Aborted by callback. An application told TclCurl to abort the operation. +
43
+Internal error. A function was called with a bad parameter. +
45
+Interface error. A specified outgoing interface could not be used. +
47
+Too many redirects. When following redirects, TclCurl hit the maximum amount, set +your limit with --maxredirs +
48
+An option passed to TclCurl is not recognized/known. Refer to the appropriate +documentation. This is most likely a problem in the program that uses +TclCurl. The error buffer might contain more specific information about which +exact option it concerns. +
49
+A telnet option string was illegally formatted. +
51
+The remote peer's SSL certificate or SSH md5 fingerprint wasn't ok +
52
+The server didn't reply anything, which here is considered an error. +
53
+The specified crypto engine wasn't found. +
54
+Failed setting the selected SSL crypto engine as default! +
55
+Failed sending network data. +
56
+Failure with receiving network data. +
58
+Problem with the local client certificate. +
59
+Couldn't use specified SSL cipher. +
60
+Peer certificate cannot be authenticated with known CA certificates. +
61
+Unrecognized transfer encoding. +
62
+Invalid LDAP URL. +
63
+Maximum file size exceeded. +
64
+SSL use failed. +
65
+Sending the data requires a rewind that failed, since TclCurl should +take care of it for you, it means you found a bug. +
66
+Failed to initialise ssl engine. +
67
+Failed to login, user password or similar was not accepted. +
68
+File not found on TFTP server. +
69
+There is a permission problem with the TFTP request. +
70
+The remote server has run out of space. +
71
+Illegal TFTP operation. +
72
+Unknown transfer ID. +
73
+TFTP file already exists and will not be overwritten. +
74
+No such user in the TFTP server and good behaving TFTP servers +should never return this. +
75
+Character conversion failed. +
77
+Problem with reading the SSL CA cert (path? access rights?). +
78
+Remote file not found +
79
+Error from the SSH layer +
80
+Failed to shut down the SSL connection +
82
+Failed to load CRL file +
83
+Issuer check failed +
84
+The FTP server does not understand the PRET command at all or does not support +the given argument. Be careful when using -customrequest, a +custom LIST command will be sent with PRET CMD before PASV as well. +
85
+Mismatch of RTSP CSeq numbers. +
86
+Mismatch of RTSP Session Identifiers. +
87
+Unable to parse FTP file list (during FTP wildcard downloading). +
88
+Chunk callback reported error. +

+

+  +

curlHandle getinfo option

+ +Request internal information from the curl session with this procedure. +This procedure is intended to get used *AFTER* a performed transfer, +and can be relied upon only if the perform returns 0. Use +this function AFTER a performed transfer if you want to get +transfer-oriented data. +

+The following information can be extracted: +

+

+
effectiveurl + +
+Returns the last used effective URL. +

+

responsecode + +
+Returns the last received HTTP or FTP code. This will be zero if no server +response code has been received. Note that a proxy's CONNECT response should +be read with httpconnectcode and not this. +

+

httpconnectcode + +
+Returns the last received proxy response code to a CONNECT request. +

+

filetime + +
+Returns the remote time of the retrieved document (in number of seconds +since 1 jan 1970 in the GMT/UTC time zone). If you get -1, +it can be because of many reasons (unknown, the server hides it or the +server doesn't support the command that tells document time etc) and the time +of the document is unknown. +

+In order for this to work you have to set the -filetime option before +the transfer. +

+

namelookuptime + +
+Returns the time, in seconds, it took from the start until the name resolving +was completed. +

+

connecttime + +
+Returns the time, in seconds, it took from the start until the connect to the +remote host (or proxy) was completed. +

+

appconnecttime + +
+Returns the time, in seconds, it took from the start until the SSL/SSH +connect/handshake to the remote host was completed. This time is most often very +near to the PRETRANSFER time, except for cases such as HTTP pippelining where the +pretransfer time can be delayed due to waits in line for the pipeline and more. +

+

pretransfertime + +
+Returns the time, in seconds, it took from the start until the file transfer +is just about to begin. This includes all pre-transfer commands and +negotiations that are specific to the particular protocol(s) involved. +

+

starttransfertime + +
+Returns the time, in seconds, it took from the start until the first byte +is just about to be transfered. This includes the pretransfertime, +and also the time the server needs to calculate the result. +

+

totaltime + +
+Returns the total transaction time, in seconds, for the previous transfer, +including name resolving, TCP connect etc. +

+

redirecturl + +
+Returns the URL a redirect would take you to if you enable followlocation. +This can come very handy if you think using the built-in libcurl redirect logic +isn't good enough for you but you would still prefer to avoid implementing all +the magic of figuring out the new URL. +

+

redirecttime + +
+Returns the total time, in seconds, it took for all redirection steps +including name lookup, connect, pretransfer and transfer before +the final transaction was started, it returns the complete execution +time for multiple redirections, so it returns zero if no redirections +were needed. +

+

redirectcount + +
+Returns the total number of redirections that were actually followed. +

+

numconnects + +
+Returns how many new connections TclCurl had to create to achieve the +previous transfer (only the successful connects are counted). Combined +with redirectcount you are able to know how many times TclCurl +successfully reused existing connection(s) or not. See the Connection +Options of setopt to see how TclCurl tries to make persistent +connections to save time. +

+

primaryip + +
+Returns the IP address of the most recent connection done with this handle. +This string may be IPv6 if that's enabled. +

+

primaryport + +
+Returns the destination port of the most recent connection done with this handle. +

+

localip + +
+Returns the local (source) IP address of the most recent connection done +with this handle. This string may be IPv6 if that's enabled. +

+

localport + +
+Returns the local (source) port of the most recent connection done with this handle. +

+

sizeupload + +
+Returns the total amount of bytes that were uploaded. +

+

sizedownload + +
+Returns the total amount of bytes that were downloaded. The amount is only +for the latest transfer and will be reset again for each new transfer. +

+

speeddownload + +
+Returns the average download speed, measured in bytes/second, for the complete download. +

+

speedupload + +
+Returns the average upload speed, measured in bytes/second, for the complete upload. +

+

headersize + +
+Returns the total size in bytes of all the headers received. +

+

requestsize + +
+Returns the total size of the issued requests. This is so far only for HTTP +requests. Note that this may be more than one request if followLocation is true. +

+

sslverifyresult + +
+Returns the result of the certification verification that was requested +(using the -sslverifypeer option to configure). +

+

sslengines + +
+Returns a list of the OpenSSL crypto-engines supported. Note that engines are +normally implemented in separate dynamic libraries. Hence not all the returned +engines may be available at run-time. +

+

contentlengthdownload + +
+Returns the content-length of the download. This is the value read from the +Content-Length: + +field. If the size isn't known, it returns -1. +

+

contentlengthupload + +
+Returns the specified size of the upload. +

+

contenttype + +
+Returns the content-type of the downloaded object. This is the value +read from the Content-Type: field. If you get an empty string, it means +the server didn't send a valid Content-Type header or that the protocol +used doesn't support this. +

+

httpauthavail + +
+Returns a list with the authentication method(s) available. +

+

proxyauthavail + +
+Returns a list with the authentication method(s) available for your +proxy athentication. +

+

oserrno + +
+Returns the errno value from a connect failure. This value is only set on +failure, it is no reset after a successfull operation. +

+

cookielist + +
+Returns a list of all cookies TclCurl knows (expired ones, too). If there +are no cookies (cookies for the handle have not been enabled or simply +none have been received) the list will be empty. +

+

ftpentrypath + +
+Returns a string holding the path of the entry path. That is the initial path +TclCurl ended up in when logging on to the remote FTP server. Returns an empty +string if something is wrong. +

+

certinfo + +
+Returns list with information about the certificate chain, assuming you had the +-certinfo option enabled when the previous request was done. The list +first item reports how many certs it found and then you can extract info for each +of those certs by following the list. The info chain is provided in a series of data +in the format "name:content" where the content is for the specific named data. +

+NOTE: this option is only available in libcurl built with OpenSSL support. +

+

conditionunmet + +
+Returns the number 1 if the condition provided in the previous request +didn't match (see timecondition), you will get a zero if the condition +instead was met. +

+

+  +

curlHandle cleanup

+ +This procedure must be the last one to call for a curl session. It is the +opposite of the +curl::init + +procedure and must be called with the same +curlhandle + +as input as the curl::init call returned. +This will effectively close all connections TclCurl has used and possibly +has kept open until now. Don't call this procedure if you intend to transfer +more files. +

+  +

curlHandle reset

+ +

+Re-initializes all options previously set on a specified handle to the +default values. +

+This puts back the handle to the same state as it was in when it was just +created with curl::init. +

+It does not change the following information kept in the handle: live +connections, the Session ID cache, the DNS cache, the cookies and shares. +

+  +

curlHandle duphandle

+ +This procedure will return a new curl handle, a duplicate, +using all the options previously set in the input curl handle. +Both handles can subsequently be used independently and +they must both be freed with +cleanup. + +The new handle will not inherit any state information, +connections, SSL sessions or cookies. +
+
RETURN VALUE + +
+A new curl handle or an error message if the copy fails. +

+

+  +

curlHandle pause

+ +You can use this command from within a progress callback procedure +to pause the transfer. +

+  +

curlHandle resume

+ +Resumes a transfer paused with curlhandle pause +

+  +

curl::transfer

+ +In case you do not want to use persistant connections you can use this +command, it takes the same arguments as the curlHandle configure +and will init, configure, perform and cleanup a connection for you. +

+You can also get the getinfo information by using -infooption variable +pairs, after the transfer variable will contain the value that would have +been returned by $curlHandle getinfo option. +

+
RETURN VALUE + +
+The same error code perform would return. +

+

+  +

curl::version

+ +Returns a string with the version number of tclcurl, libcurl and some of +its important components (like OpenSSL version). +
+
RETURN VALUE + +
+The string with the version info. +

+

+  +

curl::escape url

+ +This procedure will convert the given input string to an URL encoded string and +return that. All input characters that are not a-z, +A-Z or 0-9 will be converted to their "URL escaped" version (%NN where NN is a +two-digit hexadecimal number) +
+
RETURN VALUE + +
+The converted string. +
+  +

curl::unescape url

+ +This procedure will convert the given URL encoded input string to a "plain +string" and return that. All input characters that +are URL encoded (%XX where XX is a two-digit hexadecimal number) will be +converted to their plain text versions. +
+
RETURN VALUE + +
+The string unencoded. +

+

+  +

curl::curlConfig option

+ +Returns some information about how you have +cURL + +installed. +

+

+
-prefix + +
+Returns the directory root where you installed +cURL + +
-feature + +
+Returns a list containing particular main features the installed +libcurl + +was built with. The list may include SSL, KRB4 or IPv6, do not +assume any particular order. +
-vernum + +
+Outputs version information about the installed libcurl, in +numerical mode. This outputs the version number, in hexadecimal, +with 8 bits for each part; major, minor, patch. So that libcurl +7.7.4 would appear as 070704 and libcurl 12.13.14 would appear as +0c0d0e... +

+

+  +

curl::versioninfo option

+ +Returns information about various run-time features in TclCurl. +

+Applications should use this information to judge if things are possible to do +or not, instead of using compile-time checks, as dynamic/DLL libraries can be +changed independent of applications. +

+

+
-version + +
+Returns the version of libcurl we are using. +

+

-versionnum + +
+Retuns the version of libcurl we are using in hexadecimal with 8 bits for each +part; major, minor, patch. So that libcurl 7.7.4 would appear as 070704 and +libcurl 12.13.14 would appear as 0c0d0e... Note that the initial zero might be +omitted. +

+

-host + +
+Returns a string with the host information as discovered by a configure +script or set by the build environment. +

+

-features + +
+Returns a list with the features compiled into libcurl, the possible elements are: +
+
+
ASYNCHDNS + +
+Libcurl was built with support for asynchronous name lookups, which allows +more exact timeouts (even on Windows) and less blocking when using the multi +interface. +
CONV + +
+Libcurl was built with support for character conversions. +
DEBUG + +
+Libcurl was built with extra debug capabilities built-in. This is mainly of +interest for libcurl hackers. +
GSSNEGOTIATE + +
+Supports HTTP GSS-Negotiate. +
IDN + +
+Supports IDNA, domain names with international letters. +
IPV6 + +
+Supports IPv6. +
KERBEROS4 + +
+Supports kerberos4 (when using FTP). +
LARGEFILE + +
+Libcurl was built with support for large files. +
LIBZ + +
+Supports HTTP deflate using libz. +
NTML + +
+Supports HTTP NTLM +
SPNEGO + +
+Libcurl was built with support for SPNEGO authentication (Simple and Protected +GSS-API Negotiation Mechanism, defined in RFC 2478) +
SSL + +
+Supports SSL (HTTPS/FTPS) +
SSPI + +
+Libcurl was built with support for SSPI. This is only available on Windows and +makes libcurl use Windows-provided functions for NTLM authentication. It also +allows libcurl to use the current user and the current user's password without +the app having to pass them on. +
TLSAUTH_SRP + +
+Libcurl was built with support for TLS-SRP. +NTLM_WB + +Libcurl was built with support for NTLM delegation to a winbind helper. +
+
+ +Do not assume any particular order. +

+

-sslversion + +
+Returns a string with the OpenSSL version used, like OpenSSL/0.9.6b. +

+

-sslversionnum + +
+Returns the numerical OpenSSL version value as defined by the OpenSSL project. +If libcurl has no SSL support, this is 0. +

+

-libzversion + +
+Returns a string, there is no numerical version, for example: 1.1.3. +

+

-protocols + +
+Lists what particular protocols the installed TclCurl was built to support. +At the time of writing, this list may include HTTP, HTTPS, FTP, FTPS, +FILE, TELNET, LDAP, DICT. Do not assume any particular order. The protocols +will be listed using uppercase. There may be none, one or several protocols +in the list. +

+

+  +

curl::easystrerror errorCode

+ +This procedure returns a string describing the error code passed in the argument. +

+  +

SEE ALSO

+ +curl, The art of HTTP scripting, RFC 2396, + +

+ +

+ 

Index

+
+
NAME
+
SYNOPSIS
+
DESCRIPTION
+
curl::init
+
curlHandle configure ?options?
+
Behaviour options
+
Callback options
+
Error Options
+
Network options
+
Names and Passwords options
+
HTTP options
+
SMTP options
+
TFTP option
+
FTP options
+
Protocol options
+
Connection options
+
SSL and security options
+
SSH options
+
Other options
+
Telnet options
+
NOT SUPPORTED
+
curlHandle perform
+
curlHandle getinfo option
+
curlHandle cleanup
+
curlHandle reset
+
curlHandle duphandle
+
curlHandle pause
+
curlHandle resume
+
curl::transfer
+
curl::version
+
curl::escape url
+
curl::unescape url
+
curl::curlConfig option
+
curl::versioninfo option
+
curl::easystrerror errorCode
+
SEE ALSO
+
+
+This document was created by man2html, using the manual pages.
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl new file mode 100644 index 00000000..3cb25968 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl @@ -0,0 +1,143 @@ +################################################################################ +################################################################################ +#### tclcurl.tcl +################################################################################ +################################################################################ +## Includes the tcl part of TclCurl +################################################################################ +################################################################################ +## (c) 2001-2011 Andres Garcia Garcia. fandom@telefonica.net +## See the file "license.terms" for information on usage and redistribution +## of this file and for a DISCLAIMER OF ALL WARRANTIES. +################################################################################ +################################################################################ + +namespace eval curl { + +################################################################################ +# configure +# Invokes the 'curl-config' script to be able to know what features have +# been compiled in the installed version of libcurl. +# Possible options are '-prefix', '-feature' and 'vernum' +################################################################################ +proc ::curl::curlConfig {option} { + + if {$::tcl_platform(platform)=="windows"} { + error "This command is not available in Windows" + } + + switch -exact -- $option { + -prefix { + return [exec curl-config --prefix] + } + -feature { + set featureList [exec curl-config --feature] + regsub -all {\\n} $featureList { } featureList + return $featureList + } + -vernum { + return [exec curl-config --vernum] + } + -ca { + return [exec curl-config --ca] + } + default { + error "bad option '$option': must be '-prefix', '-feature', '-vernum' or '-ca'" + } + } + return +} + +################################################################################ +# transfer +# The transfer command is used for simple transfers in which you don't +# want to request more than one file. +# +# Parameters: +# Use the same parameters you would use in the 'configure' command to +# configure the download and the same as in 'getinfo' with a 'info' +# prefix to get info about the transfer. +################################################################################ +proc ::curl::transfer {args} { + variable getInfo + variable curlBodyVar + + set i 0 + set newArgs "" + catch {unset getInfo} + + if {[llength $args]==0} { + puts "No transfer configured" + return + } + + foreach {option value} $args { + set noPassOption 0 + set block 1 + switch -regexp -- $option { + -info.* { + set noPassOption 1 + regsub -- {-info} $option {} option + set getInfo($option) $value + } + -block { + set noPassOption 1 + set block $value + } + -bodyvar { + upvar $value curlBodyVar + set value curlBodyVar + } + -headervar { + upvar $value curlHeaderVar + set value curlHeaderVar + } + -errorbuffer { + upvar $value curlErrorVar + set value curlErrorVar + } + } + if {$noPassOption==0} { + lappend newArgs $option $value + } + } + + if {[catch {::curl::init} curlHandle]} { + error "Could not init a curl session: $curlHandle" + } + + if {[catch {eval $curlHandle configure $newArgs} result]} { + $curlHandle cleanup + error $result + } + + if {$block==1} { + if {[catch {$curlHandle perform} result]} { + $curlHandle cleanup + error $result + } + if {[info exists getInfo]} { + foreach {option var} [array get getInfo] { + upvar $var info + set info [eval $curlHandle getinfo $option] + } + } + if {[catch {$curlHandle cleanup} result]} { + error $result + } + } else { + # We create a multiHandle + set multiHandle [curl::multiinit] + + # We add the easy handle to the multi handle. + $multiHandle addhandle $curlHandle + + # So now we create the event source passing the multiHandle as a parameter. + curl::createEventSource $multiHandle + + # And we return, it is non blocking after all. + } + return 0 +} + +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html new file mode 100644 index 00000000..02b23614 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html @@ -0,0 +1,320 @@ +Manpage of TclCurl + +

TclCurl

+Section: TclCurl Multi Interface (3)
Updated: 03 September 2011
+ +  +

NAME

+ +TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP, +LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax. +  +

SYNOPSIS

+ +curl::multiinit + +

+multiHandle addhandle + +

+multiHandle removehandle + +

+multiHandle configure + +

+multiHandle perform + +

+multiHandle active + +

+multiHandle getinfo + +

+multihandle cleanup + +

+multihandle auto + +

+curl::multistrerror errorCode + +

+  +

DESCRIPTION

+ +TclCurl's multi interface introduces several new abilities that the easy +interface refuses to offer. They are mainly: +
    +
  • Enable a "pull" interface. The application that uses TclCurl decides where +and when to get/send data.

    +
  • Enable multiple simultaneous transfers in the same thread without making it +complicated for the application.

    +
  • Keep Tk GUIs 'alive' while transfers are taking place.

    +
+

+ +  +

Blocking

+ +A few areas in the code are still using blocking code, even when used from the +multi interface. While we certainly want and intend for these to get fixed in +the future, you should be aware of the following current restrictions: +
    +
  • Name resolves on non-windows unless c-ares is used. + +
  • GnuTLS SSL connections. + +
  • Active FTP connections. + +
  • HTTP proxy CONNECT operations. + +
  • SCP and SFTP connections. + +
  • SFTP transfers. + +
  • TFTP transfers + +
  • file:// transfers. +
+ +

+  +

curl::multiinit

+ +This procedure must be the first one to call, it returns a multiHandle +that you need to use to invoke TclCurl procedures. The init MUST have a +corresponding call to cleanup when the operation is completed. +

+RETURN VALUE + +

+multiHandle + +to use. +

+  +

multiHandle addhandle ?easyHandle?

+ +

+Each single transfer is built up with an 'easy' handle, the kind we have been +using so far with TclCurl, you must create them and setup the appropriate +options for each of them. Then we add them to the 'multi stack' using the +addhandle command. +

+If the easy handle is not set to use a shared or global DNS cache, it will be made +to use the DNS cache that is shared between all easy handles within the multi handle. +

+When an easy handle has been added to a multi stack, you can not and you must not use +perform on that handle! +

+

+multiHandle + +is the return code from the curl::multiinit call. +

+RETURN VALUE + +The possible return values are: +

+
-1
+Handle added to the multi stack, please call +perform + +soon +
0
+Handle added ok. +
1
+Invalid multi handle. +
2
+Invalid 'easy' handle. It could mean that it isn't an easy handle at all, or possibly that +the handle already is in used by this or another multi handle. +
3
+Out of memory, you should never get this. +
4
+You found a bug in TclCurl. +

+

+  +

multiHandle removehandle ?easyHandle?

+ +

+When a transfer is done or if we want to stop a transfer before it is completed, +we can use the removehandle command. Once removed from the multi handle, +we can again use other easy interface functions on it. +

+Please note that when a single transfer is completed, the easy handle is still +left added to the multi stack. You need to remove it and then close or, possibly, +set new options to it and add it again to the multi handle to start another transfer. +

+

+RETURN VALUE + +The possible return values are: +

+
0
+Handle removed ok. +
1
+Invalid multi handle. +
2
+Invalid 'easy' handle. +
3
+Out of memory, you should never get this. +
4
+You found a bug in TclCurl. +

+

+  +

multiHandle configure

+ +So far the only option is: +
+
-pipelining + +
+Pass a 1 to enable or 0 to disable. Enabling pipelining on a multi handle will +make it attempt to perform HTTP Pipelining as far as possible for transfers using +this handle. This means that if you add a second request that can use an already +existing connection, the second request will be "piped" on the same connection +rather than being executed in parallel. +
-maxconnects + +
+Pass a number which will be used as the maximum amount of simultaneously open +connections that TclCurl may cache. Default is 10, and TclCurl will enlarge +the size for each added easy handle to make it fit 4 times the number of added +easy handles. +

+By setting this option, you can prevent the cache size to grow beyond the limit +set by you. When the cache is full, curl closes the oldest one in the cache to +prevent the number of open connections to increase. +

+This option is for the multi handle's use only, when using the easy interface you should instead use it's own maxconnects option. +

+

+  +

multiHandle perform

+ +Adding the easy handles to the multi stack does not start any transfer. +Remember that one of the main ideas with this interface is to let your +application drive. You drive the transfers by invoking +perform. + +TclCurl will then transfer data if there is anything available to transfer. +It'll use the callbacks and everything else we have setup in the individual +easy handles. It'll transfer data on all current transfers in the multi stack +that are ready to transfer anything. It may be all, it may be none. +

+When you call perform and the amount of Irunning handles is +changed from the previous call (or is less than the amount of easy handles +you added to the multi handle), you know that there is one or more +transfers less "running". You can then call getinfo to +get information about each individual completed transfer. +

+RETURN VALUE + +If everything goes well, it returns the number of running handles, '0' if all +are done. In case of error, it will return the error code. +

+  +

multiHandle active

+ +In order to know if any of the easy handles are ready to transfer data before +invoking +perform + +you can use the +active + +command, it will return the number of transfers currently active. +

+RETURN VALUE + +The number of active transfers or '-1' in case of error. +

+  +

multiHandle getinfo

+ +This procedure returns very simple information about the transfers, you +can get more detail information using the getinfo +command on each of the easy handles. +

+

+RETURN VALUE + +A list with the following elements: +

+
easyHandle about which the info is about.
+
state of the transfer, '1' if it is done.
+
exit code of the transfer, '0' if there was no error,...
+
Number of messages still in the info queue.
+
In case there are no messages in the queue it will return {"" 0 0 0}.
+

+

+  +

multiHandle cleanup

+ +This procedure must be the last one to call for a multi stack, it is the opposite of the +curl::multiinit + +procedure and must be called with the same +multiHandle + +as input as the +curl::multiinit + +call returned. +

+  +

multiHandle auto ?-command command?

+ +Using this command Tcl's event loop will take care of periodically invoking perform +for you, before using it, you must have already added at least one easy handle to +the multi handle. +

+The command option allows you to specify a command to invoke after all the easy +handles have finished their transfers, even though I say it is an option, the truth is +you must use this command to cleanup all the handles, otherwise the transfered files +may not be complete. +

+This support is still in a very experimental state, it may still change without warning. +Any and all comments are welcome. +

+You can find a couple of examples at tests/multi. +

+  +

curl::multistrerror errorCode

+ +This procedure returns a string describing the error code passed in the argument. +

+  +

SEE ALSO

+ +tclcurl, curl. + +

+ +

+ 

Index

+
+
NAME
+
SYNOPSIS
+
DESCRIPTION
+
Blocking
+
curl::multiinit
+
multiHandle addhandle ?easyHandle?
+
multiHandle removehandle ?easyHandle?
+
multiHandle configure
+
multiHandle perform
+
multiHandle active
+
multiHandle getinfo
+
multiHandle cleanup
+
multiHandle auto ?-command command?
+
curl::multistrerror errorCode
+
SEE ALSO
+
+
+This document was created by man2html, using the manual pages.
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html new file mode 100644 index 00000000..8f3d8389 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html @@ -0,0 +1,112 @@ +Manpage of TclCurl + +

TclCurl

+Section: TclCurl share data api (3)
Updated: 03 October 2011
+ +  +

NAME

+TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP, +LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax. +  +

SYNOPSIS

+ +curl::shareinit + +

+shareHandle share ?data? + +

+shareHandle unshare ?data? + +

+shareHandle cleanup + +

+curl::sharestrerror errorCode + +

+

+  +

DESCRIPTION

+ +

+With the share API, you can have two or more 'easy' handles sharing data +among them, so far they can only share cookies and DNS data. +

+  +

curl::shareinit

+ +This procedure must be the first one to call, it returns a shareHandle +that you need to use to share data among handles using the -share option +to the configure command. The init MUST have a corresponding call to +cleanup when the operation is completed. +

+RETURN VALUE + +

+shareHandle to use. +

+  +

shareHandle share ?data?

+ +

+The parameter specifies a type of data that should be shared. This may be set +to one of the values described below: +

+

+
+
cookies + +
+Cookie data will be shared across the easy handles using this shared object. +

+

dns + +
+Cached DNS hosts will be shared across the easy handles using this shared object. +
+
+ +

+  +

shareHandle unshare ?data?

+ +This command does the opposite of share. The specified parameter will no +longer be shared. Valid values are the same as those for share. +

+  +

sharehandle cleanup

+ +

+Deletes a shared object. The share handle cannot be used anymore after this +function has been called. +

+  +

curl::sharestrerror errorCode

+ +Returns a string describing the error code passed in the argument. +

+  +

SEE ALSO

+ +curl, TclCurl + +

+ +

+ 

Index

+
+
NAME
+
SYNOPSIS
+
DESCRIPTION
+
curl::shareinit
+
shareHandle share ?data?
+
shareHandle unshare ?data?
+
sharehandle cleanup
+
curl::sharestrerror errorCode
+
SEE ALSO
+
+
+This document was created by man2html, using the manual pages.
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl new file mode 100644 index 00000000..84c74113 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl @@ -0,0 +1,386 @@ +# +# Critcl - build C extensions on-the-fly +# +# Copyright (c) 2001-2007 Jean-Claude Wippler +# Copyright (c) 2002-2007 Steve Landers +# +# See http://wiki.tcl.tk/critcl +# +# This is the Critcl runtime that loads the appropriate +# shared library when a package is requested +# + +namespace eval ::critcl::runtime {} + +proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} { + # XXX At least parts of this can be done by the package generator, + # XXX like listing the Tcl files to source. The glob here allows + # XXX code-injection after-the-fact, by simply adding a .tcl in + # XXX the proper place. + set path [file join $dir [MapPlatform $mapping]] + set ext [info sharedlibextension] + set lib [file join $path $libname$ext] + set provide [list] + + # Now the runtime equivalent of a series of 'preFetch' commands. + if {[llength $args]} { + set preload [file join $path preload$ext] + foreach p $args { + set prelib [file join $path $p$ext] + if {[file readable $preload] && [file readable $prelib]} { + lappend provide [list load $preload];# XXX Move this out of the loop, do only once. + lappend provide [list ::critcl::runtime::preload $prelib] + } + } + } + + lappend provide [list load $lib $initfun] + foreach t $tsrc { + lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]" + } + lappend provide "package provide $package $version" + package ifneeded $package $version [join $provide "\n"] + return +} + +proc ::critcl::runtime::preFetch {path ext dll} { + set preload [file join $path preload$ext] + if {![file readable $preload]} return + + set prelib [file join $path $dll$ext] + if {![file readable $prelib]} return + + load $preload ; # Defines next command. + ::critcl::runtime::preload $prelib + return +} + +proc ::critcl::runtime::Fetch {dir t} { + # The 'Ignore' disables compile & run functionality. + + # Background: If the regular critcl package is already loaded, and + # this prebuilt package uses its defining .tcl file also as a + # 'tsources' then critcl might try to collect data and build it + # because of the calls to its API, despite the necessary binaries + # already being present, just not in the critcl cache. That is + # redundant in the best case, and fails in the worst case (no + # compiler), preventing the use o a perfectly fine package. The + # 'ignore' call now tells critcl that it should ignore any calls + # made to it by the sourced files, and thus avoids that trouble. + + # The other case, the regular critcl package getting loaded after + # this prebuilt package is irrelevant. At that point the tsources + # were already run, and used the dummy procedures defined in the + # critcl-rt.tcl, which ignore the calls by definition. + + set t [file join $dir tcl $t] + ::critcl::Ignore $t + uplevel #0 [list source $t] + return +} + +proc ::critcl::runtime::precopy {dll} { + # This command is only used on Windows when preloading out of a + # VFS that doesn't support direct loading (usually, a Starkit) + # - we preserve the dll name so that dependencies are satisfied + # - The critcl::runtime::preload command is defined in the supporting + # "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c" + + global env + if {[info exists env(TEMP)]} { + set dir $env(TEMP) + } elseif {[info exists env(TMP)]} { + set dir $env(TMP) + } elseif {[file exists $env(HOME)]} { + set dir $env(HOME) + } else { + set dir . + } + set dir [file join $dir TCL[pid]] + set i 0 + while {[file exists $dir]} { + append dir [incr i] + } + set new [file join $dir [file tail $dll]] + file mkdir $dir + file copy $dll $new + return $new +} + +proc ::critcl::runtime::MapPlatform {{mapping {}}} { + # A sibling of critcl::platform that applies the platform mapping + + set platform [::platform::generic] + set version $::tcl_platform(osVersion) + if {[string match "macosx-*" $platform]} { + # "normalize" the osVersion to match OSX release numbers + set v [split $version .] + set v1 [lindex $v 0] + set v2 [lindex $v 1] + incr v1 -4 + set version 10.$v1.$v2 + } else { + # Strip trailing non-version info + regsub -- {-.*$} $version {} version + } + foreach {config map} $mapping { + if {![string match $config $platform]} continue + set minver [lindex $map 1] + if {[package vcompare $version $minver] < 0} continue + set platform [lindex $map 0] + break + } + return $platform +} + +# Dummy implementation of the critcl package, if not present +if {![llength [info commands ::critcl::Ignore]]} { + namespace eval ::critcl {} + proc ::critcl::Ignore {args} { + namespace eval ::critcl::v {} + set ::critcl::v::ignore([file normalize [lindex $args 0]]) . + } +} +if {![llength [info commands ::critcl::api]]} { + namespace eval ::critcl {} + proc ::critcl::api {args} {} +} +if {![llength [info commands ::critcl::at]]} { + namespace eval ::critcl {} + proc ::critcl::at {args} {} +} +if {![llength [info commands ::critcl::cache]]} { + namespace eval ::critcl {} + proc ::critcl::cache {args} {} +} +if {![llength [info commands ::critcl::ccode]]} { + namespace eval ::critcl {} + proc ::critcl::ccode {args} {} +} +if {![llength [info commands ::critcl::ccommand]]} { + namespace eval ::critcl {} + proc ::critcl::ccommand {args} {} +} +if {![llength [info commands ::critcl::cdata]]} { + namespace eval ::critcl {} + proc ::critcl::cdata {args} {} +} +if {![llength [info commands ::critcl::cdefines]]} { + namespace eval ::critcl {} + proc ::critcl::cdefines {args} {} +} +if {![llength [info commands ::critcl::cflags]]} { + namespace eval ::critcl {} + proc ::critcl::cflags {args} {} +} +if {![llength [info commands ::critcl::cheaders]]} { + namespace eval ::critcl {} + proc ::critcl::cheaders {args} {} +} +if {![llength [info commands ::critcl::check]]} { + namespace eval ::critcl {} + proc ::critcl::check {args} {return 0} +} +if {![llength [info commands ::critcl::cinit]]} { + namespace eval ::critcl {} + proc ::critcl::cinit {args} {} +} +if {![llength [info commands ::critcl::clibraries]]} { + namespace eval ::critcl {} + proc ::critcl::clibraries {args} {} +} +if {![llength [info commands ::critcl::compiled]]} { + namespace eval ::critcl {} + proc ::critcl::compiled {args} {return 1} +} +if {![llength [info commands ::critcl::compiling]]} { + namespace eval ::critcl {} + proc ::critcl::compiling {args} {return 0} +} +if {![llength [info commands ::critcl::config]]} { + namespace eval ::critcl {} + proc ::critcl::config {args} {} +} +if {![llength [info commands ::critcl::cproc]]} { + namespace eval ::critcl {} + proc ::critcl::cproc {args} {} +} +if {![llength [info commands ::critcl::csources]]} { + namespace eval ::critcl {} + proc ::critcl::csources {args} {} +} +if {![llength [info commands ::critcl::debug]]} { + namespace eval ::critcl {} + proc ::critcl::debug {args} {} +} +if {![llength [info commands ::critcl::done]]} { + namespace eval ::critcl {} + proc ::critcl::done {args} {return 1} +} +if {![llength [info commands ::critcl::failed]]} { + namespace eval ::critcl {} + proc ::critcl::failed {args} {return 0} +} +if {![llength [info commands ::critcl::framework]]} { + namespace eval ::critcl {} + proc ::critcl::framework {args} {} +} +if {![llength [info commands ::critcl::include]]} { + namespace eval ::critcl {} + proc ::critcl::include {args} {} +} +if {![llength [info commands ::critcl::ldflags]]} { + namespace eval ::critcl {} + proc ::critcl::ldflags {args} {} +} +if {![llength [info commands ::critcl::license]]} { + namespace eval ::critcl {} + proc ::critcl::license {args} {} +} +if {![llength [info commands ::critcl::load]]} { + namespace eval ::critcl {} + proc ::critcl::load {args} {return 1} +} +if {![llength [info commands ::critcl::make]]} { + namespace eval ::critcl {} + proc ::critcl::make {args} {} +} +if {![llength [info commands ::critcl::meta]]} { + namespace eval ::critcl {} + proc ::critcl::meta {args} {} +} +if {![llength [info commands ::critcl::platform]]} { + namespace eval ::critcl {} + proc ::critcl::platform {args} {} +} +if {![llength [info commands ::critcl::preload]]} { + namespace eval ::critcl {} + proc ::critcl::preload {args} {} +} +if {![llength [info commands ::critcl::source]]} { + namespace eval ::critcl {} + proc ::critcl::source {args} {} +} +if {![llength [info commands ::critcl::tcl]]} { + namespace eval ::critcl {} + proc ::critcl::tcl {args} {} +} +if {![llength [info commands ::critcl::tk]]} { + namespace eval ::critcl {} + proc ::critcl::tk {args} {} +} +if {![llength [info commands ::critcl::tsources]]} { + namespace eval ::critcl {} + proc ::critcl::tsources {args} {} +} +if {![llength [info commands ::critcl::userconfig]]} { + namespace eval ::critcl {} + proc ::critcl::userconfig {args} {} +} + +# Define a clone of platform::generic, if needed +if {![llength [info commands ::platform::generic]]} { + namespace eval ::platform {} + proc ::platform::generic {} { + global tcl_platform + + set plat [string tolower [lindex $tcl_platform(os) 0]] + set cpu $tcl_platform(machine) + + switch -glob -- $cpu { + sun4* { + set cpu sparc + } + intel - + ia32* - + i*86* { + set cpu ix86 + } + x86_64 { + if {$tcl_platform(wordSize) == 4} { + # See Example <1> at the top of this file. + set cpu ix86 + } + } + ppc - + "Power*" { + set cpu powerpc + } + "arm*" { + set cpu arm + } + ia64 { + if {$tcl_platform(wordSize) == 4} { + append cpu _32 + } + } + } + + switch -glob -- $plat { + windows { + if {$tcl_platform(platform) eq "unix"} { + set plat cygwin + } else { + set plat win32 + } + if {$cpu eq "amd64"} { + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 + } + } + sunos { + set plat solaris + if {[string match "ix86" $cpu]} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } elseif {![string match "ia64*" $cpu]} { + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + darwin { + set major [lindex [split $tcl_platform(osVersion) .] 0] + if {$major > 19} { + set plat macos + } else { + set plat macosx + } + # Correctly identify the cpu when running as a 64bit + # process on a machine with a 32bit kernel + if {$cpu eq "ix86"} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } + } + aix { + set cpu powerpc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + hp-ux { + set plat hpux + if {![string match "ia64*" $cpu]} { + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + osf1 { + set plat tru64 + } + default { + set plat [lindex [split $plat _-] 0] + } + } + + return "${plat}-${cpu}" + } +} + + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/license.terms b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/license.terms new file mode 100644 index 00000000..6975e4c9 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/license.terms @@ -0,0 +1 @@ +<> diff --git a/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl new file mode 100644 index 00000000..cdb609a9 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 9.0]} {return} +package ifneeded ankh 1.1 "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "ankh$ext"] ; load $lib Ankh ; ::critcl::runtime::Fetch $dir policy_1.tcl ; package provide ankh 1.1 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]" diff --git a/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl new file mode 100644 index 00000000..6c7192de --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl @@ -0,0 +1,47 @@ +# -*- tcl -*- +## Ankh - Andreas Kupries Hashes +## (c) 2021-2024 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries + +# Generate the public ensemble structure from the low-level hash commands. + +# # ## ### ##### ######## ############# + +foreach hash { + aich + blake2b blake2s + btih + ed2k + edonr/224 edonr/256 edonr/384 edonr/512 + gost12/256 gost12/512 + gost94 + has160 + md4 + md5 + ripemd160 + sha1 + sha2/224 sha2/256 sha2/384 sha2/512 + sha3/224 sha3/256 sha3/384 sha3/512 + snefru/128 snefru/256 + tiger + tth + whirlpool +} { + namespace eval ::ak::hash [list namespace export $hash] + # All the aggregated commands are defined as cprocs and cconsts. + namespace eval ::ak::hash::${hash} { + namespace export path channel string size references + namespace ensemble create + } +} + +namespace eval ::ak::hash { + namespace export list version + namespace ensemble create +} +namespace eval ::ak { + namespace export hash + namespace ensemble create +} + +# # ## ### ##### ######## ############# +return diff --git a/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/teapot.txt b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/teapot.txt new file mode 100644 index 00000000..cd2b1d9c --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/teapot.txt @@ -0,0 +1,17 @@ +Package ankh 1.1 +Meta platform win32-x86_64 +Meta build::date 2025-12-14 +Meta generated::by {critcl 3.3.1} ashok +Meta generated::date critcl +Meta require critcl::cutil +Meta license Under a BSD license. +Meta author {Andreas Kupries} +Meta summary Commands for using a variety of cryptographically secure +Meta summary hash functions +Meta description This package provides a number of commands giving +Meta description access to a variety of cryptographically secure hash +Meta description functions, old and new. +Meta subject hash {cryptographically secure hash} {secure hash} md4 md5 +Meta subject sha1 sha2 sha3 haval ripemd +Meta included tcl/policy_1.tcl critcl-rt.tcl win32-x86_64/ankh.dll +Meta entrytclcommand {eval "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "ankh$ext"] ; load $lib Ankh ; ::critcl::runtime::Fetch $dir policy_1.tcl ; package provide ankh 1.1 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll new file mode 100644 index 00000000..60046247 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/LICENSE b/src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/LICENSE similarity index 100% rename from src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/LICENSE rename to src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/LICENSE diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl similarity index 94% rename from src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/pkgIndex.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl index 1699948f..0f266406 100644 --- a/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/pkgIndex.tcl +++ b/src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl @@ -1,32 +1,32 @@ -# -# Tcl package index file - generated from pkgIndex.tcl.in -# - -package ifneeded cffi 2.0.3 \ - [list apply [list {dir} { - package require platform - set package_ns ::cffi - set initName [string totitle cffi] - if {[package vsatisfies [package require Tcl] 9]} { - set fileName "tcl9cffi203.dll" - } else { - set fileName "cffi203.dll" - } - set platformId [platform::identify] - set searchPaths [list [file join $dir $platformId] \ - {*}[lmap platformId [platform::patterns $platformId] { - file join $dir $platformId - }] \ - $dir] - foreach path $searchPaths { - set lib [file join $path $fileName] - if {[file exists $lib]} { - uplevel #0 [list load $lib $initName] - # Load was successful - set ${package_ns}::dll_path $lib - set ${package_ns}::package_dir $dir - return - } - } - error "Could not locate $fileName in directories [join $searchPaths {, }]" - }] $dir] +# +# Tcl package index file - generated from pkgIndex.tcl.in +# + +package ifneeded cffi 2.0.3 \ + [list apply [list {dir} { + package require platform + set package_ns ::cffi + set initName [string totitle cffi] + if {[package vsatisfies [package require Tcl] 9]} { + set fileName "tcl9cffi203.dll" + } else { + set fileName "cffi203t.dll" + } + set platformId [platform::identify] + set searchPaths [list [file join $dir $platformId] \ + {*}[lmap platformId [platform::patterns $platformId] { + file join $dir $platformId + }] \ + $dir] + foreach path $searchPaths { + set lib [file join $path $fileName] + if {[file exists $lib]} { + uplevel #0 [list load $lib $initName] + # Load was successful + set ${package_ns}::dll_path $lib + set ${package_ns}::package_dir $dir + return + } + } + error "Could not locate $fileName in directories [join $searchPaths {, }]" + }] $dir] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll b/src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll new file mode 100644 index 00000000..cb9396d5 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclConfig.sh b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclConfig.sh deleted file mode 100644 index 54db7151..00000000 --- a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclConfig.sh +++ /dev/null @@ -1,67 +0,0 @@ -# itclConfig.sh -- -# -# This shell script (for sh) is generated automatically by Itcl's -# configure script. It will create shell variables for most of -# the configuration options discovered by the configure script. -# This script is intended to be included by the configure scripts -# for Itcl extensions so that they don't have to figure this all -# out for themselves. This file does not duplicate information -# already provided by tclConfig.sh, so you may need to use that -# file in addition to this one. -# -# The information in this file is specific to a single platform. - -# Itcl's version number. -itcl_VERSION='4.3.2' -ITCL_VERSION='4.3.2' - -# The name of the Itcl library (may be either a .a file or a shared library): -itcl_LIB_FILE=tcl9itcl432.dll -ITCL_LIB_FILE=tcl9itcl432.dll - -# String to pass to linker to pick up the Itcl library from its -# build directory. -itcl_BUILD_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litcl432' -ITCL_BUILD_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litcl432' - -# String to pass to linker to pick up the Itcl library from its -# installed directory. -itcl_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litcl432' -ITCL_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litcl432' - -# The name of the Itcl stub library (a .a file): -itcl_STUB_LIB_FILE=libitclstub.a -ITCL_STUB_LIB_FILE=libitclstub.a - -# String to pass to linker to pick up the Itcl stub library from its -# build directory. -itcl_BUILD_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litclstub' -ITCL_BUILD_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litclstub' - -# String to pass to linker to pick up the Itcl stub library from its -# installed directory. -itcl_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litclstub' -ITCL_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litclstub' - -# String to pass to linker to pick up the Itcl stub library from its -# build directory. -itcl_BUILD_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2/libitclstub.a' -ITCL_BUILD_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2/libitclstub.a' - -# String to pass to linker to pick up the Itcl stub library from its -# installed directory. -itcl_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2/libitclstub.a' -ITCL_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2/libitclstub.a' - -# Location of the top-level source directories from which [incr Tcl] -# was built. This is the directory that contains generic, unix, etc. -# If [incr Tcl] was compiled in a different place than the directory -# containing the source files, this points to the location of the sources, -# not the location where [incr Tcl] was compiled. -itcl_SRC_DIR='/c/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2' -ITCL_SRC_DIR='/c/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2' - -# String to pass to the compiler so that an extension can -# find installed Itcl headers. -itcl_INCLUDE_SPEC='' -ITCL_INCLUDE_SPEC='' diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/libitclstub.a b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/libitclstub.a deleted file mode 100644 index 26da70f6..00000000 Binary files a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/libitclstub.a and /dev/null differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/pkgIndex.tcl deleted file mode 100644 index 236536ab..00000000 --- a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/pkgIndex.tcl +++ /dev/null @@ -1,14 +0,0 @@ -# -*- tcl -*- -# Tcl package index file, version 1.1 -# - -if {![package vsatisfies [package provide Tcl] 8.6-]} {return} - -if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded itcl 4.3.2 \ - [list load [file join $dir tcl9itcl432.dll] Itcl] -} else { - package ifneeded itcl 4.3.2 \ - [list load [file join $dir itcl432.dll] Itcl] -} -package ifneeded Itcl 4.3.2 [list package require -exact itcl 4.3.2] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/tcl9itcl432.dll b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/tcl9itcl432.dll deleted file mode 100644 index ee0598dd..00000000 Binary files a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/tcl9itcl432.dll and /dev/null differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itcl.tcl b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itcl.tcl similarity index 100% rename from src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itcl.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itcl.tcl diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclHullCmds.tcl b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclHullCmds.tcl similarity index 100% rename from src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclHullCmds.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclHullCmds.tcl diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclWidget.tcl b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclWidget.tcl similarity index 100% rename from src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclWidget.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclWidget.tcl diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclstub.lib b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclstub.lib new file mode 100644 index 00000000..247402a5 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclstub.lib differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/pkgIndex.tcl new file mode 100644 index 00000000..677629ab --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/pkgIndex.tcl @@ -0,0 +1,14 @@ +# -*- tcl -*- +# Tcl package index file, version 1.1 +# + +if {![package vsatisfies [package provide Tcl] 8.6-]} {return} + +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded itcl 4.3.5 \ + [list load [file join $dir tcl9itcl435.dll] Itcl] +} else { + package ifneeded itcl 4.3.5 \ + [list load [file join $dir itcl435.dll] Itcl] +} +package ifneeded Itcl 4.3.5 [list package require -exact itcl 4.3.5] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/tcl9itcl435.dll b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/tcl9itcl435.dll new file mode 100644 index 00000000..531b92d1 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/tcl9itcl435.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/test_Itcl_CreateObject.tcl b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/test_Itcl_CreateObject.tcl new file mode 100644 index 00000000..c70a154f --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/test_Itcl_CreateObject.tcl @@ -0,0 +1,26 @@ +# this is a program for testing the stubs interface ItclCreateObject. +# it uses itclTestRegisterC.c with the call C function functionality, +# so it also tests that feature. +# you need to define in Makefile CFLAGS: -DITCL_DEBUG_C_INTERFACE +# for makeing that work. +package require itcl + +::itcl::class ::c1 { + public method c0 {args} @cArgFunc + public method m1 { args } { puts "Hello Tcl $args" } +} + +set obj1 [::c1 #auto ] +$obj1 m1 World + +# C method cargFunc implements a call to Itcl_CreateObject! +# +# args for method c0 of class ::c1 +# arg1 does not matter +# arg2 is the class name +# arg3 is the full class name (full path name) +# arg4 is the object name of the created Itcl object +set obj2 [$obj1 c0 ::itcl::parser::handleClass ::c1 ::c1 ::c1::c11] +# test, if it is working! +$obj2 m1 Folks + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl new file mode 100644 index 00000000..2185fad5 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {[package vsatisfies [package provide Tcl] 9.0-]} { +package ifneeded sqlite3 3.51.0 [list load [file join $dir tcl9sqlite3510.dll] [string totitle sqlite3]] +} else { +package ifneeded sqlite3 3.51.0 [list load [file join $dir sqlite3510t.dll] [string totitle sqlite3]] +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n b/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n new file mode 100644 index 00000000..13913e55 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n @@ -0,0 +1,15 @@ +.TH sqlite3 n 4.1 "Tcl-Extensions" +.HS sqlite3 tcl +.BS +.SH NAME +sqlite3 \- an interface to the SQLite3 database engine +.SH SYNOPSIS +\fBsqlite3\fI command_name ?filename?\fR +.br +.SH DESCRIPTION +SQLite3 is a self-contains, zero-configuration, transactional SQL database +engine. This extension provides an easy to use interface for accessing +SQLite database files from Tcl. +.PP +For full documentation see \fIhttp://www.sqlite.org/\fR and +in particular \fIhttp://www.sqlite.org/tclsqlite.html\fR. diff --git a/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll b/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll new file mode 100644 index 00000000..91b343f3 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/README.md b/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/README.md deleted file mode 100644 index 0d9c793a..00000000 --- a/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/README.md +++ /dev/null @@ -1,40 +0,0 @@ -# Tcl cffi package - -The Tcl `cffi` package permits calling C functions in shared libraries from -within Tcl scripts via either the `libffi` or `dyncall` open source libraries. -The package supports Tcl 8.6 and 9.0+. - -The source repository is at https://github.com/apnadkarni/tcl-cffi. - -Documentation is at https://cffi.magicsplat.com. Some additional -tutorial material is available at https://www.magicsplat.com/blog/tags/cffi/ -and the samples in https://github.com/apnadkarni/tcl-cffi/tree/main/examples. - -Source distributions and binary packages for some platforms can be -downloaded from https://sourceforge.net/projects/magicsplat/files/cffi. - -## Building - -To build the package from the source, see `BUILD.md` in the repository -or source distribution. - -## About the package - -Major features of the package are - -- Implicit conversions of numerics, strings, structs and arrays -- Safety mechanisms for pointers -- Encoding of string values passed and returned from C functions -- Exception generation based on C function return values -- Proc-like argument processing with defaults, error messages etc. -- Utilities for managing memory and conversion to native formats -- Extensible type aliases and enums -- Introspection - -Limitations in the current version include - -- No support for *asynchronous* callbacks - -## Version history - -See the [Change log](https://github.com/apnadkarni/tcl-cffi/blob/main/CHANGES.md). diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/win32-x86_64/tcl9cffi203.dll b/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/win32-x86_64/tcl9cffi203.dll deleted file mode 100644 index 4f9736fc..00000000 Binary files a/src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/win32-x86_64/tcl9cffi203.dll and /dev/null differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/pkgIndex.tcl new file mode 100644 index 00000000..527ee26c --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/pkgIndex.tcl @@ -0,0 +1,5 @@ +# +# Tcl package index file +# +package ifneeded cmark 1.1 \ + [list load [file join $dir tcl9tclcmark11.dll] [string totitle cmark]] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/tcl9tclcmark11.dll b/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/tcl9tclcmark11.dll new file mode 100644 index 00000000..c9ac5998 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/tcl9tclcmark11.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/tclcmark.html b/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/tclcmark.html new file mode 100644 index 00000000..bc21ac1f --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tclcmark1.1/tclcmark.html @@ -0,0 +1,115 @@ +

NAME

+

cmark -- Tcl interface to CommonMark / Github Flavored Markdown

+

SYNOPSIS

+
    package require cmark
+    cmark::render ?options? TEXT
+
+

DESCRIPTION

+

The cmark package provides a Tcl script level interface to the +cmark-gfm library for parsing +and rendering CommonMark formatted text +which is a formalized specification of the commonly used Markdown syntax. +The library includes support for Github extensions which add several +features to the original specification. The extended syntax +accepted by the library is described in the +Github Flavored Markdown +specification. Here we refer to all these syntax variants collectively +as CommonMark.

+

The primary command exported from the package is the render command.

+
+
+
    cmark::render ?options? TEXT
+
+

The command parses TEXT which should be in CommonMark format and +returns it rendered in one of several different output formats. Currently +supported output formats are HTML, Latex, Groff manpage, CommonMark +XML, CommonMark and plain text.

+

Parsing

+

The following options affect parsing of TEXT.

+

-footnotes

+
+

Enable parsing of footnotes.

+
+

-ghprelang

+
+

Uses Github style tags for code blocks that have a language +attribute. This uses the lang attribute on the <pre> tag instead +of a class on the <code> tag that wrap the block.

+
+

-liberaltag

+
+

Be liberal in interpretation of HTML tags.

+
+

-smart

+
+

Replaces straight quotes with curly quotes and double or triple +hyphens with en dash and em dash respectively.

+
+

-utf8validate

+
+

Checks and replaces invalid UTF-8 character in TEXT with the U+FFFD +replacement character.

+
+

Rendering

+

The following options control the rendering of the input text.

+

-hardbreaks

+
+

Renders soft line breaks as hard line breaks.

+
+

-nobreaks

+
+

Renders soft line breaks as spaces.

+
+

-sourcepos

+
+

Includes the data-sourcepos attribute on all block elements.

+
+

-to FORMAT

+
+

Specifies the output format. FORMAT must be one of html, latex, +man , xml, commonmark or text. The man output is a groff manpage> page without the header.

+
+

-unsafe

+
+

Enables raw HTML by placeholder comments and unsafe links such as +javascript :, vbscript: etc. By default, raw HTML is replaced by +placeholder string and unsafe links removed.

+
+

-width

+
+

Specifies a max line width for wrapping. The default of 0 implies +no wrapping. Only applies to CommonMark, Latex and man output +formats.

+
+

Note that the HTML output format is a fragment and does not include any HTML +header boilerplate.

+

Enabling GFM extensions

+

By default, the command adheres to the CommonMark +specification. Various extensions specified in +Github Flavored Markdown (GFM) +may be enabled through the options below.

+

-gfm

+
+

Enables all GFM extensions. Equivalent to specifying all options below.

+
+

-autolink

+
+

Enables autolink enhancements.

+
+

-strikethrough

+
+

Enables the strikethrough +extension for wrapping strikethrough text in tilde ~ characters.

+
+

-table

+
+

Enables the table +for formatting tables.

+
+

-tagfilter

+
+

Enables the tagfilter +extension that disallows certain HTML tags.

+
+

AUTHOR

+

Ashok P. Nadkarni

diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.8.1/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.8.1/pkgIndex.tcl deleted file mode 100644 index f6db4779..00000000 --- a/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.8.1/pkgIndex.tcl +++ /dev/null @@ -1,2 +0,0 @@ -package ifneeded parser 1.8.1 \ - [list load [file join $dir tclparser181.dll] Tclparser] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.8.1/tclparser181.dll b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.8.1/tclparser181.dll deleted file mode 100644 index 2bc365b6..00000000 Binary files a/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.8.1/tclparser181.dll and /dev/null differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/parse.html b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/parse.html new file mode 100644 index 00000000..5f8ec6fe --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/parse.html @@ -0,0 +1,214 @@ + + +parse - Parse a Tcl script into commands, words, and tokens + + + + +
+

parse(n) 1.4 parse "Parse a Tcl script into commands, words, and tokens"

+

Name

+

parse - Parse a Tcl script into commands, words, and tokens.

+
+ + +

Description

+

This command parses a Tcl script into commands, words and tokens. +Each of the commands below takes a script to parse and a range +into the script: {first length}. The command parses the script from +the first index for length characters. For convenience length +can be set to the value "end". The return of +each command is a list of tuples indicating the ranges of each +sub-element. Use the returned indices as arguments to parse getstring to +extract the parsed string from the script.

+

The parse command breaks up the script into sequentially smaller +elements. A script contains one or more commands. A command is a set +of words that is terminated by a semicolon, newline or end the of the +script and has no unclosed quotes, braces, brackets or array element +names. A word is a set of characters grouped together by whitespace, +quotes, braces or brackets. Each word is composed of one or more +tokens. A token is one of the following types: text, variable, +backslash, command, expr, operator, or expand. +The type of token specifies how to decompose the string further. For example, a text +token is a literal set of characters that does not need to be broken +into smaller pieces. However, the variable token needs to be broken +into smaller pieces to separate the name of the variable from an array +indices, if one is supplied.

+

The first index is treated the same way as the indices in +the Tcl string command. An index of 0 refers to the first character +of the string. An index of end (or any abbreviation of it) refers to +the last character of the string. If first is less than zero then it +is treated as if it were zero, and if first + length is greater than or equal to +the length of the string then it is treated as if it were end.

+
+
parse command script [arg first] [arg length]
+

Returns a list of indices that partitions the script into commands. +This routine returns a list of the following form: commentRange +commandRange restRange parseTree. The first range refers to any +leading comments before the command. The second range refers to the +command itself. The third range contains the remainder of the +original range that appears after the command range. The parseTree is +a list representation of the parse tree where each node is a list in +the form: type range subTree.

+
parse expr script [arg first] [arg length]
+

Returns a list that partitions an expression into +subexpressions. The first element of the list is the token type, +subexpr, followed by the range of the expressions text, and +finally by a subTree with the words and types of the parse +tree.

+
parse varname script [arg first] [arg length]
+

Returns a list that partitions a variable token into words. +The first element of the list is the token type, variable. The +second is the range of the variable's text, and the third is a subTree +that lists the words and ranges of the variable's components.

+
parse list script [arg first] [arg length]
+

Parses a script as a list, returning the range of each element. +script must be a valid list, or an error will be generated.

+
parse getrange string ?index length?
+

Gets the range in bytes of string, optionally beginning at ?index? +of length ?length? (both in characters). Equivalent to string bytelength.

+
parse getstring string [arg first] [arg length]
+

Get the section of string that corresponds to the specified +range (in bytes). Note that this command must be used instead of string range +with values returned from the parse commands, because the values are +in bytes, and string range instead uses characters as its units.

+
parse charindex string [arg first] [arg length]
+

Converts byte oriented index values into character oriented index +values, for the string in question.

+
parse charlength string [arg first] [arg length]
+

Converts the given byte length into a character count, for the string in question.

+
+
+

EXAMPLES

+
+set script {
+    while true {puts [getupdate]}
+}
+parse command $script {0 end}
+
+

Returns:

+

{0 0} {5 30} {35 0} {{simple {5 5} {{text {5 5} {}}}} {simple {11 4} {{text {11 4} {}}}} {simple {16 18} {{text {17 16} {}}}}}

+

Or in other words, a string with no comments, 30 bytes long, beginning +at byte 5. It is composed of a series of subwords, which include +while, true, and {puts [getupdate]}.

+
+

Keywords

+

parse, parser

+
+
diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/pkgIndex.tcl new file mode 100644 index 00000000..0b276cc6 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {[package vsatisfies [package provide Tcl] 9.0]} { +package ifneeded parser 1.9 [list load [file join $dir tcl9tclparser19.dll]] +} else { +package ifneeded parser 1.9 [list load [file join $dir tclparser19t.dll]] +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/tcl9tclparser19.dll b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/tcl9tclparser19.dll new file mode 100644 index 00000000..1a5744db Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/tclparser1.9/tcl9tclparser19.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/libtdomstub.a b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/libtdomstub.a deleted file mode 100644 index 50c7869e..00000000 Binary files a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/libtdomstub.a and /dev/null differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/pkgIndex.tcl deleted file mode 100644 index e84d2bdd..00000000 --- a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# -# Tcl package index file -# -if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded tdom 0.9.5 \ - "[list load [file join $dir tcl9tdom095.dll]]; - [list source [file join $dir tdom.tcl]]" -} else { - package ifneeded tdom 0.9.5 \ - "[list load [file join $dir tdom095.dll]]; - [list source [file join $dir tdom.tcl]]" -} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/tcl9tdom095.dll b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/tcl9tdom095.dll deleted file mode 100644 index 1828974a..00000000 Binary files a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/tcl9tdom095.dll and /dev/null differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/category-index.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/category-index.html new file mode 100644 index 00000000..52705bac --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/category-index.html @@ -0,0 +1,19 @@ + + +tDOM manual: Index + +
+

tDOM manual: Index

+Contents · Index · Keywords · Repository +

+Tcl commands · C functions · Miscellaneous ·
+
+

Tcl commands

dom · dom · domDoc · domNode · expat · expat · tdom · tdom::pullparser · tdom::schema · tnc · xml::parser

C functions

CheckExpatParserObj, CHandlerSetInstall, CHandlerSetRemove, + CHandlerSetCreate, CHandlerSetGetUserData, GetExpatInfo

Miscellaneous

::dom::xpathFunc +
+
+Contents · Index · Keywords · Repository +
+
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/dom.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/dom.html new file mode 100644 index 00000000..3a1d79cd --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/dom.html @@ -0,0 +1,878 @@ + + +tDOM manual: dom + +
+
+NAME · SYNOPSIS · DESCRIPTION · KEYWORDS +
+
+

NAME

+dom -
Create an in-memory DOM tree from XML

+ +

SYNOPSIS

package require tdom
+
+dom method ?arg arg ...?
+ +

DESCRIPTION

This command provides the creation of DOM trees in memory. In +the usual case a string containing a XML information is parsed and converted +into a DOM tree. Other possible parse input may be HTML or JSON. +The method indicates a specific subcommand.

The valid methods are:

+ +
+dom parse ?options? ?data?
+
Parses the XML information and builds up the DOM tree in memory +providing a Tcl object command to this DOM document object. Example: + + 
+dom parse $xml doc
+$doc documentElement root
+ +

parses the XML in the variable xml, creates the DOM tree in memory, +make a reference to the document object, visible in Tcl as a document object +command, and assigns this new object name to the variable doc. When doc gets +freed, the DOM tree and the associated Tcl command object (document and all +node objects) are freed automatically.

+ + 
+set document [dom parse $xml]
+set root     [$document documentElement]
+ +

parses the XML in the variable xml, creates the DOM tree in memory, +make a reference to the document object, visible in Tcl as a document object +command, and returns this new object name, which is then stored in +document. To free the underlying DOM tree and the associative Tcl +object commands (document + nodes + fragment nodes) the document object command +has to be explicitly deleted by:

+ + 
+$document delete
+
or
+rename $document ""
+ +

The valid options are:

+
+ +
-simple
+
If -simple is specified, a simple but + fast parser is used (conforms not fully to XML + recommendation). That should double parsing and DOM + generation speed. The encoding of the data is not + transformed inside the parser. The simple parser does + not respect any encoding information in the XML + declaration. It skips over the internal DTD subset and + ignores any information in it. Therefore, it doesn't + include defaulted attribute values into the tree, even + if the according attribute declaration is in the + internal subset. It also doesn't expand internal or + external entity references other than the predefined + entities and character references
+ + + +
-html
+
If -html is specified, a fast HTML parser + is used, which tries to even parse badly formed HTML + into a DOM tree. If the HTML document given to parse + does not have a single root element (as it was legal + up to HTML 4.01) and the -forest option is not used + then a html node will be inserted as document element, + with the HTML input data top level elements as + children.
+ + + +
-html5
+
This option is only available if tDOM was build + with --enable-html5. Use the featureinfo method + if you need to know if this feature is build in. If + -html5 is specified, the gumbo lib html5 parser + (https://github.com/google/gumbo-parser) is used to + build the DOM tree. This is, as far as it goes, XML + namespace-aware (which means for example that all HTML + elements are in the html5 namespace). Since this + probably isn't wanted by a lot of users and adds only + burden for no good in a lot of use cases -html5 + can be combined with -ignorexmlns, in which + case all nodes and attributes in the DOM tree are not + in an XML namespace. All tag and attribute names in + the DOM tree will be lower case, even for foreign + elements not in the xhtml, svg or mathml namespace. + The DOM tree may include nodes, that the parser + inserted because they are implied by the context (as + <head>, <tbody>, etc.). Input longer than + 4 GByte byte length is not supported by the underlying + gumbo parser.
+ + + +
-json
+
If -json is specified, the data is + expected to be a valid JSON string (according to RFC + 7159). The command returns an ordinary DOM document + with nesting token inside the JSON data translated + into tree hierarchy. If a JSON array value is itself + an object or array then container element nodes named + (in a default build) arraycontainer or + objectcontainer, respectively, are inserted into the + tree. The JSON serialization of this document (with + the domDoc method asJSON) is the same JSON + information as the data, preserving JSON + datatypes, allowing non-unique member names of objects + while preserving their order and the full range of + JSON string values. JSON datatype handling is done + with an additional property "sticking" at the doc and + tree nodes. This property isn't contained in an XML + serialization of the document. If you need to store + the JSON data represented by a document, store the + JSON serialization and parse it back from there. Apart + from this JSON type information the returned doc + command or handle is an ordinary DOM doc, which may be + investigated or modified with the full range of the + doc and node methods. Please note that the element + node names and the text node values within the tree + may be outside of what the appropriate XML productions + allow.
+ + + +
-jsonroot <document element name>
+
If given makes the given element name the + document element of the resulting doc. The parsed + content of the JSON string will be the children of + this document element node.
+ + + +
+-jsonmaxnesting integer +
+ +
This option only has effect if used together + with the -json option. The current + implementation uses a recursive descent JSON parser. + In order to avoid using excess stack space, any JSON + input that has more than a certain levels of nesting + is considered invalid. The default maximum nesting is + 2000. The option -jsonmaxnesting allows the user to + adjust that.
+ + + +
--
+
The option -- marks the end of options. + To give this option isn't strictly necessary even in + the case of JSON parsing, for which valid data may + start with a "-". If parsing json and if the second to + last or last argument start with a "-" and isn't a + known option name it will be treated as JSON + data.
+ + + +
-keepEmpties
+
If -keepEmpties is +specified then text nodes which contain only whitespaces will be part of the +resulting DOM tree. In default case (-keepEmpties not given) those empty +text nodes are removed at parsing time.
+ + + +
-keepCDATA
+
If -keepCDATA is +specified then CDATA sections aren't added to the tree as text nodes +(and, if necessary, combined with sibling text nodes into one text +node) as without this option but are added as CDATA_SECTION_NODEs to +the tree. Please note that the resulting tree isn't prepared for XPath +selects or to be the source or the stylesheet of an XSLT +transformation. If not combined with -keepEmpties only not +whitespace only CDATA sections will be added to the resulting DOM + tree.
+ + + +
+-channel <channel-ID> +
+ +
If -channel <channel-ID> is specified, the +input to be parsed is read from the specified channel. The encoding setting of +the channel (via fconfigure -encoding) is respected, ie the data read from the +channel are converted to UTF-8 according to the encoding settings before the +data is parsed.
+ + + +
+-baseurl <baseURI> +
+ +
If -baseurl <baseURI> is specified, + the baseURI is used as the base URI of the document. + External entities references in the document are + resolved relative to this base URI. This base URI is + also stored within the DOM tree.
+ + + +
+-feedbackAfter <#bytes> +
+ +
If -feedbackAfter <#bytes> is + specified, the Tcl command given by + -feedbackcmd is evaluated at the first element + start within the document (or an external entity) + after the start of the document or external entity or + the last such call after #bytes. For backward + compatibility if no -feedbackcmd is given but there is + a Tcl proc named ::dom::domParseFeedback this proc is + used as -feedbackcmd. If there isn't such a proc and + -feedbackAfter is used it is an error to not also use + -feedbackcmd. If the called script raises error, then + parsing will be aborted, the dom parse call + returns error, with the script error msg as error msg. + If the called script return -code break, the + parsing will abort and the dom parse call will + return the empty string.
+ + + +
+-feedbackcmd <script> +
+ +
If -feedbackcmd <script> is specified, the +script script is evaluated at the first +element start within the document (or an external entity) after the +start of the document or external entity or the last such call after +#bytes value given by the -feedbackAfter option. If +-feedbackAfter isn't given, using this option +doesn't has any effect. If the called +script raises error, then parsing will be aborted, the +dom parse call returns error, with the script +error msg as error msg. If the called script return +-code break, the parsing will abort and the dom +parse call will return the empty string.
+ + + +
+-externalentitycommand <script> +
+ +
If -externalentitycommand <script> is +specified, the specified Tcl script is called to resolve any external entities +of the document. The actual evaluated command consists of this option followed +by three arguments: the base uri, the system identifier of the entity and the +public identifier of the entity. The base uri and the public identifier may be +the empty list. The script has to return a Tcl list consisting of three +elements. The first element of this list signals how the external entity is +returned to the processor. Currently the two allowed types are "string" +and "channel". The second element of the list has to be the (absolute) base URI +of the external entity to be parsed. The third element of the list are data, +either the already read data out of the external entity as string in the case +of type "string", or the name of a Tcl channel, in the case of type +"channel". Note that if the script returns a Tcl channel, it will not be closed +by the processor. It must be closed separately if it is no longer +needed.
+ + + +
+-useForeignDTD <boolean> +
+
If + <boolean> is true and the document does not have + an external subset, the parser will call the + -externalentitycommand script with empty values for + the systemId and publicID arguments. Please note that + if the document also doesn't have an internal subset, + the -startdoctypedeclcommand and + -enddoctypedeclcommand scripts, if set, are not + called.
+ + + +
+-paramentityparsing <always|never|notstandalone> +
+ +
The -paramentityparsing option controls, + if the parser tries to resolve the external entities + (including the external DTD subset) of the document + while building the DOM tree. + -paramentityparsing requires an argument, which + must be either "always", "never", or "notstandalone". + The value "always" means that the parser tries to + resolves (recursively) all external entities of the + XML source. This is the default in case + -paramentityparsing is omitted. The value + "never" means that only the given XML source is + parsed and no external entity (including the external + subset) will be resolved and parsed. The value + "notstandalone" means, that all external entities will + be resolved and parsed, with the exception of + documents, which explicitly states standalone="yes" in + their XML declaration.
+ + + + +
-forest
+
If this option is given, there is no need for a + single root; any sequence of well-formed, balanced + subtrees will be parsed into a DOM tree. This works + for the expat DOM builder, the simple xml parser + enabled with -simple and the simple HTML parser + enabled -with -html. If used together with + -json or -html5 this option is ignored. +
+ + + +
-ignorexmlns
+
It is recommended, that you only use this option + with the -html5 option. If this option is + given, no node within the created DOM tree will be + internally marked as placed into an XML Namespace, + even if there is a default namespace in scope for + un-prefixed elements or even if the element has a + defined namespace prefix. One consequence is that + XPath node expressions on such a DOM tree doesn't work + as may be expected. Prefixed element nodes can't be + selected naively and element nodes without prefix will + be seen by XPath expressions as if they are not in any + namespace (no matter if they are in fact should be in + a default namespace). If you need to inject prefixed + node names into an XPath expression use the '%' syntax + described in the documentation of the of the + domNode command method + selectNodes. +
+ + + +
+-billionLaughsAttackProtectionMaximumAmplification <float> +
+ +
This option together with + -billionLaughsAttackProtectionActivationThreshold + gives control over the parser limits that protects + against billion laugh attacks + (https://en.wikipedia.org/wiki/Billion_laughs_attack). + This option expects a float >= 1.0 as argument. You + should never need to use this option, because the + default value (100.0) should work for any real data. + If you ever need to increase this value for non-attack + payload, please report.
+ + + +
+-billionLaughsAttackProtectionActivationThreshold <long> +
+ +
This option together with + -billionLaughsAttackProtectionMaximumAmplification + gives control over the parser limits that protects + against billion laugh attacks + (https://en.wikipedia.org/wiki/Billion_laughs_attack). + This option expects a positiv integer as argument. You + should never need to use this option, because the + default value (8388608) should work for any real data. + If you ever need to increase this value for non-attack + payload, please report.
+ + +
+

+
+ + + +
+dom createDocument +docElemName ?objVar?
+
Creates a new DOM document object with one element node with +node name docElemName. The objVar controls the +memory handling as explained above.
+ + + +
+dom createDocumentNS +uri docElemName ?objVar?
+
Creates a new DOM document object with one element node with +node name docElemName. Uri gives the namespace of the +document element to create. The objVar controls the +memory handling as explained above.
+ + + +
+dom createDocumentNode +?-jsonType jsonType? ?objVar?
+
Creates a new 'empty' DOM document object without any + element node. objVar controls the memory handling as + explained above. If the option -jsonType is given the + created document node will be of the given JSON type.
+ + + +
+dom createFromTypedList typedList ?objVar?
+
+

Creates a new DOM document from the argument typedList. + The objVar argument controls the memory handling as + explained above.

+ +

The typedList argument must be a Tcl list and must + follow the format of the output of the document command + method asTypedList, see there.

+
+ + + +
+dom createNodeCmd + ?-returnNodeCmd? ?-tagName name? ?-jsonType jsonType? ?-namespace URI? ?-noNamespacedAttributes? ?-notempty? (element|comment|text|cdata|pi)Node commandName +
+
This method creates Tcl commands, which in turn create + tDOM nodes. Tcl commands created by this command are only + available inside a script given to the domNode methods + appendFromScript or insertBeforeFromScript. If + a command created with createNodeCmd is invoked in + any other context, it will return error. The created command + commandName replaces any existing command or + procedure with that name. If the commandName includes + any Tcl namespace qualifiers, it is created in the specified + namespace. The -tagName option is only allowed for + the elementNode type. The -jsonType option is only + allowed for elementNode and textNode types. + +

If such command is invoked inside a script given as argument to the +domNode method appendFromScript or +insertBeforeFromScript it creates a new node and appends this +node at the end of the child list of the invoking element node. If the +option -returnNodeCmd was given, the command returns the +created node as Tcl command. If this option was omitted, the command +returns nothing. Each command creates always the same type of node. +Which type of node is created by the command is determined by the +first argument to the createNodeCmd. The syntax of the created +command depends on the type of the node it creates.

+ +

If the command type to create is elementNode, the created +command will create an element node, if called. Though, if the +-notempty flag was used in creating the node command the +element node will only be created if it is not empty. Without the +-tagName option the tag name of the created node is +commandName without Tcl namespace qualifiers. If the +-tagName option was given then the created elements will have +the value of this option as tag name. If the -jsonType option +was given then the created node elements will have the given JSON +type. If the -namespace option is given the created element +node will be XML namespaced and in the namespace given by the option. +The element name will be literal as given either by the command name +or the -tagname option, if that was given. An appropriate XML +namespace declaration will be automatically added, to bind the prefix +(if the element name has one) or the default namespace (if the element +name hasn't a prefix) to the namespace if such a binding isn't in +scope.

+ +

The syntax of the created command is:

+ +
+elementNodeCmd ?attributeName attributeValue ...? ?script?
+elementNodeCmd ?-attributeName attributeValue ...? ?script?
+elementNodeCmd ?name_value_list? ?script?
+
+ +

The command syntax allows three different ways to specify the +attributes of the resulting element. These could be specified with +attributeName attributeValue argument pairs, in an "option +style" way with -attriubteName attributeValue argument pairs +(the '-' character is only syntactical sugar and will be stripped off) +or as a Tcl list with elements interpreted as attribute name and the +corresponding attribute value. The attribute name elements in the list +may have a leading '-' character, which will be stripped off. If the +elementNodeCmd is called with only one argument this will be +interpreted as content script.

+ +

If an attributeName is prefixed then by default the prefix +will be first looked up in the selectNodesNamespaces prefix URI +list and, if not found, looked up in the XML namespace scope of the +node. If the prefix does not resolve error is raisen. If the prefix +resolve then the attribute is created in this namespace (adding XML +namespace declarations, if necessary). If elementNodeCmd was +created with the flag -noNamespacedAttributes then no prefix +lookup is done and the attribute is created with the name as given and +in no XML namespace. It is recommended to not create XML namespace +declarations with this.

+ +

Every elementNodeCmd accepts an optional Tcl script as last +argument. This script is evaluated as recursive appendFromScript script +with the node created by the elementNodeCmd as parent of all nodes +created by the script.

+ +

If the first argument of the method is textNode, the command +will create a text node. If the -jsonType option was given then +the created text node will have that JSON type. The syntax of the +created command is:

+ +
+textNodeCmd ?-disableOutputEscaping? ?data?
+
+ +

If the json type of the created text node is NULL, TRUE or FALSE +then the data argument is optional, otherwise it this argument +must be given.

+ +

If the json type of the created text node is the virtual type +BOOLEAN then if the text value is a boolean as recognized by +Tcl_GetBooleanFromObj() the json value will according and if the text +node value is not a boolean value understood by Tcl the value will be +writen as json string.

+ +

If the optional flag -disableOutputEscaping is given, the +escaping of the ampersand character (&) and the left angle bracket (<) +inside the data is disabled. You should use this flag carefully.

+ +

If the first argument of the method is commentNode or +cdataNode the command will create an comment node or CDATA section +node. The syntax of the created command is:

+ +
+nodeCmd data
+
+ +

If the first argument of the method is piNode, the command will +create a processing instruction node. The syntax of the created +command is:

+ +
+piNodeCmd target data
+
+ +

Beside the with dom createNodeCmd calls +created node commands there are two more commands which automatically +insert nodes into the tree inside an appendFromScript +script.

+ +
+tdom::fsnewNode ?-jsonType <jsonType>? ?-namespace <namespace>? ?-noNamespacedAttributes? -notempty tagName ?attributes? ?script?
+
+ +

If called inside a fromScript context this command creates a new +node tagName in the XML namespace namespace if the +-namespace option was given and with the JSON type +jsonType if the -jsonType option was given and appends +this node at the end of the child list of the invoking element node. +The other flags will also work as if given at the creation of an +element creating command; see there. The attributes and +script arguments will also be processed as if given to an +element creating node command. If called outside a fromScript context +this command will raise error. +

+ +
+tdom::fsinsertNode node
+
+ +

If called inside a fromScript context this command instead of +creating a new node appends the as argument given node at the end of +the child list of the invoking element node. The node is unlinked from +its previous place. If called outside a fromScript context this +command will raise error. +

+ + +
+ + + +
+dom fromScriptContext ?objVar?
+
If called inside a fromScript context this method + returns the node on which the script context appends nodes + to the child list. Otherwise it returns error. + +

If you create nodeCmds with the -notempty the returned + node may have vanished outside the evaluation context if it + is still empty at the end of the evaluation.

+
+ + + +
+dom setStoreLineColumn ?boolean?
+
If switched on, the DOM nodes will contain line and column +position information for the original XML document after parsing. The default +is not to store line and column position information.
+ + + +
+dom setNameCheck ?boolean?
+
If NameCheck is true, every method which expects an XML Name, +a full qualified name or a processing instructing target will check, if the +given string is valid according to its production rule. For commands created +with the createNodeCmd method to be used in the context of +appendFromScript the status of the flag at creation time +decides. If NameCheck is true at creation time, the command will +check its arguments, otherwise not. The setNameCheck +set this flag. It returns the current NameCheck flag state. The +default state for NameCheck is true.
+ + + +
+dom setTextCheck ?boolean?
+
If TextCheck is true, every command which expects XML Chars, +a comment, a CDATA section value or a processing instructing value will check, +if the given string is valid according to its production rule. For commands +created with the createNodeCmd method to be used in the +context of appendFromScript the status of the flag at +creation time decides. If TextCheck is true at creation time, the +command will check its arguments, otherwise not.The +setTextCheck method sets this flag. It returns the current +TextCheck flag state. The default state for TextCheck is true.
+ + + +
+dom setObjectCommands ?(automatic|token|command)?
+
Controls if documents and nodes are created as Tcl commands or +as token to be +used with the domNode and domDoc commands. If the mode is +'automatic', then methods used at Tcl commands will create Tcl +commands and methods used at doc or node tokes will create tokens. If +the mode is 'command' then always Tcl commands will be created. If +the mode is 'token', then always token will be created. The method +returns the current mode. This method is an experimental interface.
+ + + +
+dom isName name +
+
Returns 1 if name is a valid XML Name according to +production 5 of the XML + 1.0 recommendation. This means that name is a valid + XML element or attribute name. Otherwise it returns 0.
+ + + +
+dom isPIName name +
+
Returns 1 if name is a valid XML processing instruction + target according to +production 17 of the XML 1.0 recommendation. Otherwise it returns 0.
+ + + +
+dom isNCName name +
+
Returns 1 if name is a valid NCName according +to production 4 of the of the Namespaces in XML recommendation. Otherwise it returns +0.
+ + + +
+dom isQName name +
+
Returns 1 if name is a valid QName according +to production 6 of the of the Namespaces in XML recommendation. Otherwise it returns +0.
+ + + +
+dom isCharData +string +
+
Returns 1 if every character in string is +a valid XML Char according to production 2 of the XML 1.0 +recommendation. Otherwise it returns 0.
+ + + +
+dom isHTML5CustomName string +
+
Returns 1 if string is a HTML5 valid custom + element name (according to + https://html.spec.whatwg.org/#valid-custom-element-name at + 26 June 2024, it's a living standard). Otherwise it returns + 0.
+ + + +
+dom clearString ?-replace? string +
+
Returns the string given as argument cleared out from + any characters not allowed as XML parsed character data. If + the -replace option is given then instead of removing + such characters are replaced with \uFFFD.
+ + + +
+dom isBMPCharData +string +
+
Returns 1 if every character in string is +a valid XML Char with a Unicode code point within the Basic +Multilingual Plane (that means, that every character within the string +is at most 3 bytes long). Otherwise it returns 0.
+ + + +
+dom isComment +string +
+
Returns 1 if string is +a valid comment according to production 15 of the XML 1.0 +recommendation. Otherwise it returns 0.
+ + + +
+dom isCDATA +string +
+
Returns 1 if string is +valid according to production 20 of the XML 1.0 +recommendation. Otherwise it returns 0.
+ + + +
+dom isPIValue +string +
+
Returns 1 if string is +valid according to production 16 of the XML 1.0 +recommendation. Otherwise it returns 0.
+ + + +
+dom jsonEscape +string +
+
Returns the given string argument escaped in a + way that if the returned string is used literary in a JSON + document it is read by any confirming JSON parser as the + original string.
+ + + +
+dom featureinfo feature +
+
This method provides information about the used + build options and the expat version. The valid values for + the feature argument are: +
+ +
expatversion
+
Returns the version of the underlyling expat + version as string, something like + "exapt_2.1.0". This is what the expat API + function XML_ExpatVersion() returns.
+ + +
expatmajorversion
+
Returns the major version of the at build + time used expat version as integer.
+ + +
expatminorversion
+
Returns the minor version of the at build + time used expat version as integer.
+ + +
expatmicroversion
+
Returns the micro version of the at build + time used expat version as integer.
+ + +
dtd
+
Returns as boolean if build with + --enable-dtd.
+ + +
ns
+
Returns as boolean if build with + --enable-ns.
+ + +
unknown
+
Returns as boolean if build with + --enable-unknown.
+ + +
tdomalloc
+
Returns as boolean if build with + --enable-tdomalloc.
+ + +
lessns
+
Returns as boolean if build with + --enable-lessns.
+ + +
TCL_UTF_MAX
+
Returns the TCL_UTF_MAX value of the Tcl + core, tDOM was build with as integer
+ + +
html5
+
Returns as boolean, if build with + --enable-html5.
+ + +
versionhash
+
Returns the fossil repository version hash.
+ + +
pullparser
+
Returns as boolean if the pullparser command + is build in.
+ + +
schema
+
Returns as boolean if the tDOM schema features + are build in.
+ + +
largedata
+
Returns as boolean if the expat library + configuration allows pcdata content of an XML + element. Could be true only if build with Tcl 9 + for a 64-bit architecture and then depends if the + build-in expat version is used with default + configuration or if the used system expat library + is capable enough for this (typically not). are + build in.
+ +
+
+ +
+ +

KEYWORDS

+XML, DOM, document, node, parsing +

+
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/domDoc.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/domDoc.html new file mode 100644 index 00000000..95d18a37 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/domDoc.html @@ -0,0 +1,786 @@ + + +tDOM manual: domDoc + +
+
+NAME · SYNOPSIS · DESCRIPTION · SEE ALSO · KEYWORDS +
+
+

NAME

+domDoc -
Manipulates an instance of a DOM document object

+ +

SYNOPSIS

domDocObjCmd method ?arg arg ...?
+ +

DESCRIPTION

This command manipulates one particular instance of a document +object. method indicates a specific method of the document class. These +methods should closely conform to the W3C recommendation "Document Object Model +(Core) Level 1" (http://www.w3.org/TR/REC-DOM-Level-1/level-one-core.html). Look +at these documents for a deeper understanding of the functionality.

The valid methods are:

+ +
+documentElement ?objVar?
+
Returns the top most element in the document (the root +element).
+ + + +
+getElementsByTagName name +
+
Returns a list of all elements in the document matching +(glob style) name.
+ + + +
+getElementsByTagNameNS uri localname +
+
Returns a list of all elements in the subtree +matching (glob style) localname and having the given namespace +uri.
+ + + +
+createElement tagName ?objVar?
+
Creates (allocates) a new element node with node name +tagName, append it to the hidden fragment list in the document +object and returns the node object. If objVar is given the new +node object is stored in this variable.
+ + + +
+createElementNS url tagName ?objVar?
+
Creates (allocates) a new element node within a namespace +having uri as the URI and node name tagName, which +could include the namespace prefix, append it to the hidden fragment list in +the document object and returns the node object. If objVar is +given the new node object is stored in this variable.
+ + + +
+createTextNode text ?objVar?
+
Creates (allocates) a new text node with node value +text, appends it to the hidden fragment list in the document +object and returns the node object. If objVar is given, the new +node object is stored in this variable.
+ + + +
+createComment text ?objVar?
+
Creates (allocates) a new comment node with value +text, appends it to the hidden fragment list in the document +object and returns the node object. If objVar is given, the new +comment node object is stored in this variable.
+ + + +
+createCDATASection data ?objVar?
+
Creates (allocates) a new CDATA node with node value +data, appends it to the hidden fragment list in the document +object and returns the node object. If objVar is given, the new +node object is stored in this variable.
+ + + +
+createProcessingInstruction target data ?objVar?
+
Creates a process instruction, appends it to the hidden +fragment list in the document object and returns the node object. If +objVar is given, the new node object is stored in this variable.
+ + + +
delete
+
Explicitly deletes the document, including the associated +Tcl object commands (for nodes, fragment/new nodes, the document object itself) +and the underlying DOM tree.
+ + + +
getDefaultOutputMethod
+
Returns the default output method of the document. This is +usually a result of a XSLT transformation.
+ + + +
+asXML ?-indent none/tabs/1..8? ?-channel channelId? ?-escapeNonASCII? ?-doctypeDeclaration <boolean>? -xmlDeclaration <boolean>? -encString <string> ?-escapeAllQuot? ?-indentAttrs? ?-nogtescape? ?-noEmptyElementTag? ?-escapeCR? ?-escapeTab? +
+
+

Returns the DOM tree as an (optional indented) XML + string or sends the output directly to the given + channelId.

+ +

The -indent option requires "no", "none", "tabs" or a + natural number betwenn 0 and 8, both included, as value. With + the values "no" or "none" no additional white space outside of + markup will be added to the serialization. I. Otherwise, it's + a "pretty-print" serialization, due to inserting white space + between end and the next start tag according to the nesting + level. The level indentation wide is given with the number. If + the value is "tabs", then indentation is done with tabs, one + tab per level.

+ +

If the option -escapeNonASCII is given, + every non 7 bit ASCII character in attribute values or element + PCDATA content will be escaped as character reference in + decimal representation.

+ +

The flag -doctypeDeclaration determines whether + there will be a DOCTYPE declaration emitted before the first + node of the document. The default is not to emit it. The + DOCTYPE name will always be the element name of the document + element. An external entity declaration of the external subset + is only emitted if the document has a system identifier.

+ +

The flag -xmlDeclaration determines whether there + will be an XML Declaration and a newline emitted before + anything else. The default is not to emit one. If this flag is + given with a true argument then

+ +

+-encString sets the encoding value in the XML + Declaration. Otherwise this option is ignored. Please note + that this option just enhances the string representation of the + generated XML Declaration with an encoding information string, + nothing more. It's up to the user to handle encoding in case + of writing to a channel or reparsing.

+ +

If the option -escapeAllQuot is given, + quotation marks will be escaped with &quot; even in text + content of elements.

+ +

If the option -indentAttrs is + given, then attributes will each be separated with newlines + and indented to the same level as the parent node plus the + value given as argument to -indentAttrs (0..8).

+ +

If the option -nogtescape is given then the + character '>' won't get escaped in attribute values and text + content of elements. The default is to escape this + character.

+ +

If the option -noEmptyElementTag is given then no + empty tag syntax will be used. Instead, if an element has + empty content it will be serialized with an element start tag + and an immediately following element end tag.

+ +

If the option -escapeCR is given then the character + '\r' will be escaped as character reference in attribute + values and text content of elements. The default is to not do + this.

+ +

If the option -escapeTab is given then the character + '\t' will be escaped as character reference in attribute + values and text content of elements. The default is to not do + this.

+
+ + + +
+asCanonicalXML ?-channel channelId? ?-comments <boolean>? +
+
+

Returns the DOM tree as canonical XML string + according to the "Canonical + XML Version 1.0 W3C Recommendation 15 March 2001" or + sends the output directly to the given channelId.

+ +

If the goal is to get a canonical XML serialization of the + XML file from which the DOM tree was parsed there are a few + prerequisites. The XML data must be parsed with the + -keepEmpties option. If the XML data includes a DTD + which defines attribute defaults or external parsed entity + references it is necessary to use the expat parser (not the + -simple one). For any supported Tcl version lesser then + 9.0 if the XML data includes characters outside the BMP a Tcl + build with TCL_UTF_MAX defined to 6 (and a tDOM build with + this Tcl) is necessary. +

+ +

If the -channel option is given then the output is send + directly to the Tcl channel given as argument. It is the up to + the caller to ensure that the channel is correctly + fconfigured. If this option is not given then the command + returns the serialization as string.

+ +

If the option -comments is given with a true value + then the serialization includes comments according to the + rules of the recommendation. If the value is false or this + option is omitted then comments are removed from the + serialization.

+
+ + + +
+asHTML ?-channel +channelId? ?-escapeNonASCII? ?-htmlEntities? ?-doctypeDeclaration <boolean>? ?-breakLines? ?-onlyContents? +
+
+

Returns the DOM tree serialized according to HTML rules + (HTML elements are recognized regardless of case, without end + tags for empty HTML elements etc.) as string or sends the + output directly to the given channelId.

+ +

If the option -escapeNonASCII is given, every non 7 + bit ASCII character in attribute values or element PCDATA + content will be escaped as character reference in decimal + representation.

+ +

If the option -htmlEntities is given, a character or + a pair of characters is written using its HTML 5 character + entity reference, if it has one. Some HTML 5 character entity + references encode the same character or code points. From the + possible entity names the shortest is choosen. If there are + more than one shortest name and this names differ only in case + then the lowercase alternative is choosen. Otherwise frist + name in lexical ASCII order is choosen. There is one HTML5 + entitiy (ThickSpace), which escapes two characters for which + the first and the second character have an entity name by + itself. If the two characters are to be serialized then the + one two-characters entity ThickSpace will be choosen.

+ +

If the option -breakLines is given the serialization + outputs "\n>" instead of ">" for the opening tags of + elements.

+ +

If the option -onlyContents is given only all child + nodes are serialized. This option is ignored by document + nodes.

+ +

If the flag -doctypeDeclaration is given there will + be a DOCTYPE declaration emitted before the first node of the + document. The default is, to do not. The DOCTYPE name will + always be the element name of the document element without + case normalization. An external entity declaration of the + external subset is only emitted, if the document has a system + identifier. The doctype declaration will be written from the + available information, without check, if this is a known (w3c) + HTML version information or if the document confirms to the + given HTML version. All nodes types other than document nodes + ignore this option.

+
+ + + +
asText
+
The asText method returns the tree by serializing the + string-value of every text node in document order without + any escaping. In effect, this is what the xslt output method + "text" (XSLT 1.0 recommendation, section 16.3) does.
+ + + +
+asJSON ?-indent none/0..8? ?-channel channelId? +
+
+

The asJSON method serializes the tree into a valid + JSON data string. In general, this may be a lossy + serialization. For this serialization all comment, character + data sections and processing instruction nodes, all + attributes and all XML namespaces are ignored. Only element + and text nodes may be reflected in the generated JSON + serialization. Appropriate JSON data type information of a + node will be respected.

+ +

If an element node has the JSON type OBJECT, then every + element node child of this element will be serialized as + member of that object, with the node name of the child as + the member name and the relevant children of that child as + the value. Every other child nodes will be ignored.

+ +

If an element node has the JSON type ARRAY, then the text + and element node children of that element node are serialized + as the consecutive values of the array. Element node children + of an ARRAY element will be container nodes for nested ARRAY + or OBJECT values.

+ +

Text nodes with the JSON types TRUE, FALSE or NULL will + be serialized to the corresponding JSON token without + looking at the value of the text node. A text node without + JSON type will always be serialized as a JSON string token. + A text node with JSON type NUMBER will be serialized as JSON + number token if the text node value is in fact a valid JSON + number and as a JSON string if not.

+ +

If an element node doesn't has a JSON type then the + serialization of its children is determined by the following + rules:

+ +

Only text and element node child are relevant. If the + element node to serialize is the member of a JSON object and + there is no relevant child node the value of that member + will be an empty JSON string. If the only relevant child + node of this element node is a text node then the JSON + value of that text node will be the value of the object + member. If the element has more than one relevant child + nodes and the first one is a text node then the relevant + children will be serialized as JSON array. If the only + relevant child node is an element node or the first relevant + child is an element node and the node name of that only or + first relevant child isn't equal to the array container node + name all element node children will be serialized as the + members of a JSON object (while ignoring any intermixed text + nodes). If the only or first relevant child is an element + node and the node name of this child is equal to the array + container element name then all relevant children will be + serialized as the values of a JSON array.

+ +

If the element to serialize is a value of a JSON array + and the node name of this element isn't equal to the array + container node name that element will be seen as a container + node for a JSON object and all element node children will be + serialized as the members of that array while ignoring any + text node children. If the element to serialize is a value of + a JSON array and the node name of this element is equal to + the array container node name, all relevant children will be + serialized as JSON array.

+ +

If the -channel option is given the serialization + isn't returned as string but send directly to the channel, + given as argument to the option.

+ +

If the -indent option is given and the argument + given to this option isn't "none" then the returned JSON + string is "pretty-printed". The numeric argument to this + option defines the number of spaces for any indentation + level. The default is to not emit any additional + white space.

+
+ + + +
+asTclValue ?typevariable? +
+
+

In case the DOM tree includes JSON type information + this method returns the JSON data as nested Tcl data + structure.

+ +

The returned value may be a Tcl dict, a Tcl list or a + string. If the optional argument typevariable is given + then the variable with that name is set to the value + dict, list or string respectively to + signal the type of the result.

+ +

A JSON object is returned as Tcl dict, a JSON array is + returned as list and JSON strings and numbers as well as the + symbolic JSON values null, true and false are returned as + string (with the strings null, true and false for the + respectively JSON symbol). The value of a member of a JSON + object may be also a Tcl dict, or a Tcl list or a string and + the elements of a JSON array list may be a Tcl dict or a Tcl + list or a string.

+
+ + + +
asTypedList
+
+

In case the DOM tree includes JSON type information + this method returns the JSON data as a nested Tcl list.

+ +

The first element of every of this lists describes the type + of the value. The types are: OBJECT, ARRAY, STRING, NUMBER, + TRUE, FALSE or NULL.

+ +

If the type is NUMBER or STRING, then the second (and last) + element is the value. If the type is NULL, TRUE or FALSE the + list does not have any other elements.

+ +

If the type is OBJECT the second value will be a Tcl list + of property name and value pairs, which means the second + element could be used as dict. The value will be a Tcl list + build by the rules of the asTypedList method.

+ +

If the type is ARRAY the second value will be a Tcl list of + the JSON array values, each one build by the rules of the + asTypedList method.

+
+ + + +
+publicId ?publicId? +
+
Returns the public identifier of the doctype declaration of the +document, if there is one, otherwise the empty string. If there is a value +given to the method, the public identifier of the document is set to this +value.
+ + + +
+systemId ?systemId? +
+
Returns the system identifier of the doctype declaration of the +document, if there is one, otherwise the empty string. If there is a value +given to the method, the system identifier of the document is set to this +value.
+ + + +
+internalSubset ?internalSubset? +
+
Returns the internal subset of the doctype declaration of the +document, if there is one, otherwise the empty string. If there is a value +given to the method, the internal subset of the document is set to this +value. Note that none of the parsing methods preserve the internal subset +of a document; a freshly parsed document will always have an empty internal +subset. Also note that the method doesn't do any syntactical check on a +given internal subset.
+ + + +
+cdataSectionElements (?URI:?localname|*) ?<boolean>? +
+
This method allows one to control for which element nodes +the text node children will be serialized as CDATA sections (this affects only +serialization with the asXML method, no text node is altered in any +way by this method). IF the method is called with an element name as +first argument and a boolean with value true as second argument, every +text node child of every element node in the document with the same +name as the first argument will be serialized as CDATA section. If the +second argument is a boolean with value false, all text nodes of all +elements with the same name as the first argument will be serialized +as usual. Namespaced element names have to be given in the form +namespace_URI:localname, not in the otherwise usual prefix:localname +form. With two arguments called, the method returns the used boolean +value. If the method is called with only an element name, it will +return a boolean value, indicating that the text node children of all +elements with that name in the document will be serialized as CDATA +section elements (return value 1) or not (return value 0). If the +method is called with only one argument and that argument is an +asterisk ('*'), then the method returns an unordered list of all +element names of the document, for which the text node children will be +serialized as CDATA section nodes.
+ + + +
+selectNodesNamespaces ?prefixUriList? +
+
This method gives control to a document global prefix to + namespace URI mapping, which will be used for selectNodes + method calls (on document as well as on all nodes, which + belongs to the document) if it is not overwritten by using the + -namespaces option of the selectNodes method. Any namespace + prefix within an xpath expression will be first resolved + against this list. If the list binds the same prefix to + different namespaces, then the first binding will win. If a + prefix could not resolved against the document global prefix / + namespaces list, then the namespace definitions in scope of + the context node will be used to resolve the prefix, as usual. + If the optional argument prefixUriList is given, then + the global prefix / namespace list is set to this list and + returns it. Without the optional argument the method returns + the current list. The default is the empty list.
+ + + +
+xslt ?-parameters +parameterList? ?-ignoreUndeclaredParameters? +?-maxApplyDepth int? +?-xsltmessagecmd script? stylesheet ?outputVar? +
+
Applies an XSLT transformation on the whole document of the node +object using the XSLT stylesheet (given as domDoc). Returns a document +object containing the result document of the transformation and stores that +document object in the optional outputVar, if that was given. + +

The optional -parameters option sets top level +<xsl:param> to string values. The parameterList has to be a tcl +list consisting of parameter name and value pairs.

+ +

If the option -ignoreUndeclaredParameters is given, then parameter +names in the parameterList given to the -parameters options that +are not declared as top-level parameters in the stylesheet are silently +ignored. Without this option, an error is raised if the user tries to set a +top-level parameter that is not declared in the stylesheet.

+ +

The option -maxApplyDepth expects a positiv integer as +argument. By default, the XSLT engine allows XSLT templates to nest up +to 3000 levels (and raises error if they nest deeper). This limit can +be set by the -maxApplyDepth option.

+ +

The -xsltmessagecmd option sets a callback for xslt:message elements +in the stylesheet. The actual command consists of the script, given as argument +to the option, appended with the XML Fragment from instantiating the +xsl:message element content as string (as if the XPath string() function would +have been applied to the XML Fragment) and a flag, which indicates, if the +xsl:message has an attribute "terminate" with the value "yes". If the +called script returns anything else then TCL_OK then the XSLT +transformation will be aborted, returning error. If the called script +returns -code break, the error message is empty, otherwise the result +code is reported. In case of terminated transformation, the outputVar, +if given, is set to the empty string.

+
+ + + +
+toXSLTcmd ?objVar?
+ +
If the DOM tree represents a valid XSLT stylesheet, this method +transforms the DOM tree into an XSLT command, otherwise it returns error. The +created xsltCmd is returned and stored in the objVar, if a var name was +given. A successful transformation of the DOM tree to an xsltCmd removes the +domDoc cmd and all nodeCmds of the document. + +

The syntax of the created xsltCmd is:

+ +
+xsltCmd method ?arg ...?
+
+ +

The valid methods are:

+ +
+ +
+transform ?-parameters +parameterList? ?-ignoreUndeclaredParameters? +?-maxApplyDepth int? +?-xsltmessagecmd script? domDoc ?outputVar? +
+ +
Applies XSLT transformation on the document +domDoc. Returns a document object containing the +result document of that transformation and stores it in the optional +outputVar. + +

The optional -parameters option sets top level +<xsl:param> to string values. The parameterList has to be a tcl +list consisting of parameter name and value pairs.

+ +

If the option -ignoreUndeclaredParameters is given, then parameter +names in the parameterList given to the -parameters options that +are not declared as top-level parameters in the stylesheet are silently +ignored. Without this option, an error is raised if the user tries to set a +top-level parameter, which is not declared in the stylesheet.

+ +

The option -maxApplyDepth expects a positiv integer as +argument. By default, the XSLT engine allows XSLT templates to nest up +to 3000 levels (and raises error if they nest deeper). This limit can +be set by the -maxApplyDepth option.

+ +

The -xsltmessagecmd option sets a callback for xslt:message elements +in the stylesheet. The actual command consists of the script, given as argument +to the option, appended with the XML Fragment from instantiating the +xsl:message element content as string (as if the XPath string() function would +have been applied to the XML Fragment) and a flag, which indicates, if the +xsl:message has an attribute "terminate" with the value "yes".

+
+ + + +
delete
+
Deletes the xsltCmd and cleans up all used recourses
+ +
+ +

If the first argument to an xsltCmd is a domDoc or starts with a "-", +then the command is processed in the same way as +<xsltCmd> transform.

+
+ + + +
+normalize ?-forXPath? +
+
Puts all text nodes in the document +into a "normal" form where only structure (e.g., elements, +comments, processing instructions and CDATA +sections) separates text nodes, i.e., there +are neither adjacent text nodes nor empty text nodes. If the option +-forXPath is given, all CDATA sections in the nodes are +converted to text nodes, as a first step before the +normalization.
+ + + +
nodeType
+
Returns the node type of the document node. This is always +DOCUMENT_NODE.
+ + + +
+getElementById id +
+
Returns the node having a id attribute with value +id or the empty string, if no node has an id attribute with that value.
+ + + +
+firstChild ?objVar? +
+
Returns the first top level node of the document.
+ + + +
+lastChild ?objVar? +
+
Returns the last top level node of the document.
+ + + +
+appendChild newChild +
+
Append newChild to the end of the list of top level nodes +of the document.
+ + + +
+removeChild child +
+
Removes child from the list of top level nodes of the +document. child will be part of the document fragment list +after this operation. It is not physically deleted.
+ + + +
hasChildNodes
+
Returns 1 if the document has any nodes in the tree. Otherwise 0 is returned.
+ + + +
childNodes
+
Returns a list of the top level nodes of the document.
+ + + +
+ownerDocument ?domObjVar? +
+
Returns the document itself.
+ + + +
+insertBefore newChild refChild +
+
Insert newChild before the refChild into the list of +top level nodes of the document. If refChild is the empty string, inserts +newChild at the end of the top level nodes.
+ + + +
+replaceChild newChild oldChild +
+
Replaces oldChild with newChild in the list of +children of that node. The oldChild node will be part of the +document fragment list after this operation.
+ + + +
+appendFromList list +
+
Parses list , creates an according DOM subtree and +appends this subtree at the end of the current list of top level nodes of the document.
+ + + +
+appendXML XMLstring +
+
Parses XMLstring, creates an according DOM subtree and +appends this subtree at the end of the current list of top level nodes of the document.
+ + + +
+selectNodes ?-namespaces prefixUriList? ?-cache <boolean>? ?-list? xpathQuery ?typeVar? +
+
+

Returns the result of applying the XPath query +xpathQuery to the document. The context node of the query is the root +node in the sense of the XPath recommendation (not the document element). The +result can be a string/value, a list of strings, a list of nodes or a list +of attribute name / value pairs. If typeVar is given +the result type name is stored into that variable (empty, +bool, number, string, nodes, attrnodes or mixed).

+ +

See the documentation of the of the + domNode command method + selectNodes for a detailed description of + the arguments.

+
+ + + +
+baseURI ?URI? +
+
Returns the present baseURI of the document. If the optional +argument URI is given, sets the base URI of the document to the given URI.
+ + + +
+appendFromScript tclScript +
+
Appends the nodes created by the tclScript by +Tcl functions, which have been built using dom createNodeCmd, at the end +of the current list of top level nodes of the document.
+ + + +
+insertBeforeFromScript tclScript refChild +
+
Inserts the nodes created in the tclScript by Tcl +functions, which have been built using dom +createNodeCmd, before the refChild into to the list +of top level nodes of the document. If refChild is the +empty string, the new nodes will be appended.
+ + + +
+deleteXPathCache ?xpathQuery? +
+
If called without the optional argument, all cached XPath +expressions of the document are freed. If called with the optional +argument xpathQuery, this single XPath query will be removed +from the cache, if it is there. The method always returns an +empty string.
+ + +

Otherwise, if an unknown method name is given, the command with the +same name as the given method within the namespace ::dom::domDoc is +tried to be executed. This allows quick method additions on Tcl level.

Newly created nodes are appended to a hidden fragment list. If they +are not moved into the tree they are automatically deleted as soon as the whole +document gets deleted.

+ +

SEE ALSO

dom, domNode

+ +

KEYWORDS

+DOM node creation, document element +

+ +
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/domNode.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/domNode.html new file mode 100644 index 00000000..a37b77be --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/domNode.html @@ -0,0 +1,795 @@ + + +tDOM manual: domNode + +
+
+NAME · SYNOPSIS · DESCRIPTION · SEE ALSO · KEYWORDS +
+
+

NAME

+domNode -
Manipulates an instance of a DOM node object

+ + + +

SYNOPSIS

 $nodeObject method  arg arg ...
+
+

DESCRIPTION

This command manipulates one particular instance of a DOM node object. +method indicates a specific method of the node class. These methods +should closely conform to the W3C recommendation "Document Object Model +(Core) Level 1" (http://www.w3.org/TR/REC-DOM-Level-1/level-one-core.html) +as well to parts of the W3C draft "XML Pointer Language (XPointer)" +(http://www.w3.org/TR/1998/WD-xptr-19980303). +Please note, that the XPointer methods are deprecated. Use DOM methods +or XPath expressions instead of them.

The selectNodes method implements the "XML Path +Language (XPath) Version 1.0" W3C recommendation 16 November 1999 (http://www.w3.org/TR/1999/REC-xpath-19991116). Look +at these documents for a deeper understanding of the functionality.

The valid methods are:

+ +
nodeType
+
Returns the node type of that node object. This can be: +ELEMENT_NODE, TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE or +PROCESSING_INSTRUCTION_NODE.
+ + + +
nodeName
+
Returns the node name of that node object. This is the element +(tag) name for element nodes (type ELEMENT_NODE), the processing-instruction +target for processing-instructions, "#text" for text node, +"#comment" for comment nodes or "#cdata" for cdata section +nodes.
+ + + +
+nodeValue ?newValue? +
+
Returns the value of that node object. This is the text or +the data for element nodes of type TEXT_NODE, COMMENT_NODE, +PROCESSING_INSTRUCTION_NODE or CDATA_SECTION_NODE). Otherwise it is empty. If +the node is a TEXT_NODE, COMMENT_NODE or PROCESSING_INSTRUCTION_NODE and the +optional argument newValue is given, the node is set to that +value.
+ + + + +
hasChildNodes
+
Returns 1 if the node has children. Otherwise 0 is returned.
+ + + +
+parentNode ?objVar? +
+
Returns the parent node.
+ + + +
childNodes
+
Returns a list of direct children node objects.
+ + + +
childNodesLive
+
Returns a "live" nodeList object of the child nodes of +the node in the sense of the DOM recommendation. This nodeList object is +"live" in the sense that, for instance, changes to the children of +the node object that it was created from are immediately reflected in the nodes +returned by the NodeList accessors; it is not a static snapshot of the content +of the node. The two accessors known by the nodeList object are "item +<index>", which returns the indexth item in the collection, and +"length", which returns the number of nodes in the list.
+ + + +
+firstChild ?objVar? +
+
Returns the first child as a node object.
+ + + +
+lastChild ?objVar? +
+
Returns the last child as a node object.
+ + + +
+nextSibling ?objVar? +
+
Returns the next sibling relative to the current node as a node +object.
+ + + +
+previousSibling ?objVar? +
+
Returns the next sibling relative to the current node as a node +object.
+ + + +
+getElementsByTagName name +
+
Returns a list of all elements in the subtree matching (glob +style) name.
+ + + +
+getElementsByTagNameNS uri localname +
+
Returns a list of all elements in the subtree +matching (glob style) localname and having the given namespace +uri.
+ + + +
+getElementById id +
+
Returns the node having an id attribute with value +id or the empty string if no node has an id attribute with that value.
+ + + +
+hasAttribute attributeName +
+
Returns 1 if the object node contains an attribute with name +attributeName . Otherwise 0 is returned.
+ + + +
+getAttribute attributeName ?defaultValue? +
+
Returns the value of the attribute attributeName. If the +attribute is not available defaultValue is returned.
+ + + +
+setAttribute attributeName newValue +?attributeName newValue ...? +
+
Sets the value for one or more attributes. Every + attributeName is set to the corresponding + newValue. If there isn't an attribute for one or more + of the attributeName, this will create that attribute. + It is not recommended to set attributes that look like XML + namespace declarations.
+ + + +
+removeAttribute attributeName +
+
Removes the attribute attributeName.
+ + + +
+hasAttributeNS uri localName +
+
Returns 1 if the object node contains an attribute with the +local name localName within the namespace uri. Otherwise 0 is +returned.
+ + + +
+getAttributeNS uri localName +?defaultValue? +
+
Returns the value of the attribute with the local name +localName within the namespace URI uri. If the node dosn't have +that attribute the defaultValue is returned.
+ + + +
+setAttributeNS uri qualifiedName newValue +?uri qualifiedName newValue ...?
+
+

Sets the value for one or more full qualified +attributes. Every attribute qualifiedName with the namespace URI +uri will be set to newValue. This will create a new attribute, if +it wasn't available before. If you want to set an attribute within a namespace +you must specify the attribute name with prefix, even if you want to set an +already existing attribute to a new value. While searching, if the attribute +already exists, only the given uri and the localname of the +qualifiedName is used.

+ + 
$node setAttributeNS "http://some.uri.com/wow" prefix:attr1 attrValue
+ +

If the uri is the empty string and the attribute name has no +prefix, this method has the same effect as the method +setAttribute.

+ + 
$node setAttributeNS "" attri "some Value"
+ +

With the exceptions of the special prefixes "xmlns" and "xml" you +always must provide a non empty uri if your qualifiedName has a +prefix. It is not recommended to set XML namespace declarations. The effects are complicated and not always obvious up to resulting a not well-formed serializations after further processing.

+
+ + + +
+removeAttributeNS uri localName +
+
Removes the attribute with the local name localName within + the namespace uri.
+ + + +
+attributes ?attributeNamePattern? +
+
Returns information about the attributes matching the + attributeNamePattern. If attributeNamePattern + isn't given, information about all attributes are returned. + The return value is a Tcl list, the elements just the + attribute name in case of non namespaced attributes and three + element sublists for namespaced attributes. In case of an + "ordinary" namespaced attribute, the sublist elements are + {<localname> <prefix> <namespace_uri>}. In the special case of + an XML namespace declaration it is {<the prefix defined> + <localname> ""}. +
+ + + +
+attributeNames ?attributeNamePattern? +
+
Returns a flat list of all attributes names (as found in + the XML source) matching the attributeNamePattern. If + attributeNamePattern isn't given, all attribute names + are returned as a Tcl list.
+ + + +
+appendChild newChild +
+
Appends newChild to the end of the child list of the +node.
+ + + +
+insertBefore newChild refChild +
+
Inserts newChild before the refChild into the list of +children of node. If refChild is the empty string, insert +newChild at the end of the child nodes list of that node.
+ + + +
+replaceChild newChild oldChild +
+
Replaces oldChild with newChild in the list of +children of that node. The oldChild node will be part of the +document fragment list after this operation.
+ + + +
+removeChild child +
+
Removes child from the list of children of that node. +child will be part of the document fragment list after this +operation.
+ + + +
delete
+
Deletes the given node and its complete child tree +and frees the complete internal memory. The affected nodes are not accessible +through the document fragment list.
+ + + +
+cloneNode ?-deep? +
+
Clones this node and adds the new create node into the document +fragment list. If the -deep option is specified, all descendant nodes +are also cloned.
+ + + +
+ownerDocument ?domObjVar? +
+
Returns the document object of the document this node belongs +to.
+ + + +
+find attrName attrVal +?objVar? +
+
Finds the node with the attribute name attrName, and +attribute value attrVal in the subtree starting the current node.
+ + + +
+child number|all type +attrName attrValue +
+
(XPointer) child
+ + + +
+descendant number|all type +attrName attrValue +
+
(XPointer) descendant
+ + + +
+ancestor number|all type +attrName attrValue +
+
(XPointer) ancestor
+ + + +
+fsibling number|all type +attrName attrValue +
+
(XPointer) fsibling
+ + + +
+psibling number|all type +attrName attrValue +
+
(XPointer) psibling
+ + + +
+root objVar +
+
(XPointer) root
+ + + +
text
+
Returns all text node children of that current node combined, +i.e. appended into one string.
+ + + +
target
+
For a processing instruction node the target part is returned. +Otherwise an error is generated.
+ + + +
data
+
For a processing instruction node the data part is returned. For +a text node, comment node or cdata section node the value is returned. +Otherwise an error is generated.
+ + + +
prefix
+
Returns the namespace prefix.
+ + + +
namespaceURI
+
Returns the namespace URI.
+ + + +
localName
+
Returns the localName from the tag name of the given node.
+ + + +
+selectNodes ?-namespaces prefixUriList? ?-cache <boolean>? ?-list? xpathQuery ?typeVar? +
+
+

Returns the result of applying the XPath query +xpathQuery to the subtree. This result can be a +string/value, a list of strings, a list of nodes or a list +of attribute name / value pairs. If typeVar argument is given +the result type name is stored into that variable (empty, +bool, number, string, nodes, attrnodes or mixed).

+ +

The argument xpathQuery has to be a valid XPath 1.0 expression. +However there are a few exceptions to that rule. Tcl variable +references (in the usual tcl syntax: $varname) may appear in the XPath +statement at any position where it is legal according to the rules of +the XPath syntax to put an XPath variable. Ignoring the syntax rules of +XPath the Tcl variable name may be any legal Tcl var name: local +variables, global variables, array entries and so on. The value will +always be seen as string literal by the xpath engine. Cast the value +explicitly with the according xpath functions (number(), boolean()) to +another data type, if needed.

+ +

Similar to the way described above to inject literals in a secure +way into the XPath expression using tcl variable references there is a +syntax to inject element names from tcl variables. At every place +where the XPath syntax allows a node test there could be a Tcl +variable reference (in any form), just the leading $ replaced with %. +This allows one to select nodes with 'strange' (invalid, according to the +appropriate XML production rule) node names which may be needed in +case of working with JSON data.

+ +

The option -namespaces expects a Tcl list with prefix / +namespace pairs as argument. If this option is not given, then any +namespace prefix within the xpath expression will be first resolved +against the list of prefix / namespace pairs set with the +selectNodesNamespaces method for the document, the node belongs to. If +this fails, then the namespace definitions in scope of the context +node will be used to resolve the prefix. If this option is given, any +namespace prefix within the xpath expression will be first resolved +against that given list (and ignoring the document global prefix / +namespace list). If the list binds the same prefix to different +namespaces, then the first binding will win. If this fails, then the +namespace definitions in scope of the context node will be used to +resolve the prefix, as usual.

+ +

If the -cache option is used with a true value, then the +xpathQuery will be looked up in a document specific cache. If +the query is found, then the stored pre-compiled query will be used. +If the query isn't found, it will be compiled and stored in the cache, +for use in further calls. Please note that the xpathQuery +given as string is used as key for the cache. This means, that equal +XPath expressions, which differ only in white space are treated as +different cache entries. Special care is needed, if the XPath +expression includes namespace prefixes or references to Tcl variables. +Both namespace prefixes and Tcl variable references will be resolved +according to the XML prefix namespace mappings and Tcl variable values +at expression compilation time. If the same XPath expression is used +later on in a context with other XML prefix namespace mappings or +values of the used Tcl variables, make sure to first remove the +compiled expression from the cache with the help of the +deleteXPathCache method, to force a recompilation. +Without using the -cache option such consideration is never +needed.

+ +

If the -list option is given then the xpathQuery +argument is expected to be a Tcl list of XPath queries. Every XPath +query in this list other than the last one must return a node set +result. Using the context and namespace resolution rules as without +the -list option the first query out of the list is run. Every +node out of the result set of this query is used as context node for +the next XPath query out of the list and so on. It returns the result +sets of the last query in the query list concatenated together.

+ +

Examples:

+ 
set paragraphNodes [$node selectNodes {chapter[3]//para[@type='warning' or @type='error'} ]
+foreach paragraph $paragraphNodes {
+    lappend  values [$paragraph selectNodes attribute::type]
+}
+
+set doc [dom parse {<doc xmlns="http://www.defaultnamespace.org"><child/></doc>}]
+set root [$doc documentElement]
+set childNodes [$root selectNodes -namespaces {default http://www.defaultnamespace.org} default:child]
+ +
+ + + +
getLine
+
Returns the line number of that node in the originally + parsed XML. The counting starts with 1
+ + + +
getColumn
+
Returns the column number of that node in the originally + parsed XML. The counting starts with 0
+ + + +
getByteIndex
+
Returns the byte position of that node in the originally + parsed XML. The counting starts with 0.
+ + + +
asList
+
Returns the DOM substree starting from the current node as a +nested Tcl list.
+ + + +
+asXML ?-indent none/tabs/1..8? ?-channel channelId? ?-escapeNonASCII? ?-doctypeDeclaration <boolean>? -xmlDeclaration <boolean>? -encString <string> ?-escapeAllQuot? ?-indentAttrs? ?-nogtescape? ?-noEmptyElementTag? ?-escapeCR? ?-escapeTab? +
+
+

Returns the DOM substree starting from the current + node as the root node of the result as an (optional indented) + XML string or sends the output directly to the given + channelId.

+ +

See the documentation of the + domDoc command method + asXML for a detailed description of the + arguments.

+
+ + + +
+asCanonicalXML ?-channel channelId? ?-comment? +
+
+

Returns the DOM tree as canonical XML string + according to the "Canonical + XML Version 1.0 W3C Recommendation 15 March 2001" or + sends the output directly to the given channelId.

+ +

See the documentation of the + domDoc command method + asCanonicalXML for a detailed description of the + arguments.

+
+ + + +
+asHTML ?-channel +channelId? b?-escapeNonASCII? ?-htmlEntities? ?-doctypeDeclaration <boolean>? ?-breakLines? ?-onlyContents? +
+
+

Returns the DOM substree starting from the current + node as the root node of the result serialized according to + HTML rules (HTML elements are recognized regardless of case, + without end tags for empty HTML elements etc.), as string or + sends the output directly to the given channelId.

+ +

See the documentation of the domDoc + method asHTML for a detailed description of + the arguments.

+
+ + + +
asText
+
For ELEMENT_NODEs, the asText method outputs +the string-value of every text node descendant of node in document +order without any escaping. For every other node type, this method outputs the XPath string value of that node.
+ + + +
+asJSON ?-indent none/0..8? ?-channel channelId? +
+
+

The asJSON method serializes the subtree starting with the node the method was called on into a valid + JSON data string.

+ +

See the documentation of the domDoc + method asJSON for a detailed description of + the method

+
+ + + +
+asTclValue ?typevariable? +
+
+

In case the subtree starting with the node the method + was called on includes JSON type information this method + returns the JSON data as nested Tcl data structure.

+

See the documentation of the domDoc + method asTclValue for a detailed description of + the method

+
+ + + +
+appendFromList list +
+
Parses list , creates an according DOM subtree and +appends this subtree to the current node.
+ + + +
+appendFromScript tclScript +
+
Appends the nodes created in the tclScript by +Tcl functions, which have been built using dom createNodeCmd, to the +given node.
+ + + +
+insertBeforeFromScript tclScript refChild +
+
Inserts the nodes created in the tclScript by +Tcl functions, which have been built using dom createNodeCmd, before the +refChild into the list of children of node. If refChild is +the empty string, the new nodes will be appended.
+ + + +
+appendXML XMLstring +
+
Parses XMLstring, creates an according DOM subtree and +appends this subtree to the current node.
+ + + +
+simpleTranslate outputVar +specifications +
+
Translates the subtree starting at the object node according to +the specifications in specifications and outputs the result in the +variable outputVar . The translation is very similar to Cost Simple +mode.
+ + + +
+toXPath ?-legacy? +
+
Returns an XPath, which exactly addresses the given +node in its document. This XPath is only valid as there are no changes to DOM +tree made later one. With the -legacy option, other XPath expressions +are returned, which doesn't work in all cases.
+ + + +
getBaseURI
+
Returns the baseURI of the node. This method is deprecated in + favor of the baseURI method.
+ + + +
+baseURI ?URI? +
+
Returns the present baseURI of the node. If the optional +argument URI is given, it sets the base URI of the node and of all of its child +nodes out of the same entity as node to the given URI.
+ + + +
+disableOutputEscaping ?boolean? +
+
This method works only for text nodes; for every other node it +returns error. Without the optional argument it returns, if disabling output +escaping is on. The return value 0 means, the characters of the text node will +be escaped, to generate valid XML, if serialized. This is the default for +every parsed or created text node (with the exception of that text nodes in a +result tree of an XSLT transformation, for which disabling output escaping was +requested explicitly in the stylesheet). The return value 1 means, that output +escaping is disabled for this text node. If such a text node is serialized +(with asXML or asHTML), it is literally written, without escaping of the +special XML characters. If the optional boolean value boolean is given, +the flag is set accordingly. You should not set this flag to 1 until you +really know what you do.
+ + + +
+precedes refnode +
+
Compares the relative order of the node and refnode. Both +nodes must be part of the same documents and not out of the fragment list of +the document. Returns true if node is in document order (in the sense of the +XPath 1.0 recommendation) before refnode, and false otherwise.
+ + + + +
+normalize ?-forXPath? +
+
Puts all Text nodes in the full depth of the sub-tree underneath +this Node into a "normal" form where only structure (e.g., elements, +comments, processing instructions and CDATA +sections) separates Text nodes, i.e., there +are neither adjacent Text nodes nor empty Text nodes. If the option +-forXPath is given, all CDATA sections in the nodes are +converted to text nodes, as a first step before the +normalization.
+ + + +
+xslt ?-parameters +parameterList? ?-ignoreUndeclaredParameters? +?-maxApplyDepth int? +?-xsltmessagecmd script? stylesheet ?outputVar? +
+
Applies an XSLT transformation on the document using the XSLT +stylesheet (given as domDoc). Returns a document object containing the +result document of that transformation and stores it in the optional +outputVar. + +

The optional -parameters option sets top level +<xsl:param> to string values. The parameterList has to be a Tcl +list consisting of parameter name and value pairs.

+ +

If the option -ignoreUndeclaredParameters is given, then parameter +names in the parameterList given to the -parameters options that +are not declared as top-level parameters in the stylesheet are silently +ignored. Without this option, an error is raised if the user tries to set a +top-level parameter which is not declared in the stylesheet.

+ +

The option -maxApplyDepth expects a positive integer as +argument. By default, the XSLT engine allows XSLT templates to nest up +to 3000 levels (and raises error if they nest deeper). This limit can +be set by the -maxApplyDepth option.

+ +

The -xsltmessagecmd option sets a callback for xslt:message elements +in the stylesheet. The actual command consists of the script, given as argument +to the option, appended with the XML Fragment from instantiating the +xsl:message element content as string (as if the XPath string() function would +have been applied to the XML Fragment) and a flag, which indicates whether the +xsl:message has an attribute "terminate" with the value "yes". If the +called script returns anything else then TCL_OK then the XSLT +transformation will be aborted, returning error. If the called script +returns -code break the error message is empty, otherwise the result +code is reported. In case of terminated transformation the outputVar, +if given, is set to the empty string.

+
+ + + +
@attrName
+
Returns the value of the attribute attrName. Short cut +for getAttribute.
+ + + +
+jsonType ?(OBJECT|ARRAY|NONE)|(STRING|NUMBER|TRUE|FALSE|NULL|NONE)? +
+
Only element and text nodes may have a JSON type and + only this types of nodes support the jsonType method; + the other node types return error if called with this method. + Returns the jsonType of the node. If the optional argument is + given, the JSON type of the node is set to the given type and + returned. Valid type arguments for element nodes are OBJECT, + ARRAY and NONE. Valid type arguments for text nodes are + STRING, NUMBER, TRUE, FALSE, NULL and NONE.
+ + +

Otherwise, if an unknown method name is given, the command with the same +name as the given method within the namespace ::dom::domNode is tried to +be executed. This allows quick method additions on Tcl level.

+ + +

SEE ALSO

dom, domDoc

+ +

KEYWORDS

+XML, DOM, document, node, parsing +

+ +
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/expat.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/expat.html new file mode 100644 index 00000000..d4b1bb74 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/expat.html @@ -0,0 +1,934 @@ + + +tDOM manual: expat + +
+
+NAME · SYNOPSIS · DESCRIPTION · COMMAND OPTIONS · COMMAND METHODS · Callback Command Return Codes · SEE ALSO · KEYWORDS +
+
+

NAME

+expat -
Creates an instance of an expat parser object

+ + + +

SYNOPSIS

package require tdom
+
+expat ?parsername? ?-namespace? ?arg arg ..
+
+xml::parser ?parsername? ?-namespace? ?arg arg ..
+
+

DESCRIPTION

The parser created with expat or xml::parser +(which is just another name for the same command in an own namespace) are able +to parse any kind of well-formed XML. The parsers are stream oriented XML +parser. This means that you register handler scripts with the parser prior to +starting the parse. These handler scripts are called when the parser discovers +the associated structures in the document being parsed. A start tag is an +example of the kind of structures for which you may register a handler +script.

The parsers always check for XML well-formedness of the input (and +report error, if the input isn't well-formed). They parse the internal +DTD and, at request, external DTD and external entities, if you +resolve the identifier of the external entities with the +-externalentitycommand script (see there). If you use the -validateCmd +option (see there), the input is additionally validated.

Additionly, the Tcl extension code that implements this command provides an +API for adding C level coded handlers. Up to now, there exists the parser +extension command "tdom". The handler set installed by this extension build an +in memory "tDOM" DOM tree, while the parser is parsing the input.

It is possible to register an arbitrary amount of different handler scripts +and C level handlers for most of the events. If the event occurs, they are +called in turn.

+ +

COMMAND OPTIONS

+ +
-namespace
+ +
+

Enables namespace parsing. You must use this option while +creating the parser with the expat or xml::parser +command. You can't enable (nor disable) namespace parsing with +<parserobj> configure ....

+
+ + + +
+-namespaceseparator char +
+ + +

This option has only effect, if used together with + the option -namespace. If given, this option + determines the character inserted between namespace URI and + the local name, while reporting an XML element name to a + handler script. The default is the character ':'. The + value must be a one-character string less or equal to + \u00FF, preferably a 7-bit ASCII character or the empty + string. If the value is the empty string (as well, as if the + value is \x00) the namespace URI and the local name will be + concatenated without any separator.

+ + + +
+-final boolean +
+ + +
+

This option indicates whether the document data next +presented to the parse method is the final part of the document. A value of "0" +indicates that more data is expected. A value of "1" indicates that no more is +expected. The default value is "1".

+ +

If this option is set to "0" then the parser will not report certain errors +if the XML data is not well-formed upon end of input, such as unclosed or +unbalanced start or end tags. Instead some data may be saved by the parser +until the next call to the parse method, thus delaying the reporting of some of +the data.

+ +

If this option is set to "1" then documents which are not well-formed upon +end of input will generate an error.

+
+ + + +
+-validateCmd <tdom schema cmd> +
+ + +

This option expects the name of a tDOM schema + command. If this option is given, then the input is also + validated. If the schema command hasn't set a reportcmd then + the first validation error will stop further parsing (as a + well-formedness error).

+ + + +
+-baseurl url +
+ + +

Reports the base url of the document to the +parser.

+ + + +
+-fastcall boolean +
+ + +
+

By default this option is 0 (off). If this option + is on then any handler installed by the options + -elementstartcommand, -elementendcommand and + -characterdatacommand from this moment on is + installed in a way that calling it has lesser overhead as + usual. This option may be switched between callback hander + (re-)installion as desired.

+ +

However this has some requirenments. The handler proc has + to be defined before used as callback. If it is not then + the callback is installed as ususal. And the handler proc + must not be removed or re-defined as long as it is used as + callback. If this is done the programm probably will crash + but also may execute arbitrary code.

+ +

The callback handler installed while this option is on + will not be traced by executing them.

+
+ + + +
+-keepTextStart boolean +
+ + +

By default this option is 0 (off). If this option + is on then the position information of the start of a text + or CDATA node is keeped over collecting the sometimes by + expat delivered cdata pieces. With this option on the + position information returned by the parser in a + -characterdatacommand proc will be correct, otherwise not. + Called in all other handler code the parser always return + the correct position results, no matter what value this + option have. It is off by default because it is rarely + needed and saves a few cpu cyles this way.

+ + + +
+-elementstartcommand script +
+ + +
+

Specifies a Tcl command to associate with the start tag of +an element. The actual command consists of this option followed by at least two +arguments: the element type name and the attribute list.

+ +

The attribute list is a Tcl list consisting of name/value pairs, suitable +for passing to the array set Tcl command.

+ +

Example:

+
proc HandleStart {name attlist} {
+    puts stderr "Element start ==> $name has attributes $attlist"
+}
+
+$parser configure -elementstartcommand HandleStart
+
+$parser parse {<test id="123"></test>}
+
+ +

This would result in the following command being invoked:

+
HandleStart text {id 123}
+
+ + + +
+-elementendcommand script +
+ + +
+

Specifies a Tcl command to associate with the end tag of an +element. The actual command consists of this option followed by at least one +argument: the element type name. In addition, if the -reportempty option is set +then the command may be invoked with the -empty configuration option to +indicate whether it is an empty element. See the description of the +-reportempty option for an example.

+ +

Example:

+
proc HandleEnd {name} {
+    puts stderr "Element end ==> $name"
+}
+
+$parser configure -elementendcommand HandleEnd
+
+$parser parse {<test id="123"></test>}
+
+ +

This would result in the following command being invoked:

+
+HandleEnd test
+
+
+ + + + +
+-characterdatacommand script +
+ + +
+

Specifies a Tcl command to associate with character data in +the document, ie. text. The actual command consists of this option followed by +one argument: the text.

+ +

Other than with the C API of the expat parser it is guaranteed that +character data will be passed to the application in a single call to +this command.

+ +

Example:

+ +
proc HandleText {data} {
+    puts stderr "Character data ==> $data"
+}
+
+$parser configure -characterdatacommand HandleText
+
+$parser parse {<test>this is a test document</test>}
+
+ +

This would result in the following command being invoked:

+ +
HandleText {this is a test document}
+
+ + + + +
+-processinginstructioncommand script +
+ + +
+

Specifies a Tcl command to associate with processing +instructions in the document. The actual command consists of this option +followed by two arguments: the PI target and the PI data.

+ +

Example:

+ +
proc HandlePI {target data} {
+    puts stderr "Processing instruction ==> $target $data"
+}
+
+$parser configure -processinginstructioncommand HandlePI
+
+$parser parse {<test><?special this is a processing instruction?></test>}
+
+ +

This would result in the following command being invoked:

+ +
+HandlePI special {this is a processing instruction}
+
+
+ + + +
+ -notationdeclcommand script +
+ + +

Specifies a Tcl command to associate with notation +declaration in the document. The actual command consists of this option +followed by four arguments: the notation name, the base uri of the document +(this means, whatever was set by the -baseurl option), the system identifier +and the public identifier. The notation name is never empty, the other +arguments may be.

+ + + +
+ -externalentitycommand script +
+ + +
+

Specifies a Tcl command to associate with references to +external entities in the document. The actual command consists of this option +followed by three arguments: the base uri, the system identifier of the entity +and the public identifier of the entity. The base uri and the public identifier +may be the empty list.

+ +

This handler script has to return a tcl list consisting of three +elements. The first element of this list signals, how the external entity is +returned to the processor. At the moment, the three allowed types are +"string", "channel" and "filename". The second +element of the list has to be the (absolute) base URI of the external entity to +be parsed. The third element of the list are data, either the already read +data out of the external entity as string in the case of type +"string", or the name of a tcl channel, in the case of type +"channel", or the path to the external entity to be read in case of +type "filename". Behind the scene, the external entity referenced by +the returned Tcl channel, string or file name will be parsed with an expat +external entity parser with the same handler sets as the main parser. If +parsing of the external entity fails, the whole parsing is stopped with an +error message. If a Tcl command registered as externalentitycommand isn't able +to resolve an external entity it is allowed to return TCL_CONTINUE. In this +case, the wrapper give the next registered externalentitycommand a try. If no +externalentitycommand is able to handle the external entity parsing stops with +an error.

+ +

Example:

+ +
proc externalEntityRefHandler {base systemId publicId} {
+    if {![regexp {^[a-zA-Z]+:/} $systemId]}  {
+        regsub {^[a-zA-Z]+:} $base {} base
+        set basedir [file dirname $base]
+        set systemId "[set basedir]/[set systemId]"
+    } else {
+        regsub {^[a-zA-Z]+:} $systemId systemId
+    }
+    if {[catch {set fd [open $systemId]}]} {
+        return -code error \
+                -errorinfo "Failed to open external entity $systemId"
+    }
+    return [list channel $systemId $fd]
+}
+
+set parser [expat -externalentitycommand externalEntityRefHandler \
+                  -baseurl "file:///local/doc/doc.xml" \
+                  -paramentityparsing notstandalone]
+$parser parse {<?xml version='1.0'?>
+<!DOCTYPE test SYSTEM "test.dtd">
+<test/>}
+
+ +

This would result in the following command being invoked:

+ +
+externalEntityRefHandler file:///local/doc/doc.xml test.dtd {}
+
+ +

External entities are only tried to resolve via this handler script, if +necessary. This means, external parameter entities triggers this handler only, +if -paramentityparsing is used with argument "always" or if +-paramentityparsing is used with argument "notstandalone" and the +document isn't marked as standalone.

+
+ + + +
+ -unknownencodingcommand script +
+ + +

Not implemented at Tcl level.

+ + + +
+-startnamespacedeclcommand script +
+ + +

Specifies a Tcl command to associate with start scope of +namespace declarations in the document. The actual command consists of this +option followed by two arguments: the namespace prefix and the namespace +URI. For an xmlns attribute, prefix will be the empty list. For an +xmlns="" attribute, uri will be the empty list. The call to the start +and end element handlers occur between the calls to the start and end namespace +declaration handlers.

+ + + +
+ -endnamespacedeclcommand script +
+ + +

Specifies a Tcl command to associate with end scope of +namespace declarations in the document. The actual command consists of this +option followed by the namespace prefix as argument. In case of an xmlns +attribute, prefix will be the empty list. The call to the start and end element +handlers occur between the calls to the start and end namespace declaration +handlers.

+ + + +
+ -commentcommand script +
+ + +
+

Specifies a Tcl command to associate with comments in the +document. The actual command consists of this option followed by one argument: +the comment data.

+ +

Example:

+ +
+proc HandleComment {data} {
+    puts stderr "Comment ==> $data"
+}
+
+$parser configure -commentcommand HandleComment
+
+$parser parse {<test><!-- this is <obviously> a comment --></test>}
+
+ +

This would result in the following command being invoked:

+ +
+HandleComment { this is <obviously> a comment }
+
+
+ + + +
+ -notstandalonecommand script +
+ + +

This Tcl command is called, if the document is not +standalone (it has an external subset or a reference to a parameter entity, but +does not have standalone="yes"). It is called with no additional +arguments.

+ + + +
+ -startcdatasectioncommand script +
+ + +

Specifies a Tcl command to associate with the start of a +CDATA section. It is called with no additional arguments.

+ + + +
+ -endcdatasectioncommand script +
+ + +

Specifies a Tcl command to associate with the end of a CDATA +section. It is called with no additional arguments.

+ + + +
+ -elementdeclcommand script +
+ + +
+

Specifies a Tcl command to associate with element +declarations. The actual command consists of this option followed by two +arguments: the name of the element and the content model. The content model arg +is a tcl list of four elements. The first list element specifies the type of +the XML element; the six different possible types are reported as +"MIXED", "NAME", "EMPTY", "CHOICE", +"SEQ" or "ANY". The second list element reports the +quantifier to the content model in XML Syntax ("?", "*" or +"+") or is the empty list. If the type is "MIXED", then the +quantifier will be "{}", indicating an PCDATA only element, or +"*", with the allowed elements to intermix with PCDATA as tcl list as +the fourth argument. If the type is "NAME", the name is the third +arg; otherwise the third argument is the empty list. If the type is +"CHOICE" or "SEQ" the fourth argument will contain a list +of content models build like this one. The "EMPTY", "ANY", +and "MIXED" types will only occur at top level.

+ +

Examples:

+ +
+proc elDeclHandler {name content} {
+     puts "$name $content"
+}
+
+set parser [expat -elementdeclcommand elDeclHandler]
+$parser parse {<?xml version='1.0'?>
+<!DOCTYPE test [
+<!ELEMENT test (#PCDATA)> 
+]>
+<test>foo</test>}
+
+ +

This would result in the following command being invoked:

+ +
+test {MIXED {} {} {}}
+
+$parser reset
+$parser parse {<?xml version='1.0'?>
+<!DOCTYPE test [
+<!ELEMENT test (a|b)>
+]>
+<test><a/></test>}
+
+ +

This would result in the following command being invoked:

+ +
+elDeclHandler test {CHOICE {} {} {{NAME {} a {}} {NAME {} b {}}}}
+
+
+ + + + +
+ -attlistdeclcommand script +
+ + +
+

Specifies a Tcl command to associate with attlist +declarations. The actual command consists of this option followed by five +arguments. The Attlist declaration handler is called for *each* attribute. So +a single Attlist declaration with multiple attributes declared will generate +multiple calls to this handler. The arguments are the element name this +attribute belongs to, the name of the attribute, the type of the attribute, the +default value (may be the empty list) and a required flag. If this flag is true +and the default value is not the empty list, then this is a "#FIXED" +default.

+ +

Example:

+ +
+proc attlistHandler {elname name type default isRequired} {
+    puts "$elname $name $type $default $isRequired"
+}
+
+set parser [expat -attlistdeclcommand attlistHandler]
+$parser parse {<?xml version='1.0'?>
+<!DOCTYPE test [
+<!ELEMENT test EMPTY>
+<!ATTLIST test
+          id      ID      #REQUIRED
+          name    CDATA   #IMPLIED>
+]>
+<test/>}
+
+ +

This would result in the following commands being invoked:

+ +
+attlistHandler test id ID {} 1
+attlistHandler test name CDATA {} 0
+
+
+ + + +
+ -startdoctypedeclcommand script +
+ + +

Specifies a Tcl command to associate with the start of the +DOCTYPE declaration. This command is called before any DTD or internal subset +is parsed. The actual command consists of this option followed by four +arguments: the doctype name, the system identifier, the public identifier and a +boolean, that shows if the DOCTYPE has an internal subset.

+ + + +
+ -enddoctypedeclcommand script +
+ + +

Specifies a Tcl command to associate with the end of the +DOCTYPE declaration. This command is called after processing any external +subset. It is called with no additional arguments.

+ + + +
+ -paramentityparsing never|notstandalone|always +
+ + +

"never" disables expansion of parameter entities, +"always" expands always and "notstandalone" only, if the +document isn't "standalone='no'". The default ist "never"

+ + + +
+ -entitydeclcommand script +
+ + +

Specifies a Tcl command to associate with any entity +declaration. The actual command consists of this option followed by seven +arguments: the entity name, a boolean identifying parameter entities, the value +of the entity, the base uri, the system identifier, the public identifier and +the notation name. According to the type of entity declaration some of this +arguments may be the empty list.

+ + + + +
+ -ignorewhitecdata boolean +
+ + +

If this flag is set, element content which contain only +whitespaces isn't reported with the +-characterdatacommand.

+ + + +
+ -ignorewhitespace boolean +
+ + +
Another name for -ignorewhitecdata; see there. +
+ + + +
+ -handlerset name +
+ + +

This option sets the Tcl handler set scope for the +configure options. Any option value pair following this option in the +same call to the parser are modifying the named Tcl handler set. If +you don't use this option, you are modifying the default Tcl handler +set, named "default".

+ + + +
+ -noexpand boolean +
+ + +
+

Normally, the parser will try to expand references to +entities defined in the internal subset. If this option is set to a true value +this entities are not expanded, but reported literal via the default +handler. Warning: If you set this option to true and doesn't install a +default handler (with the -defaultcommand option) for every handler set of the +parser all internal entities are silent lost for the handler sets without a +default handler.

+
+ + + +
+-useForeignDTD <boolean> +
+ +
If <boolean> is true and the document does not have an +external subset, the parser will call the -externalentitycommand script with +empty values for the systemId and publicID arguments. This option must be set, +before the first piece of data is parsed. Setting this option, after the +parsing has started has no effect. The default is not to use a foreign DTD. The +default is restored, after resetting the parser. Pleace notice, that a +-paramentityparsing value of "never" (which is the default) suppresses any call +to the -externalentitycommand script. Pleace notice, that, if the document also +doesn't have an internal subset, the -startdoctypedeclcommand and +enddoctypedeclcommand scripts, if set, are not called.
+ + + +
+-billionLaughsAttackProtectionMaximumAmplification <float> +
+ +
This option together with + -billionLaughsAttackProtectionActivationThreshold + gives control over the parser limits that protects + against billion laugh attacks + (https://en.wikipedia.org/wiki/Billion_laughs_attack). + This option expects a float >= 1.0 as argument. You + should never need to use this option, because the + default value (100.0) should work for any real data. + If you ever need to increase this value for non-attack + payload, please report.
+ + + +
+-billionLaughsAttackProtectionActivationThreshold <long> +
+ +
This option together with + -billionLaughsAttackProtectionMaximumAmplification + gives control over the parser limits that protects + against billion laugh attacks + (https://en.wikipedia.org/wiki/Billion_laughs_attack). + This option expects a positiv integer as argument. You + should never need to use this option, because the + default value (8388608) should work for any real data. + If you ever need to increase this value for non-attack + payload, please report.
+ + +
+

COMMAND METHODS

+ +
+parser configure option value ?option value? +
+ +

Sets configuration options for the parser. Every command +option, except -namespace can be set or modified with this method.

+ + + +
+parser cget ?-handlerset name? option +
+ +
+

Return the current configuration value option for the +parser.

+

If the -handlerset option is used, the configuration for the +named handler set is returned.

+
+ + + +
+parser currentmarkup +
+ +

Returns the current markup as found in the XML, if + called from within one of its markup event handler script + (-elementstartcommand, -elementendcommand, -commentcommand + and -processinginstructioncommand). Otherwise it return the + empty string.

+ + + +
+parser delete +
+ +

Deletes the parser and the parser command. A parser cannot +be deleted from within one of its handler callbacks (neither directly nor +indirectly) and will raise a tcl error in this case.

+ + + +
+parser free +
+ +

Another name to call the method delete, see + there.

+ + + +
+parser get -specifiedattributecount|-idattributeindex|-currentbytecount|-currentlinenumber|-currentcolumnnumber|-currentbyteindex +
+
+
+ +
-specifiedattributecount
+ +

Returns the number of the attribute/value pairs +passed in last call to the elementstartcommand that were specified in the +start-tag rather than defaulted. Each attribute/value pair counts as 2; thus +this corresponds to an index into the attribute list passed to the +elementstartcommand.

+ + + +
-idattributeindex
+ +

Returns the index of the ID attribute passed in the +last call to XML_StartElementHandler, or -1 if there is no ID attribute. Each +attribute/value pair counts as 2; thus this corresponds to an index into the +attributes list passed to the elementstartcommand.

+ + + +
-currentbytecount
+ +
+

Return the number of bytes in the current event. + Returns 0 if the event is in an internal entity.

+ +

If you use this option consider if you may need the + parser option -keepTextStart.

+
+ + + +
-currentlinenumber
+ +
+

Returns the line number of the current parse + location.

+ +

If you use this option consider if you may need the + parser option -keepTextStart.

+
+ + + +
-currentcolumnnumber
+ +
+

Returns the column number of the current + parse location.

+ +

If you use this option consider if you may need the + parser option -keepTextStart.

+
+ + + +
-currentbyteindex
+ +
+

Returns the byte index of the current parse + location.

+ +

If you use this option consider if you may need the + parser option -keepTextStart.

+
+ +
+

Only one value may be requested at a time.

+
+ + + +
+parser parse data +
+ +

Parses the XML string data. The event callback +scripts will be called, as there triggering events happens. This method cannot +be used from within a callback (neither directly nor indirectly) of +the parser to be used and will raise an error in this case.

+ + + +
+parser parsechannel channelID +
+

Reads the XML data out of the tcl channel channelID +(starting at the current access position, without any seek) up to the end of +file condition and parses that data. The channel encoding is respected. Use the +helper proc tDOM::xmlOpenFile out of the tDOM script library to open a file, if +you want to use this method. This method cannot +be used from within a callback (neither directly nor indirectly) of +the parser to be used and will raise an error in this case.

+ + + +
+parser parsefile filename +
+ +

Reads the XML data directly out of the file with the +filename filename and parses that data. This is done with low-level file +operations. The XML data must be in US-ASCII, ISO-8859-1, UTF-8 or UTF-16 +encoding. If applicable, this is the fastest way, to parse XML data. This +method cannot be used from within a callback (neither directly nor indirectly) +of the parser to be used and will raise an error in this case.

+ + + +
+parser reset +
+ +

Resets the parser in preparation for parsing another +document. A parser cannot be reset from within one of its handler callbacks +(neither directly nor indirectly) and will raise a tcl error in this +cases.

+ +
+ +

Callback Command Return Codes

A script invoked for any of the parser callback commands, such as +-elementstartcommand, -elementendcommand, etc, may return an error code other +than "ok" or "error". All callbacks may in addition return +"break" or "continue".

If a callback script returns an "error" error code then +processing of the document is terminated and the error is propagated in the +usual fashion.

If a callback script returns a "break" error code then all +further processing of every handler script out of this Tcl handler set is +suppressed for the further parsing. This does not influence any other handler +set.

If a callback script returns a "continue" error code then +processing of the current element, and its children, ceases for every handler +script out of this Tcl handler set and processing continues with the next +(sibling) element. This does not influence any other handler set.

If a callback script returns a "return" error +code then parsing is canceled altogether, but no error is raised.

+ +

SEE ALSO

+expatapi, tdom +

+ +

KEYWORDS

+SAX, push, pushparser +

+
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/expatapi.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/expatapi.html new file mode 100644 index 00000000..4c6f85a1 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/expatapi.html @@ -0,0 +1,209 @@ + + +tDOM manual: expatapi + +
+
+NAME · SYNOPSIS · ARGUMENTS · DESCRIPTION · SEE ALSO · KEYWORDS +
+
+

NAME

+CheckExpatParserObj, CHandlerSetInstall, CHandlerSetRemove, + CHandlerSetCreate, CHandlerSetGetUserData, GetExpatInfo -
Functions to create, install and remove expat parser object +extensions.

+

SYNOPSIS

#include <tclexpat.h>
+
+int 
+CheckExpatParserObj (interp, nameObj)  
+
+int
+CHandlerSetInstall (interp, expatObj, handlerSet)
+
+int 
+CHandlerSetRemove (interp, expatObj, handlerSetName)
+
+CHandlerSet*
+CHandlerSetCreate (handlerSetName)
+
+CHandlerSet*
+CHandlerSetGet (interp, expatObj, handlerSetName)
+
+void*
+CHandlerSetGetUserData (interp, expatObj, handlerSetName)
+
+TclGenExpatInfo*
+GetExpatInfo (interp, expatObj)
+
+ +

ARGUMENTS

+ + + + + + + + + + + + + + + + + + + + + + + +
TypeNameMode
Tcl_Interp*interpin
 Interpreter with the expat parser object.
Tcl_Obj*expatObjin
 A Tcl Object containing the command name of the expat parser object to be queried or modified.
char*handlerSetNamein
 Identifier of the handler set.
CHandlerSet*handlerSetin
 Pointer to a C handler set.
Tcl_Obj*nameObj
 A Tcl Object containing the name of a expat parser object
+ +

DESCRIPTION

The functions described in this manual allows one to add C level coded event +handler to an tDOM Tcl expat parser objects. A tDOM Tcl expat parser object is +able to have several Tcl scripts and C functions associated with a specific +event. If the event occurs, first the Tcl scripts then the C functions +associated with the event are called in turn.

A tDOM Tcl expat parser extension is an ordinary Tcl extension and loaded +like every other Tcl extension. It must install at least one new Tcl Level +command, that manipulates a tDOM Tcl expat parser object.

A C level handler set is a data structure like this:

+typedef struct CHandlerSet {
+    struct CHandlerSet *nextHandlerSet;
+    char *name;                     /* refname of the handler set */
+    int ignoreWhiteCDATAs;          /* ignore 'white' CDATA sections */
+
+    void *userData;                 /* Handler set specific Data Structure;
+                                       the C handler set extension has to
+                                       malloc the needed structure in his
+                                       init func and has to provide a
+                                       cleanup func (to free it). */
+
+    CHandlerSet_userDataReset        resetProc;
+    CHandlerSet_userDataFree         freeProc;
+
+    /* C func for element start */
+    XML_StartElementHandler          elementstartcommand;
+    /* C func for element end */
+    XML_EndElementHandler            elementendcommand;
+    /* C func for character data */
+    XML_CharacterDataHandler         datacommand;
+    /* C func for namespace decl start */
+    XML_StartNamespaceDeclHandler    startnsdeclcommand;
+    /* C func for namespace decl end */
+    XML_EndNamespaceDeclHandler      endnsdeclcommand;
+    /* C func for processing instruction */
+    XML_ProcessingInstructionHandler picommand;
+    /* C func for default data */
+    XML_DefaultHandler               defaultcommand;
+    /* C func for unparsed entity declaration */
+    XML_NotationDeclHandler          notationcommand;
+    /* C func for external entity */
+    XML_ExternalEntityRefHandler     externalentitycommand;
+    /* C func for unknown encoding */
+    XML_UnknownEncodingHandler       unknownencodingcommand;
+    /* C func for comments */
+    XML_CommentHandler               commentCommand;
+    /* C func for "not standalone" docs */
+    XML_NotStandaloneHandler         notStandaloneCommand;
+    /* C func for CDATA section start */
+    XML_StartCdataSectionHandler     startCdataSectionCommand;
+    /* C func for CDATA section end */
+    XML_EndCdataSectionHandler       endCdataSectionCommand;
+    /* C func for !ELEMENT decl's */
+    XML_ElementDeclHandler           elementDeclCommand;
+    /* C func for !ATTLIST decl's */
+    XML_AttlistDeclHandler           attlistDeclCommand;
+    /* C func for !DOCTYPE decl's */
+    XML_StartDoctypeDeclHandler      startDoctypeDeclCommand;
+    /* C func for !DOCTYPE decl ends */
+    XML_EndDoctypeDeclHandler        endDoctypeDeclCommand;
+    /* C func for !ENTITY decls's */
+    XML_EntityDeclHandler            entityDeclCommand;
+} CHandlerSet;
+

The types and the arguments of the event functions (XML_*) are exactly +the same like the expat lib handler functions and described in detail in +expat.h, see there. The extension has only to provided the handler functions +needed; it's perfectly OK to leave unused handler slots as the are (they are +initialized to NULL by CHandlerSetCreate).

The name of this structure is used to identify the handler set. +

If the flag ignoreWhiteCDATAs is set, element content which +contain only whitespace isn't reported with the datacommand.

The userData element points to the handler set specific data. The +event handler functions are called with this pointer as userData argument. +

+resetProc and freeProc must have arguments that match the +type

void (Tcl_Interp *interp, void *userData)

+resetProc is called in case the parser is reset with +<parserObj> reset and should do any necessary cleanup and +reinitializing to prepare the C handler set for a new XML document. The +freeProc is called, if the parser is deleted and should do memory +cleanup etc.

CHandlerSetCreate create a C handler set, gives it the name +name and initializes any other element with NULL.

CHandlerSetInstall adds the handlerSet to the parser +expatObj. The parser has to be a tDOM Tcl expat parser object in the +interpreter interp. The name of the C handler set has to be unique for +the parser. Returns 0 in case of success. Returns 1 if expatObj isn't a +parser object in the interpreter interp. Returns 2 if this parser has +already a C handler set with the handlerSet name.

CHandlerSetRemove removes the C handler set referenced by the +handlerSetName from the parser expatObj. The parser has to be a +tDOM Tcl expat parser object in the interpreter +interp. CHandlerSetRemove calls the freeProc function of the C +handler set structure, removes the handler set from the C handler set list and +frees the handler structure. Returns 0 in case of success. Returns 1 if +expatObj isn't a parser object in the interpreter interp. Returns +2 if this parser hasn't a C handler set named handlerSetName.

+CheckExpatParserObj returns 1, if nameObj is a tDOM Tcl expat +parser object in the interpreter interp, otherwise it returns +0. Example:

+int
+TclExampleObjCmd(dummy, interp, objc, objv)
+     ClientData dummy;
+     Tcl_Interp *interp;
+     int objc;
+     Tcl_Obj *const objv[];
+{
+    char          *method;
+    CHandlerSet   *handlerSet;
+    int            methodIndex, result;
+    simpleCounter *counter;
+    
+
+    static char *exampleMethods[] = {
+        "enable", "getresult", "remove",
+        NULL
+    };
+    enum exampleMethod {
+        m_enable, m_getresult, m_remove
+    };
+
+    if (objc != 3) {
+        Tcl_WrongNumArgs (interp, 1, objv, example_usage);
+        return TCL_ERROR;
+    }
+
+    if (!CheckExpatParserObj (interp, objv[1])) {
+        Tcl_SetResult (interp, "First argument has to be a expat parser object", NULL);
+        return TCL_ERROR;
+    }
+    /* ... */
+

CHandlerSetGet returns a pointer to the C handler Set referenced +by the name handlerSetName of the parser object +expatObj. expatObj has to be an expat parser object in the +interpreter interp. Returns NULL in case of error.

+CHandlerSetGetUserData returns a pointer to the userData of the C +handler set referenced by the name handlerSetName of the parser object +expatObj. expatObj has to be an expat parser object in the +interpreter interp. Returns NULL in case of error.

GetExpatInfo Is a helper function that returns a pointer to the +TclGenExpatInfo structure of the tDOM Tcl expat parser object +expatObj. The expatObj has to be a tDOM Tcl expat parser object +in the interpreter interp. This is most useful, to set the application +status of the parser object.

See the simple but full functionally example in the extensions/example +dir or the more complex example tnc in the extensions/tnc dir (a simple DTD +validation extension).

+ +

SEE ALSO

expat

+ +

KEYWORDS

C handler set

+
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/index.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/index.html new file mode 100644 index 00000000..13d353e9 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/index.html @@ -0,0 +1,20 @@ + + +tDOM manual + +
+

tDOM manual: Contents

+Contents · Index · Keywords · Repository +

+
+
+Contents · Index · Keywords · Repository +
+
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/keyword-index.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/keyword-index.html new file mode 100644 index 00000000..dad0cb2d --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/keyword-index.html @@ -0,0 +1,99 @@ + + +tDOM manual: Keyword Index + +
+

tDOM manual: Keywords

+Contents · Index · Keywords · Repository +

+: · C · D · E · N · P · S · T · V · X ·
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Keywords: :
::dom::xpathFuncxpathFunc
Keywords: C
C handler set +expatapi · tdom +
CheckExpatParserObj, CHandlerSetInstall, CHandlerSetRemove, + CHandlerSetCreate, CHandlerSetGetUserData, GetExpatInfoexpatapi
Keywords: D
document +dom · domNode +
document elementdomDoc
dom +dom · domNode · schema · tdom +
DOM node creationdomDoc
domDocdomDoc
domNodedomNode
DTDtnc
Keywords: E
expatexpat
expatapiexpatapi
Keywords: N
node +dom · domNode +
Keywords: P
parsing +dom · domNode · pullparser +
Postvalidationschema
pullpullparser
pullparserpullparser
pushexpat
pushparserexpat
Keywords: S
SAX +expat · schema · tdom +
schemaschema
Keywords: T
tdomtdom
tdom::pullparserpullparser
tdom::schemaschema
tdomcmdtdom
tnctnc
Keywords: V
Validation +schema · tnc +
Keywords: X
XML +dom · domNode · pullparser +
xml::parserexpat
XPath +domNode · xpathFunc +
xpathFuncxpathFunc
+
+Contents · Index · Keywords · Repository +
+
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/manpage.css b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/manpage.css new file mode 100644 index 00000000..a5dbef21 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/manpage.css @@ -0,0 +1,204 @@ +/* + * $Id: manpage.css,v 1.4 2002/06/20 00:44:17 jenglish Exp $ + * Author: Joe English, + * Created: 26 Jun 2000 + * Description: CSS stylesheet for TCL man pages + */ + +HTML { + background: #FFFFFF; + color: black; +} + +BODY { + background: #FFFFFF; + color: black; +} + +DIV.body { + margin-left: 10%; + margin-right: 10%; +} +DIV.header,DIV.footer { + width: 100%; + margin-left: 0%; + margin-right: 0%; +} + +DIV.body H1,DIV.body H2 { + margin-left: -5%; +} + +/* Navigation material: */ + +DIV.navbar { + width: 100%; + margin-top: 5pt; + margin-bottom: 5pt; + margin-left: 0%; + margin-right: 0%; + padding-top: 5pt; + padding-bottom: 5pt; + background: #DDDDDD; + color: black; + border: 1px solid black; + text-align: center; + font-size: small; + font-family: sans-serif; +} + +P.navaid { + text-align: center; +} +.navaid { + font-size: small; + font-family: sans-serif; +} + +A.navaid:link { color: green; background: transparent; } +A.navaid:visited { color: green; background: transparent; } +A.navaid:active { color: yellow; background: transparent; } + +/* For most anchors, we should leave colors up to the user's preferences. */ +/*-- +A:link { color: blue; background: transparent; } +A:visited { color: purple; background: transparent; } +A:active { color: red; background: transparent; } +--*/ + +H1, H2, H3, H4 { + margin-top: 1em; + font-family: sans-serif; + font-size: large; + color: #005A9C; + background: transparent; + text-align: left; +} + +H1.title { + text-align: center; +} + +UL,OL { + margin-right: 0em; + margin-top: 3pt; + margin-bottom: 3pt; +} +UL LI { + list-style: disc; +} +OL LI { + list-style: decimal; +} + +DT { + padding-top: 1ex; +} + +DL.toc { + font: normal 12pt/16pt sans-serif; + margin-left: 10%; +} + +UL.toc,UL.toc UL, UL.toc UL UL { + font: normal 12pt/14pt serif; + list-style: none; +} +LI.tocentry,LI.tocheading { + list-style: none; + margin-left: 0em; + text-indent: 0em; + padding: 0em; +} + +.tocheading { + font-family: sans-serif; + font-weight: bold; + color: #005A9C; + background: transparent; +} + +PRE { + display: block; + font-family: monospace; + white-space: pre; + margin: 0%; + padding-top: 0.5ex; + padding-bottom: 0.5ex; + padding-left: 1ex; + padding-right: 1ex; + width: 100%; +} +PRE.syntax { + color: black; + background: #80ffff; + border: 1px solid black; + font-family: serif; +} +PRE.example { + color: black; + background: #f5dcb3; + border: 1px solid black; +} + +DIV.arglist { + border: 1px solid black; + width: 100%; +} +TH, THEAD TR, TR.heading { + color: #005A9C; + background: #DDDDDD; + text-align: center; + font-family: sans-serif; + font-weight: bold; +} +TR.syntax { + color: black; + background: #80ffff; +} +TR.desc { + color: black; + background: #f5dcb3; +} + +/* TR.row[01] are used to get alternately colored table rows. + * Could probably choose better colors here... + */ +TR.row0 { + color: black; + background: #efffef; +} + +TR.row1 { + color: black; + background: #efefff; +} + +/* Workaround for Netscape bugs: + * Netscape doesn't seem to compute table widths properly. + * unless they're wrapped inside a DIV. (Additionally, + * it appears to require a non-zero border-width.) + */ +DIV.table { + border-width: 1px; + border-color: white; + width: 100%; +} +DIV.menu { /* Wrapper for TABLE class="menu" */ + margin-top: 10px; + margin-bottom: 10px; + border: thin solid #005A9C; + width: 100%; + margin-left: 5%; +} + +VAR { + font-style: italic; +} + +/* For debugging: highlight unrecognized elements: */ +.unrecognized { + color: red; background: green; +} + +/* EOF */ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/pkgIndex.tcl new file mode 100644 index 00000000..019421d6 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/pkgIndex.tcl @@ -0,0 +1 @@ + package ifneeded tdom 0.9.6 "[list load [file join $dir tcl9tdom096.dll] Tdom]; [list source [file join $dir tdom.tcl]]" diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/pullparser.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/pullparser.html new file mode 100644 index 00000000..af722e39 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/pullparser.html @@ -0,0 +1,187 @@ + + +tDOM manual: pullparser + +
+
+NAME · SYNOPSIS · DESCRIPTION · KEYWORDS +
+
+

NAME

+tdom::pullparser -
Create an XML pull parser command

+ +

SYNOPSIS

package require tdom
+
+    tdom::pullparser cmdName  ? -ignorewhitecdata ? 
+
+ +

DESCRIPTION

This command creates XML pull parser commands with a simple + API, along the lines of a simple StAX parser. After creation, + you've to set an input source, to do anything useful with the pull + parser. For this see the methods input, inputchannel + and inputfile.

The parser has always a state. You start parsing the XML + data until some next state, do what has to be done and skip again + to the next state. XML well-formedness errors along the way will + be reported as TCL_ERROR with additional info in the error + message.

The pull parsers don't follow external entities and are XML + 1.0 only, they know nothing about XML Namespaces. You get the tags + and attribute names as in the source. You aren't noticed about + comments, processing instructions and external entities; they are + silently ignored for you. CDATA Sections are handled as if their + content would have been provided without using a CDATA Section. +

On the brighter side is that character entity and attribute + default declarations in the internal subset are respected (because + of using expat as underlying parser). It is probably somewhat + faster than a comperable implementation with the SAX interface. + It's a nice programming model. It's a slim interface. +

If the option -ignorewhitecdata is given, the created + XML pull parser command will ignore any white space only (' ', \t, + \n and \r) text content between START_TAG and START_TAG / END_TAG. + The parser won't stop at such input and will create TEXT state + events only for not white space only text.

Not all methods are valid in every state. The parser will raise + TCL_ERROR if a method is called in a state the method isn't valid + for. Valid methods of the created commands are:

+ +
state
+
This method is valid in all parser states. The + possible return values and their meanings are: +
    +
  • +READY - The parser is created or reset, but no + input is set.
    • +
  • +START_DOCUMENT - Input is set, parser is ready + to start parsing.
    • +
  • +START_TAG - Parser has stopped parsing at a + start tag.
    • +
  • +END_TAG - Parser has stopped parsing at an end tag
    • +
  • +TEXT - Parser has stopped parsing to report + text between tags.
    • +
  • +END_DOKUMENT - Parser has finished parsing + without error.
    • +
  • +PARSE_ERROR - Parser stopped parsing at XML + error in input.
    • +
+
+ + + +
+input data +
+
This method is only valid in state READY. It + prepares the parser to use data as XML input to parse + and switches the parser into state START_DOCUMENT.
+ + + +
+inputchannel channel +
+
This method is only valid in state READY. It + prepares the parser to read the XML input to parse out of + channel and switches the parser into state START_DOCUMENT.
+ + + +
+inputfile filename +
+
This method is only valid in state READY. It + open filename and prepares the parser to read the XML + input to parse out of that file. The method returns TCL_ERROR, + if the file could not be open in read mode. Otherwise it + switches the parser into state START_DOCUMENT.
+ + + +
next
+
This method is valid in state START_DOCUMENT, + START_TAG, END_TAG and TEXT. It continues + parsing of the XML input until the next event, which it will + return.
+ + + +
tag
+
This method is only valid in states START_TAG and + END_TAG. It returns the tag name of the current start + or end tag.
+ + + +
attributes
+
This method is only valid in state START_TAG. It + returns all attributes of the element in a name value list.
+ + + +
text
+
This method is only valid in state TEXT. It + returns the character data of the event. There will be always + at most one TEXT event between START_TAG and the next + START_TAG or END_TAG event.
+ + + +
skip
+
This method is only valid in state START_TAG. It + skips to the corresponding end tag and ignores all events (but + not XML parsing errors) on the way and returns the new state + END_TAG.
+ + + +
+find-element ? tagname | -names tagnames ?
+
This method is only valid in states + START_DOCUMENT, START_TAG and END_TAG. It + skips forward until the next element start tag with tag name + tagname and returns the new state START_TAG. If a list + of tagnames is provided with the -names option, any of + the tagnames match. If there isn't such an element the + parser stops at the end of the input and returns + END_DOCUMENT.
+ + + +
reset
+
This method is valid in all parser states. It resets the + parser into READY state and returns that.
+ + + +
delete
+
This method is valid in all parser states. It deletes + the parser command.
+ +

Miscellaneous methods:

+ +
line
+
This method is valid in all parser states except READY + and TEXT. It returns the line number of the parsing + position. Line counting starts with 1.
+ + + +
column
+
This method is valid in all parser states except READY + and TEXT. It returns the offset, from the beginning of the + current line, of the parsing position. Column counting starts + with 0.
+ +
+ +

KEYWORDS

+XML, pull, parsing +

+
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/schema.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/schema.html new file mode 100644 index 00000000..6c8bfd0a --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/schema.html @@ -0,0 +1,1689 @@ + + +tDOM manual: schema + +
+
+NAME · SYNOPSIS · DESCRIPTION · Schema definition scripts · Quantity specifier · Text constraint scripts · Local key constraints · Recovering · Examples · KEYWORDS +
+
+

NAME

+tdom::schema -
Creates a schema validation command

+ +

SYNOPSIS

package require tdom
+
+tdom::schema ?create? cmdName
+
+ +

DESCRIPTION

Every call of this command creates a new validation command. A + validation command has methods to define a schema and is able + to validate XML data or to post-validate a tDOM DOM tree (and to + some degree other kind of hierarchical data) against this + schema.

Also, a validation command may be used as argument to the + -validateCmd option of the dom parse and the + expat commands to enable validation additionally to what + they do otherwise.

The methods of created commands are:

+ +
+prefixns ?prefixUriList? +
+
This method controls prefix (or abbreviation) to + namespace URI mapping. Wherever a namespace argument is + expected in the schema command methods the + "prefix" could be used instead of the namespace + URI. If the list maps the same prefix to different namespace + URIs, the first one wins. If there is no such prefix, the + namespace argument is used literally as namespace URI. If + the method is called without argument, it returns the + current prefixUriList. If the method is called with the + empty string, any namespace URI arguments are used + literally. This is the default. +
+ + + +
+defelement name ?namespace? <definition script> +
+
This method defines the element name (optional in + the namespace namespace) in the schema. The + definition script is evaluated and defines the content + model of the element. If the namespace argument is + given, any element or ref references in the + definition script not wrapped inside a namespace + command are resolved in that namespace. If there is already a + element definition for the name/namespace combination, the + command raises error.
+ + + +
+defelementtype typename ?namespace? <definition script> +
+
This method defines the element type typename + (optional in the namespace namespace) in the schema. If + the element type is used in a definition script with the + schema command element, the validation engine expects an + element content according to content model definition + script. Defining (and using) element types seems only + sensible if you really have elements with the same name and + namespace but different content models. The definition + script is evaluated and defines the content model of the + element it is assgned to. If the namespace argument is + given, any element or ref references in the + definition script not wrapped inside a namespace + command are resolved in that namespace. If there is already an + elementtype definition for the typename/namespace combination, + the command raises error. The document element of any XML to + validate cannot be a defelementtype defined + element.
+ + + +
+defpattern name ?namespace? <definition script> +
+
This method defines a (maybe complex) content particle + with the name (optional in the namespace + namespace) in the schema, to be used in other + definition scripts with the definition command ref. The + definition script is evaluated and defines the content + model of the content particle. If the namespace + argument is given, any element or ref references + in the definition script not wrapped inside a namespace + command are resolved in that namespace. If there is already a + pattern definition for the name/namespace combination, the + command raises error.
+ + + +
+deftexttype name <constraint script> +
+
This method defines a bundle of text constraints that + can be referred to by name while defining constraints + on text element or attribute values. If there is already a + text type definition with this name, the command raises error. + A text type may be referred before it is defined in the + schema. If a referred text type isn't defined anywhere in the + schema then any text will match this type during + validation.
+ + + +
+start documentElement ?namespace? +
+
This method defines the name and namespace of the root + element of a tree to validate. If this method is used, the + root element must match for validity. If start is not + used, any element defined by defelement may be the root + of a valid document. The start method may be used + several times with varying arguments during the lifetime of a + validation command. If the command is called with just the + empty string (and no namespace argument), the validation + constraint for the root element is removed and any defined + element will be valid as root of a tree to validate.
+ + + +
+define <definition script> +
+
This method defines several elements or patterns or a + whole schema with one call, by evaluating the definition + script. All schema command methods so far + (prefixns, defelement, defelementtype, + defpattern, deftexttype and start) are + allowed top level in the definition script. The + define method itself isn't allowed recursively.
+ + + +
+event (start|end|text) ?event specific data? +
+
This method enables validation of hierarchical data against + the content constraints of the validation command. + +
+ +
+start name ?attributes? ?namespace? +
+ +
Checks if the current validation state allows the + element name in the namespace to start here. + It raises error if not.
+ + + +
end
+
Checks if the current innermost open element may end + there in the current state without violation of validation + constraints. It raises error if not.
+ + + +
+text text +
+ +
Checks if the current validation state allows the + given text content. It raises error if not.
+ +
+
+ + + +
+validate ?options? <XML string> ?objVar? +
+
+

Returns true if the <XML string> is valid, or + false, otherwise. If validation has failed and the optional + objVar argument is given, the variable with that + name is set to a validation error message. If the XML string + is valid and the optional objVar argument is given, + the variable will be untouched.

+ +

The valid options are:

+
+ +
+-baseurl <baseURI> +
+ +
If -baseurl <baseURI> is specified, + the baseURI is used as the base URI of the document. + External entities references in the document are + resolved relative to this base URI. This base URI is + also stored within the DOM tree.
+ + +
+-externalentitycommand <script> +
+ +
If -externalentitycommand <script> + is specified, the specified Tcl script is called to + resolve any external entities of the document. The + default is "::tdom::extRefHandler", which is a simple + file URL resolver defined by the script part of the + package. Setting the option value to the empty string + disables resolving of external entities. The actual + evaluated command consists of this option followed by + three arguments: the base uri, the system identifier + of the entity and the public identifier of the entity. + The base uri and the public identifier may be the + empty list. The script has to return a Tcl list + consisting of three elements. The first element of + this list signals how the external entity is returned + to the processor. Currently the two allowed types are + "string" and "channel". The second element of the list + has to be the (absolute) base URI of the external + entity to be parsed. The third element of the list are + data, either the already read data out of the external + entity as string in the case of type "string", or the + name of a Tcl channel, in the case of type "channel". + Note that if the script returns a Tcl channel, it will + not be closed by the processor. It must be closed + separately if it is no longer needed.
+ + + +
+-paramentityparsing <always|never|notstandalone> +
+ +
The -paramentityparsing option controls, + if the parser tries to resolve the external entities + (including the external DTD subset) of the document + while building the DOM tree. + -paramentityparsing requires an argument, which + must be either "always", "never", or "notstandalone". + The value "always" means that the parser tries to + resolves (recursively) all external entities of the + XML source. This is the default in case + -paramentityparsing is omitted. The value + "never" means that only the given XML source is + parsed and no external entity (including the external + subset) will be resolved and parsed. The value + "notstandalone" means, that all external entities will + be resolved and parsed, with the exception of + documents, which explicitly states standalone="yes" in + their XML declaration.
+ + + +
+-useForeignDTD <boolean> +
+ +
If <boolean> is true and the document does + not have an external subset, the parser will call the + -externalentitycommand script with empty values for + the systemId and publicID arguments. Please note that + if the document also doesn't have an internal subset, + the -startdoctypedeclcommand and + -enddoctypedeclcommand scripts, if set, are not + called.
+ + +
+
+ + + +
+validatefile ?options? filename ?objVar? +
+
Returns true if the content of filename is valid, + or false, otherwise. The given file is fed as binary stream to + expat, therefore, only US-ASCII, ISO-8859-1, UTF-8 or UTF-16 + encoded data will work with this method. If validation has + failed and the optional objVar argument is given, the + variable with that name is set to a validation error message. + If the XML data is valid and the optional objVar + argument is given, the variable will be untouched. The allowed + options and their meaning are the same as for the + validate method; see there for a description.
+ + + +
+validatechannel ?options? channel ?objVar? +
+
Returns true if the content read from the Tcl channel + channel is valid, or false, otherwise. Since data read + out of a Tcl channel is UTF-8 encoded, any misleading encoding + declaration at the beginning of the data will lead to errors. + If the validation fails and the optional objVar + argument is given, the variable with that name is set to a + validation error message. If the XML data is valid and the + optional objVar argument is given, the variable will be + untouched. The allowed options and their meaning are the same + as for the validate method; see there for a + description.
+ + + +
+domvalidate domNode ?objVar? +
+
Returns true if the first argument is a valid tree, or + false, otherwise. If validation has failed and the optional + objVar argument is given, the variable with that name + is set to a validation error message. If the dom tree is valid + and the optional objVar argument is given, the variable + with that name is set to the empty string.
+ + + +
+reportcmd ?cmd? +
+
This method expects the name of a Tcl command to be + called in case of validation error. The command will be + called with two arguments appended: the schema command which + raises the validation error, and a validation error code. + +

The possible error codes are:

+
+
MISSING_ELEMENT
+
MISSING_TEXT
+
UNEXPECTED_ELEMENT
+
UNEXPECTED_ROOT_ELEMENT
+
UNEXPECTED_TEXT
+
UNKNOWN_ROOT_ELEMENT
+
UNKNOWN_ATTRIBUTE
+
MISSING_ATTRIBUTE
+
INVALID_ATTRIBUTE_VALUE
+
DOM_KEYCONSTRAINT
+
DOM_XPATH_BOOLEAN
+
INVALID_KEYREF
+
INVALID_VALUE
+
UNKNOWN_GLOBAL_ID
+
UNKNOWN_ID
+
+

For more detailed information see section Recovering.

+
+ + + +
delete
+
This method deletes the validation command.
+ + + +
+info ?args? +
+
This method bundles methods to query the state of and + details about the schema command. +
+ +
validationstate
+
This method returns the state of the validation command + with respect to validation state. The possible return values + and their meanings are: +
+
READY
The validation command is ready to start + validation
+
VALIDATING
The validation command is in the + process of validating input.
+
FINISHED
The validation has finished, no further + events are expected.
+
+
+ + +
vstate
+
This method is a shorter alias for validationstate; see there.
+ + +
line
+
If the schema command is currently validating, + this method returns the line part of the parsing + position information, and the empty string in all + other cases. If the schema command is currently + post-validating a DOM tree, there may be no position + information stored at some or all nodes. The + empty string is returned in these cases.
+ + +
column
+
If the schema command is currently validating + this method returns the column part of the parsing + position information, and the empty string in all + other cases. If the schema command is currently + post-validating a DOM tree, there may be no position + information stored at some or all nodes. The + empty string is returned in these cases.
+ + +
byteIndex
+
If the schema command is currently validating + this method returns the byte position of the parsing + position information, and the empty string in all + other cases. If the schema command is currently + post-validating a DOM tree, there may be no position + information stored at some or all nodes. The + empty string is returned in these cases.
+ + +
domNode
+
If the schema command isn't currently + post-validating a DOM tree this method returns the + empty string. Otherwise, if the schema command waits + for the reportcmd script to finish while recovering + from a validation error it returns the node on which + the validation engine is currently looking at in + case the node is an ELEMENT_NODE or, if not, its + parent node. It is recommended that you do not use + this method. Or at least leave the DOM tree alone, + use it read-only.
+ + +
nrForwardDefinitions
+
Returns how many elements, element types and + ref patterns are referenced that aren't defined so + far (summed together).
+ + +
definedElements
+
Returns in no particular order the defined + elements in the grammar as list. If an element is + namespaced, its list entry will be itself a list with + two elements, with the name as first and the + namespace as second element.
+ + +
definedElementtypes
+
Returns in no particular order the defined + element types in the grammar as list. If an element + type is namespaced, its list entry will be itself a + list with two elements, with the name as first and + the namespace as second element.
+ + +
definedPatterns
+
Returns in no particular order the defined + named pattern in the grammar as list. If a named + pattern is namespaced, its list entry will be itself + a list with two elements, with the name as first and + the namespace as second element.
+ + +
expected
+
Returns in no particular order all possible + next events (since the last successful event match, + if there was one) as a list. If an element is + namespaced its list entry will be itself a list with + two elements, with the name as first and the + namespace as second element. If text is a possible + next event, the list entry will be a two elements + list, with #text as first element and the empty + string as second. If an any element constraint is + possible the list entry will be a two elements list, + with <any> as first element and the empty string + as second. If an any element in a certain namespace + constraint is possible, the list entry will be a two + elements list, with <any> as first element and + the namespace as second. If element end is a + possible event, the list entry will be a two elements + list with <elementend> as first element and the + empty string as second element.
+ + +
definition name ?namespace?
+
Returns the code that defines the given + element. The command raises error if there is no + definition of that element. +
+ + +
typedefinition name ?namespace?
+
Returns the code that defines the given + element type definition. The command raises error if + there is no definition of that element. +
+ + +
patterndefinition name ?namespace?
+
Returns the code that defines the given + pattern definition. The command raises error if + there is no definition of a pattern with that name + and, if given, namespace. +
+ + +
vaction ?name|namespace|text?
+
+

This method returns useful information only if + the schema command waits for the reportcmd script to + finish while recovering from a validation error. + Otherwise it returns NONE.

+

If the command is called without the optional + argument the possible return values and their + meanings are:

+
+
NONE
The schema command currently + does not recover from a validation event.
+
MATCH_ELEMENT_START
Element start event, which includes looking for missing or unknown attributes.
+
MATCH_ELEMENT_END
Element end event.
+
MATCH_TEXT
Validating text between tags.
+
MATCH_ATTRIBUTE_TEXT
Attribute text value constraint check
+
MATCH_GLOBAL
Checking global IDs
+
MATCH_DOM_KEYCONSTRAINT
Checking domunique constraint
+
MATCH_DOM_XPATH_BOOLEAN
Checking domxpathboolean constant
+
+

If called with one of the possible optional + arguments, the command returns detail information + depending on current action.

+
+
name
Returns the name of the element + that has to match in case of + MATCH_ELEMENT_START. Returns the name of the + closed element in case of MATCH_ELEMENT_END. + Returns the name of the attribute in case of + MATCH_ATTRIBUTE_TEXT. Returns the name of the + parent element in case of MATCH_TEXT.
+ +
namespace
Returns the namespace of + the element that has to match in case of + MATCH_ELEMENT_START. Returns the namespace of the + closed element in case of MATCH_ELEMENT_END. + Returns the namespace of the attribute in case + of MATCH_ATTRIBUTE_TEXT. Returns the namespace of + the parent element in case of MATCH_TEXT.
+ +
text
Returns the text to match in + case of MATCH_TEXT. Returns the value of the + attribute in case of MATCH_ATTRIBUTE_TEXT.
+
+
+ + +
stack top|inside|associated
+
In Tcl scripts evaluated by validation this method + provides information about the current validation stack. + Called outside this context the method returns the empty + string. +
+ +
top
+
Returns the element whose content is currently + checked (the open element tag at this moment). +
+ + + +
inside
+
Returns all currently open elements as a list.
+ + + +
associated
+
Returns the data associated with the + current top most stack content particle or + the empty string if there isn't any. +
+ +
+
+ +
+
+ + + +
reset
+
This method resets the validation command into state + READY (while preserving the defined grammar).
+ + +
+ +

Schema definition scripts

Schema definition scripts are ordinary Tcl scripts evaluated in + the namespace tdom::schema. The schema definition commands listed + below in this Tcl namespace allow the definition of a wide variety + of document structures. Every schema definition command + establishes a validation constraint on the content which has to + match or must be optional to qualify the content as valid. It is a + validation error if there is additional (not matched) content. + White-space-only text (in the XML sense of white space) between + any different tags is ignored, with the exception of text only + elements (for which even white-space-only text will be considered + as significant content).

The schema definition commands are:

+ +
+element name ?quant? (?<definition script>|"type" typename)? +
+
+

If neither the optional argument definition + script nor the string "type" and a typename is given this + command refers to the element defined with defelement + with the name name in the current context namespace.

+

If the string "type" and a typename is given then + the content of the element is described by the content model + defined with defelementtype with the name + typename in the current context namespace.

+

If the defelement script argument is given, the + validation constraint expects an element with the name + name in the current namespace with content "locally" + defined by the definition script. Forward references to + so far not defined elements or patterns or other local + definitions of the same name inside the definition + script are allowed. If a forward referenced element is not + defined until validation, only an empty element with name + name and namespace namespace and no attributes + matches.

+
+ + + +
+ref name ?quant? +
+
This command refers to the content particle defined with + defpattern with the name name in the current + context namespace. Forward references to a so far not defined + pattern and recursive references are allowed. If a forward + referenced pattern is not defined until validation no content + whatsoever is expected ("empty match").
+ + + +
+group ?quant? <definition script> +
+
This method group a sequence of content particles + defined by the definition script, which have to match + in this sequence order.
+ + + +
+choice ?quant? <definition script> +
+
This schema constraint matches if one of the top level + content particles defined by the definition script + matches. If one of this top level content particle is optional + this constraint matches the "empty match". +
+ + + +
+interleave ?quant? <definition script> +
+
This schema constraint matches after every of the required + top level content particles defined by the definition + script have matched (and, optional, some or all other) in + any arbitrary order.
+ + + +
+mixed ?quant? <definition script> +
+
This schema constraint matches for any text (including the + empty one) and every top level content particle defined by the + definition script with default quantifier *.
+ + + +
+text ?<constraint script>|"type" typename? +
+
Without the optional constraint script this validation + constraint matches every string (including the empty one). + With constraint script or with a given text type + argument a text matching this script or the text type is + expected.
+ + + +
+any ?options? ?<namespace list>? ?quant? +
+
Without arguments the any command matches every element. + If the <namespace list> argument is given, this + matches any element in a namespace out of that list. The empty + string means elements with no namespace. If additionally the + option -not is given then this maches every element + with a namespace not in the list. The only other recognized + option is -- which signals the end of any options. + Please note that in case of no namespace argument is + given that means that the quantifier * and + will eat up any + elements until the enclosing element ends. If you really have + a namespace that looks like a valid tDOM schema quantifier you + will have to spell out always both arguments.
+ + + +
+attribute name ?quant? (?<constraint script>|"type" typename?) +
+
The attribute command defines an attribute (in no + namespace) to the enclosing element. The first definition of + name inside an element definition wins; later + definitions of the same name are silently ignored. After the + name argument there may be one of the quantifiers ? or + !. If there is, it will be used. Otherwise the attribute will + be required (must be present in the XML source). If there is + one argument more this argument is evaluated as constraint + script, defining the value constraints of the attribute. + Otherwise, if there are two more arguments and the first of + them is the bare-word "type" the following argument is used as + a text type name. This command is only allowed at top level in + the definition script of a defelement/element script.
+ + + +
+nsattribute name namespace ?quant? (?<constraint script>|"type" typename?) +
+
This command does the same as the command + attribute, for the attribute name in the + namespace namespace.
+ + + +
+namespace URI <definition script> +
+
Evaluates the definition script with context + namespace URI. Every element, element type or ref + command name will be looked up in the namespace URI, + and local defined elements will be in that namespace. An + empty string as URI means no namespace.
+ + + +
+tcl tclcmd ?arg arg ...? +
+
Evaluates the Tcl script tclcmd arg arg ... . + This validation command is only allowed in strict sequential + context (not in choice, mixed and interleave). If the return + code is something else than TCL_OK, this is an error (which + is not caught and reported by reportcmd).
+ + + +
self
+
Returns the schema command.
+ + + +
+associate data +
+
This command is only allowed top-level inside definition + scripts of the element, elementtype, pattern or interleave + content particles. Associates the data given as argument + with the currently defined content particle and may be + requested in scripts evaluated while validating the content of + that particle with the schema command method call info + stack associated.
+ + + +
+domunique selector fieldlist ?name? ?"IGNORE_EMPTY_FIELD_SET"|("EMPTY_FIELD_SET_VALUE" emptyFieldSetValue)? +
+
If not postvalidating a DOM tree with domvalidate + this constraint always matches. If postvalidating this + constraint resembles the xsd key/keyref mechanism. The + selector argument may be any valid XPath expression + (without the xsd limits). Several domunique commands + within one element definition are allowed. They are checked in + definition order. The argument name is available in the + recovering script per info vaction name. If the + fieldlist does not select something for a node of the + result set of the selector the key value will be the + empty string by default. If the arguments + EMPTY_FIELD_SET_VALUE <value> are given an empty + node set will have the key value value. If instead the + flag IGNORE_EMPTY_FIELD_SET flag is given an empty + node set result will not have any key value.
+ + + +
+domxpathboolean XPath_expr ?name? +
+
+

If not postvalidating a DOM tree with + domvalidate this constraint always matches. If + postvalidating the XPath_expr argument is evaluated + (with the node matching the schema parent of the + domxpathboolean command as context node). The + constraint maches if the result of this XPath expression, + converted to boolean by XPath rules, is true. Several + domxpathboolean commands within one element definition + are allowed. They are checked in definition order.

+ +

This enables checks depending on more than one element. Consider

+ + 
+tdom::schema s
+s define {
+    defelement doc {
+        element a ! text
+        element b ! text
+        element c ! text
+        domxpathboolean "a * b * c >= 20000" volume
+        domxpathboolean "a > b and b > c" sequence
+    }
+}
+
+
+ + + +
+jsontype JSON structure type +
+
+

If not postvalidating a DOM tree with + domvalidate this constraint always matches. If + postvalidating the constraint matches if the enclosing element + has the JSON type given as argument to the structure + constraint. The possible JSON structure types are NONE, + OBJECT and ARRAY. This constraint is only + allowed as direct child of a defelement, defelementtype or + local element definition.

+
+ + + +
+prefixns + ?prefixUriList? +
+
This defines a prefix to namespace URI mapping exactly + as a schemacmd prefixns would. It is meant as top-level + command of a schemacmd define script. This command is + not allowed nested in another definition script command and + will raise error, if you call it there.
+ + + +
+defelement name ?namespace? <definition script> +
+
This defines an element exactly as a schemacmd + defelement call would. It is meant as top-level command of a + schemacmd define script. This command is not allowed + nested in another definition script command and will raise + error, if you call it there.
+ + + +
+defelementtype typename ?namespace? <definition script> +
+
This defines an elementtype exactly as a schemacmd + defelementtype call would. It is meant as top-level + command of a schemacmd define script. This command is + not allowed nested in another definition script command and + will raise error, if you call it there.
+ + + +
+defpattern name ?namespace? <definition script> +
+
This defines a named pattern exactly as a schemacmd + defpattern call would. It is meant as top-level command of a + schemacmd define script. This command is not allowed + nested in another definition script command and will raise + error, if you call it there.
+ + + +
+deftexttype name <constraint script> +
+
This defines a named bundle of text constraints exactly + as a schemacmd deftexttype call would. It is meant as + top-level command of a schemacmd define script. This + command is not allowed nested in another definition script + command and will raise error, if you call it there.
+ + + +
+start name ?namespace? +
+
This command works exactly as a schemacmd start + call would. It is meant as top-level command of a schemacmd + define script. This command is not allowed nested in + another definition script command and will raise error, if you + call it there.
+ +
+ +

Quantity specifier

Several schema definition commands expect a quantifier as + one of their arguments which determines how often the content + particle specified by the command is expected. The valid values + for a quant argument are:

+ +
!
+
The content particle has to occur exactly once in valid + documents.
+ + + +
?
+
The content particle may not occur more than once in + valid documents - the particle is optional.
+ + + +
*
+
The content particle may occur zero or more times in a + row in valid documents.
+ + + +
+
+
The content particle may occur one or more times in a + row in valid documents.
+ + + +
n
+
The content particle must occur n times in a row in + valid documents. The quantifier must be an integer greater + zero.
+ + + +
{n m}
The content particle must occur + at least n and at most m times in a row in valid documents. + The quantifier must be a Tcl list with two elements. The first + element of this list must be an integer with n >= 0. If the + second list element is the character *, then there is no upper + limit. Otherwise the second list element must be an integer + with n < m.
+ +

If an optional quantifier is not given, it defaults to * in + case of the mixed command and to ! for all other commands.

+ +

Text constraint scripts

Text (parsed character data, as XML calls it) sometimes has to + be of a certain kind or comply with certain rules to be valid. The + text constraint script arguments to text, attribute, nsattribute + and deftexttype commands are evaluated in the Tcl namespace + tdom::schema::text namespace and allow the ensuing text + constraint commands to check text for certain properties. The + commands are defined in the Tcl namespace + tdom::schema::text. They raise error in case they are + called outside of a text constraint script.

A few of the ensuing text type commands are exposed as general + Tcl commands. They are defined in the namespace tdom::type and are + called as documented below with the text to check appended to the + argument list. They return a logical value. Please note that the + commands may not accept starting or ending white space. If a + command is available in the tdom::type namespace is recorded in + its documentation. +

+

The tcl text constraint command

+

The tcl text constraint command dispatches the check + to an arbitrary Tcl command, thus enable any programmable + decision rules.

+
+ +
+tcl tclcmd ?arg arg ...? +
+
Evaluates the Tcl script tclcmd arg arg ... and + the text to validate appended to the argument list. The return + value of the Tcl command is interpreted as a boolean.
+ +
+ +

Basic XML types

+
+ +
name
+
This text constraint matches if the text value + matches the XML name production + https://www.w3.org/TR/xml/#NT-Name. This + means that the text value must start with a letter, + underscore (_), or colon (:), and may contain only + letters, digits, underscores (_), colons (:), hyphens + (-), and periods (.).
+ + +
ncname
+
This text constraint matches if the text value + matches the XML ncname production + https://www.w3.org/TR/xml-names/#NT-NCName. + This means that the text value must start with a + letter or underscore (_), and may contain only + letters, digits, underscores (_), hyphens (-), and + periods (.) (The only difference to the name + constraint is that colons are not permitted.)
+ + +
qname
+
This text constraint matches if the text value + matches the XML qname production + https://www.w3.org/TR/xml-names/#NT-QName. + This means that the text value is either a ncname or + two ncnames joined by a colon (:).
+ + +
nmtoken
+
This text constraint matches if the text value + matches the XML nmtoken production + https://www.w3.org/TR/xml/#NT-Nmtoken +
+ + +
nmtokens
+
This text constraint matches if the text value + matches the XML nmtokens production + https://www.w3.org/TR/xml/#NT-Nmtokens +
+ +
+ +

Basic type tests

+

+

+
+ +
+integer ?(xsd|tcl)? +
+
This text constraint matches if the text value could be + parsed as an integer. If the optional argument to the command + is tcl, everything that returns TCL_OK if fed into + Tcl_GetInt() matches. If the optional argument to the command + is xsd, the constraint matches if the value is a + valid xsd:integer. Without argument xsd is the + default.
+ + + +
+negativeInteger ?(xsd|tcl)? +
+
This text constraint matches the same text values as the + integer text constraint (see there), with the additional + constraint, that the value must be < zero.
+ + + +
+nonNegativeInteger ?(xsd|tcl)? +
+
This text constraint matches the same text values as the + integer text constraint (see there), with the additional + constraint, that the value must be >= zero.
+ + + +
+nonPositiveInteger ?(xsd|tcl)? +
+
This text constraint matches the same text values as the + integer text constraint (see there), with the additional + constraint, that the value must be <= zero.
+ + + +
+positiveInteger ?(xsd|tcl)? +
+
This text constraint matches the same text values as the + integer text constraint (see there), with the additional + constraint, that the value must be > zero.
+ + + +
+number ?(xsd|tcl)? +
+
This text constraint matches if the text value could be + parsed as a number. If the optional argument to the command is + tcl, everything that returns TCL_OK if fed into + Tcl_GetDouble() matches. If the optional argument to the command + is xsd, the constraint matches if the value is a + valid xsd:decimal. Without argument xsd is the + default.
+ + +
+boolean ?(xsd|tcl)? +
+
This text constraint matches if the text value could be + parsed as a boolean. If the optional argument to the command is + tcl, everything that returns TCL_OK if fed into + Tcl_GetBoolean() matches. If the optional argument to the command + is xsd, the constraint matches if the value is a + valid xsd:boolean. Without argument xsd is the + default.
+ + +
date
+
This text constraint matches if the text value is + a xsd:date, which is basically like an ISO 8601 date of + the form YYYY-MM-DD, with optional time zone part + (either the letter Z or plus (+) or minus (-) followed + by hh:mm and with maximum allowed positive or negative + time zone 14:00). It follows the date rules of the + Gregorian calendar for all dates. A preceding minus + sign for bce dates is allowed. There is no year 0. The + year may have more than 4 digits, but only if needed + (no extra leading zeros). This is available as common + Tcl command tdom::type::date.
+ + +
time
+
This text constraint matches if the text value is + a xsd:time, which is basically like an ISO 8601 time of + the form hh:mm:ss with optional time zone part. The + time zone part follow the rules of the date + command; see there. All three parts of the time value + (hours, minutes, seconds) must be spelled out with 2 + digits. Additional fractional seconds (with a point + ('.') as separator) are allowed, but not just a + dangling point. The time value 24:00:00 (without + fractional part) is allowed. This is available as + common Tcl command tdom::type::time.
+ + +
dateTime
+
This text constraint matches if the text value + is a xsd:dateTime, which is basically like an ISO 8601 + date time of the form YYYY-MM-DDThh:mm:ss with + optional time zone part. The date and time zone parts + follows the rules of the date and time + command; see there. The time part (including the + signaling 'T' character) is mandatory. This is + available as common Tcl command + tdom::type::dateTime.
+ + +
duration
+
This text constraint matches if the text value is + a xsd:duration, which is basically like an ISO 8601 + duration of the form PnYnMnDTnHnMnS. All parts other + than the starting P and - if one of H, M or S is given + - T are optional. In case the following sign letter is + S, n may be a decimal (with at least one digit before + and after the dot), otherwise it must be a (positive) + integer. This is available as common Tcl command + tdom::type::duration.
+ + +
base64
+
This text constraint matches if text is valid according to + RFC 4648.
+ + +
hexBinary
+
This text constraint matches if text is a sequence of + binary octets in hexadecimal encoding, where each binary octet + is a two-character hexadecimal number. Lowercase and uppercase + letters A through F are permitted.
+ + +
unsignedByte
+
This text constraint matches if the text value is a + xsd:unsignedByte. This is an integer between 0 and 255, both + included, optionally preceded by a + sign and leading + zeros.
+ + +
unsignedShort
+
This text constraint matches if the text value is a + xsd:unsignedShort. This is an integer between 0 and 65535, + both included, optionally preceded by a + sign and leading + zeros.
+ + +
unsignedInt
+
This text constraint matches if the text value is a + xsd:unsignedInt. This is an integer between 0 and 4294967295, + both included, optionally preceded by a + sign and leading + zeros.
+ + +
unsignedLong
+
This text constraint matches if the text value is a + xsd:unsignedLong. This is an integer between 0 and + 18446744073709551615, both included, optionally preceded by a + + sign and leading zeros.
+ + +
byte
+
This text constraint matches if the text value + is a xsd:byte. This is an integer between -128 and + 127, both included, optionally preceded by a + or a - + sign and leading zeros.
+ + +
short
+
This text constraint matches if the text value is a + xsd:short. This is an integer between -32768 and 32767, + both included, optionally preceded by a + or a - sign and leading + zeros.
+ + +
int
+
This text constraint matches if the text value + is a xsd:int. This is an integer between -2147483648 + and 2147483647, both included, optionally preceded by + a + or a - sign and leading zeros.
+ + +
long
+
This text constraint matches if the text value + is a xsd:long. This is an integer between + -9223372036854775808 and 9223372036854775807, both + included, optionally preceded by a + or a - sign and + leading zeros.
+ +
+ +

Logical constructs

+
+ +
+oneOf <constraint script> +
+
This text constraint matches if one of the text + constraints defined in the argument constraint script + matches the text. It stops after the first matches and probes the + text constraints in the order of definition.
+ + +
+allOf <constraint script> +
+
This text constraint matches if all of the text + constraints defined in the argument constraint script + matches the text. It stops after the first match failure and + probes the text constraints in the order of definition. Since + the schema definition command text also expects all + text constraints to match the text constraint, allOf is + useful mostly in connection with the oneOf text constraint + command.
+ + +
+not <constraint script> +
+
This text constraint matches if none of the text + constraints defined in the argument constraint + script matches the text. It stops after the first + matching constraint in the constraint script and + reports validation error. The text constraints in the + constraint script are probed in the order of + definition.
+ + +
+type text type name +
+
This text constraint matches if the text type given + as argument matches.
+ +
+ +

Constraints on processed text value

+
+ +
+whitespace (preserve|replace|collapse) <constraint script> +
+
This text constraint command does white-space (#x20 + (space, ' '), #x9 (tab, \t), #xA (linefeed, \n), and #xD + (carriage return, \r) normalization to the text value and + checks the resulting text with the text constraints of the + constraint script argument. The normalization method + preserve keeps everything as it is; this is another way + to say allOf. The replace normalization method + replaces any single white-space character (as above) to a + space. The collapse normalization method removes all + leading and trailing white-space, and all the other sequences of + contiguous white-space are replaced by a single space.
+ + +
+split ?type ?args??<constraint script> +
+
+

This text constraint command splits the text to test + into a list of values and tests all elements of that list for + the text constraints in the evaluated constraint + script.

+

The available types are:

+
+
whitespace
The text to split is stripped + of all white space at start and end and split into a + list at any successive white space.
+
tcl tclcmd ?arg ...?
The text to split is + handed to the tclcmd, which is evaluated on + global level, appended with every given arg and the + text to split as last argument. This call must return + a valid Tcl list whose elements are tested.
+
+

The default in case no split type argument is given is + whitespace.

+
+ + +
+strip <constraint script> +
+
This text constraint command tests all text constraints + in the evaluated constraint script with the text to + test stripped of all white space at start and end.
+ +
+ +

Various other string properties

+
+ +
+fixed value +
+
The text constraint only matches if the text value is + string equal to the given value.
+ + + +
+enumeration list +
+
This text constraint matches if the text value is equal to + one element (respecting case and any white-space) of the + argument list, which has to be a valid Tcl list. +
+ + +
+match ?-nocase? glob_style_match_pattern> +
+
This text constraint matches if the text value matches the + glob style pattern given as argument. It follows the rules of + the Tcl [string match] command, see + https://www.tcl.tk/man/tcl8.6/TclCmd/string.htm#M35.
+ + +
+regexp expression +
+
This text constraint matches if the text value matches the + regular expression given as argument. https://www.tcl.tk/man/tcl8.6/TclCmd/re_syntax.htm describes the regular expression syntax
+ + +
+length length +
+
This text constraint matches if the length of the text + value (in characters, not bytes) is length. The + length argument must be a positive integer or zero.
+ + +
+maxLength length +
+
This text constraint matches if the length of the text + value (in characters, not bytes) is at most length. The + length argument must be an integer greater zero.
+ + +
+minLength length +
+
This text constraint matches if the length of the text + value (in characters, not bytes) is at least length. + The length argument must be an integer greater zero.
+ + +
+id ?keySpace? +
+
This text constraint command marks the text as a + document wide ID (to be referenced by an idref). Every ID + value within a document must be unique. It isn't an error if + the ID isn't actually referenced within the document. The + optional argument keySpace does all this for a named + key space. The key space "" (the empty sting) is another key + space then the id command without keySpace + argument.
+ + +
+idref ?keySpace? +
+
This text constraint command expects the text to be + a reference to an ID within the document. The referenced + ID may appear later in the document than the reference. + Several references within the document to one ID are + possible. For the optional keySpace argument see + id +
+ + +
+jsontype <JSON text type> +
+
If not postvalidating a DOM tree with + domvalidate this constraint always matches. If + postvalidating the current TEXT_NODE to check must have + the JSON text type given as argument to the text + constraint command. The possible types are NULL, + TRUE, FALSE, STRING and + NUMBER.
+ +
+ + +

Local key constraints

Document wide uniqueness and foreign key constraints are + available with the text constraint commands id and idref. + Keyspaces allow for sub-tree local uniqueness and foreign key + constraints.

+ +
+keyspace <names list> <constraint script> +
+
Any number of keyspaces are possible. A keyspace is + either active or not. An inside a constraint + script called keyspace with the same name does + nothing.
+ +

This text constraint commands work with keyspaces:

+ +
+key <name> +
+
If the keyspace with the name <name> is + not active the constraint always matches. If the keyspace + is active, reports error if there is already a key with + the value. Otherwise it stores the value as key in this + keyspace and matches.
+ + +
+keyref <name> +
+
If the keyspace with the name <name> is not + active always matches. If the keyspace is active then + reports error if there is still no key as the value at the + end of the keyspace <name>. Otherwise, it + matches.
+ +
+ +

Recovering

By default the validation engine stops at the first detected + validation violation and reports that finding. It does so by + return false (and sets, if given, the result variable with an + error message) in case the schema command itself is used to + validate input. If the schema command is used by a SAX parser or + the DOM parser, it does so by throwing error.

If a reportcmd is set this command is called on global + level appended with the schema command and an error type as + arguments in case a validation violation is detected. Then the + validation recovers from the error and continues. For some + validation errors the recover strategy can be determined with + the script result of the reportcmd.

With a reportcmd (as long as the reportcmd does + not throw error while called) the validation engine will never + report validation failure to its caller. The validation engine + recovers, continues, and reports the next error (if occurring) + and so on until the end of the input. The schema command will + return true and the SAX parser and DOM builder will process + normally until the end of the input, as if there had not been a + validation error.

Please note that this happens only for validation errors. It + is not possible to recover from well-formedness errors. If the + input is not well-formed, the schema command returns false and + sets (if given) the result variable with an error message about + the well-formedness error.

If the reportcmd throws error while called by the + validation engine then validation stops and the schema command + throws error with the error message of the script.

While validating basically three events can happen: an + element start tag has to match, a piece of text has to match or + an element end tag has to match. The method info vaction + called in the recovering script or any script code called from + there returns, which event has triggered the error report + (MATCH_ELEMENT_START, MATCH_TEXT, MATCH_ELEMENT_END, + respectively). While the command walks throu the schema looking + whether the event matches other, data driven events (as, for example + checking, if any keyref within a keyspace exists) may happen.

Several of the validation error codes, appended as second + argument to the reportcmd calls, may happen at more than + one kind of validation event. The info vaction method and + its subcommands provide information about the current validation + event, if called from the report command.

If a structural validation error happens, the default + recovering strategy is to ignore any following (or missing) + content within the current subtree and to continue with the + element end event of the subtree.

Returning "ignore" from the recovering script in case of + error type MISSING_ELEMENT recovers by ignoring the failed + constraint and continues to match the event further against the + schema.

Returning "vanish" from the recover script in case of the + error types MISSING_ELEMENT and UNEXPECTED_ELEMENT recovers by + ignoring the event.

+ +

Examples

The XML Schema Part 0: Primer Second Edition + (https://www.w3.org/TR/xmlschema-0/) starts with this + example schema:

+<xsd:schema xmlns:xsd="http://www.w3.org/2001/XMLSchema">
+
+  <xsd:annotation>
+    <xsd:documentation xml:lang="en">
+     Purchase order schema for Example.com.
+     Copyright 2000 Example.com. All rights reserved.
+    </xsd:documentation>
+  </xsd:annotation>
+
+  <xsd:element name="purchaseOrder" type="PurchaseOrderType"/>
+
+  <xsd:element name="comment" type="xsd:string"/>
+
+  <xsd:complexType name="PurchaseOrderType">
+    <xsd:sequence>
+      <xsd:element name="shipTo" type="USAddress"/>
+      <xsd:element name="billTo" type="USAddress"/>
+      <xsd:element ref="comment" minOccurs="0"/>
+      <xsd:element name="items"  type="Items"/>
+    </xsd:sequence>
+    <xsd:attribute name="orderDate" type="xsd:date"/>
+  </xsd:complexType>
+
+  <xsd:complexType name="USAddress">
+    <xsd:sequence>
+      <xsd:element name="name"   type="xsd:string"/>
+      <xsd:element name="street" type="xsd:string"/>
+      <xsd:element name="city"   type="xsd:string"/>
+      <xsd:element name="state"  type="xsd:string"/>
+      <xsd:element name="zip"    type="xsd:decimal"/>
+    </xsd:sequence>
+    <xsd:attribute name="country" type="xsd:NMTOKEN"
+                   fixed="US"/>
+  </xsd:complexType>
+
+  <xsd:complexType name="Items">
+    <xsd:sequence>
+      <xsd:element name="item" minOccurs="0" maxOccurs="unbounded">
+        <xsd:complexType>
+          <xsd:sequence>
+            <xsd:element name="productName" type="xsd:string"/>
+            <xsd:element name="quantity">
+              <xsd:simpleType>
+                <xsd:restriction base="xsd:positiveInteger">
+                  <xsd:maxExclusive value="100"/>
+                </xsd:restriction>
+              </xsd:simpleType>
+            </xsd:element>
+            <xsd:element name="USPrice"  type="xsd:decimal"/>
+            <xsd:element ref="comment"   minOccurs="0"/>
+            <xsd:element name="shipDate" type="xsd:date" minOccurs="0"/>
+          </xsd:sequence>
+          <xsd:attribute name="partNum" type="SKU" use="required"/>
+        </xsd:complexType>
+      </xsd:element>
+    </xsd:sequence>
+  </xsd:complexType>
+
+  <!-- Stock Keeping Unit, a code for identifying products -->
+  <xsd:simpleType name="SKU">
+    <xsd:restriction base="xsd:string">
+      <xsd:pattern value="\d{3}-[A-Z]{2}"/>
+    </xsd:restriction>
+  </xsd:simpleType>
+
+</xsd:schema>
+

A simple one-to-one translation of that into a tDOM schema + definition script would be:

+tdom::schema schema      
+schema define {
+
+    # Purchase order schema for Example.com.
+    # Copyright 2000 Example.com. All rights reserved.
+
+    defelement purchaseOrder {ref PurchaseOrderType}
+
+    foreach elm {comment name street city state product} {
+        defelement $elm text
+    }
+
+    defpattern PurchaseOrderType {
+        element shipTo ! {ref USAddress}
+        element billTo ! {ref USAddress}
+        element comment ?
+        element items
+        attribute orderDate date
+    }
+
+    defpattern USAddress {
+        element name
+        element street
+        element city
+        element state
+        element zip ! {text number}
+        attribute country {fixed "US"}
+    }
+
+    defelement items {
+        element item * {
+            element product
+            element quantity ! {text positiveInteger}
+            element USPrice ! {text number}
+            element comment
+            element shipDate ? {text date}
+            attribute partNum {regexp "^\d{3}-[A-Z]{2}$"}
+        }
+    }
+}
+      
+

The RELAX NG Tutorial + (http://relaxng.org/tutorial-20011203.html) starts with + this example:

+Consider a simple XML representation of an email address book:
+
+<addressBook>
+  <card>
+    <name>John Smith</name>
+    <email>js@example.com</email>
+  </card>
+  <card>
+    <name>Fred Bloggs</name>
+    <email>fb@example.net</email>
+  </card>
+</addressBook>
+
+The DTD would be as follows:
+
+<!DOCTYPE addressBook [
+<!ELEMENT addressBook (card*)>
+<!ELEMENT card (name, email)>
+<!ELEMENT name (#PCDATA)>
+<!ELEMENT email (#PCDATA)>
+]>
+
+A RELAX NG pattern for this could be written as follows:
+
+<element name="addressBook" xmlns="http://relaxng.org/ns/structure/1.0">
+  <zeroOrMore>
+    <element name="card">
+      <element name="name">
+        <text/>
+      </element>
+      <element name="email">
+        <text/>
+      </element>
+    </element>
+  </zeroOrMore>
+</element>
+      
+

This schema definition script will do the same:

+tdom::schema schema      
+schema define {
+    defelement addressBook {
+        element card *
+    }
+    defelement card {
+        element name
+        element email
+    }
+    foreach e {name email} {
+        defelement $e text
+    }
+}
+      
+
+ +

KEYWORDS

+Validation, Postvalidation, DOM, SAX +

+
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tcl9tdom096.dll b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tcl9tdom096.dll new file mode 100644 index 00000000..f8e02e9e Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tcl9tdom096.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/tdom.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdom.tcl similarity index 100% rename from src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.5/tdom.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdom.tcl diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdomcmd.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdomcmd.html new file mode 100644 index 00000000..6e192cfc --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdomcmd.html @@ -0,0 +1,90 @@ + + +tDOM manual: tdom + +
+
+NAME · SYNOPSIS · DESCRIPTION · SEE ALSO · KEYWORDS +
+
+

NAME

+tdom -
tdom is an expat parser object extension to create an in-memory +DOM tree from the input while parsing.

+ + +

SYNOPSIS

package require tdom
+
+set parser [expat]
+
+tdom $parser enable
+ +

DESCRIPTION

+tdom adds the C handler set "tdom" to an tcl expat +parser obj. This handler set builds an in-memory DOM tree out of the input, +parsed by the parser. A DOM tree created this way behave exactly like a DOM +tree created by the "dom" command (see there). In fact, tdom is only +another interface to the same functionality; it uses the code behind the +dom code for building the DOM tree.

+ +
+tdom parserObj enable +
+ +

Adds the tdom C handler set to a Tcl expat parser object. Next +time, the parser parses input, the tdom C handler functions create an in-memory +DOM tree.

+ + + +
+tdom parserObj getdoc +
+ +

Returns the DOM tree as domDoc (see there) object.

+ + + +
+tdom parserObj setStoreLineColumn ?boolean?
+ +

See the method setStoreLineColumn of the +dom command.

+ + + +
+tdom parserObj remove +
+ +

Removes the tdom C handler set from the parser +object.

+ + + +
+tdom parserObj keepEmpties +
+ +

See the option -keepEmpties of the dom command.

+ + + +
+tdom parserObj setExternalEntityResolver script +
+
+ + +
+ +

SEE ALSO

dom, expat

+ +

KEYWORDS

+DOM, SAX, C handler set +

+ +
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdomstub.lib b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdomstub.lib new file mode 100644 index 00000000..927a9d01 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tdomstub.lib differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tnc.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tnc.html new file mode 100644 index 00000000..8c9d17de --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/tnc.html @@ -0,0 +1,140 @@ + + +tDOM manual: tnc + +
+
+NAME · SYNOPSIS · DESCRIPTION · BUGS · KEYWORDS +
+
+

NAME

+tnc -
tnc is an expat parser object extension, that validates the XML +stream against the document DTD while parsing.

+ +

SYNOPSIS

package require tdom
+package require tnc
+
+set parser [expat]
+
+tnc $parser enable
+ +

DESCRIPTION

+tnc adds the C handler set "tnc" to a tcl expat parser +obj. This handler set is a simple DTD validator. If the validator detects a +validation error, it sets the interp result, signals error and stops +parsing. There isn't any validation error recovering. As a consequence, only +valid documents are completely parsed.

This handler set has only three methods:

+ +
+tnc parserObj enable +
+ +

Adds the tnc C handler set to a Tcl expat parser object.

+ + + +
+tnc parserObj remove +
+ +

Removes the tnc validatore from the parser parserObj +and frees all information, stored by it.

+ + + +
+tnc parserObj getValidateCmd ?validateCmdName? +
+ +
+

Returns a new created validation command, if one is available +from the parser command, otherwise it signals error. The name of the validation +command is the validateCmdName, if this optional argument was given, or +a random chosen name. A validation command is available in a parser command, +if the parser with tnc enabled was previously used, to parse an XML document +with a valid doctype declaration, a valid external subset, if one was given by +the doctype declaration, and a valid internal subset. The further document +doesn't need to be valid, to make the validation command available. The +validation command can only get received one time from the parser command. The +created validation command has this syntax:

+ +
+validationCmd method ?args?
+
+ +

The valid methods are:

+ +
+ +
+validateDocument domDocument ?varName? +
+
Checks, if the given domDocument is valid against the DTD +information represented by the validation command. Returns 1, if the document +ist valid, 0 otherwise. If the varName argument is given, then the +variable it names is set to the detected reason for the validation error or to +the empty string in case of a valid document.
+ + + +
+validateTree elementNode ?varName? +
+ +
Checks, if the given subtree with domNode as root element +is a possible valid subtree of a document conforming to the DTD information +represented by the validation command. IDREF could not checked, while +validating only a subtree, but it is checked, that every known ID attribute in +the subtree is unique. Returns 1, if the subtree is OK, 0 otherwise. If the +varName argument is given, then the variable it names is set to the +detected reason for the validation error or to the empty string in case of +a valid subtree.
+ + + + +
+validateAttributes elementNode ?varName? +
+ +
Checks, if there is an element declaration for the name of the +elementNode in the DTD represented by the validation command and, if +yes, if the attributes of the elementNode are conform to the ATTLIST +declarations for that element in the DTD. Returns 1, if the attributes and +there value types are OK, 0 otherwise. If the varName argument is given, +then the variable it names is set to the detected reason for the validation +error or to the empty string in case the element has all its required +attributes, only declared attributes and the values of the attributes matches +there type.
+ + + + +
delete
+
Deletes the validation command and frees the memory used by +it. Returns the empty string.
+ + +
+
+ +
+ +

BUGS

The validation error reports could be much more informative and +user-friendly.

The validator doesn't detect ambiguous content models (see XML +recomendation Section 3.2.1 and Appendix E). Most Java validators also doesn't, +but handle such content models right anyhow. Tnc does not; if your DTD has +such ambiguous content models, tnc can not used to validate documents against +such (not completely XML spec compliant) DTDs.

It isn't possible to validate XML documents with standalone="yes" in the +XML Declaration

Violations of the validity constraints Proper Group/PE Nesting and +Proper Conditional Section/PE Nesting are not detected. They could only happen +inside a invalid DTD, not in the content of a document.

+

KEYWORDS

+Validation, DTD +

+ +
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/xpathFunc.html b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/xpathFunc.html new file mode 100644 index 00000000..9dfc5d88 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tdom0.9.6/xpathFunc.html @@ -0,0 +1,224 @@ + + +tDOM manual: xpathFunc + +
+
+NAME · SYNOPSIS · DESCRIPTION · EXAMPLES · HELPER PROCS · LIMITS · KEYWORDS +
+
+

NAME

+::dom::xpathFunc -
Scripted XPath functions

+ +

SYNOPSIS

::dom::xpathFunc::funcName ctxNode pos nodeListType nodeList ?type arg type arg...?
+::dom::xpathFunc::namespaceURL::funcName ctxNode pos nodeListType nodeList ?type arg type arg...?
+ +

DESCRIPTION

+ tDOM's XPath engine supports custom XPath functions implemented by Tcl + commands. When it encounters a function call to an unknown function name + without a namespace qualifier, the XPath engine looks for a Tcl command of + the same name in the ::dom::xpathFunc namespace. If it encounters + an unknown namespace-qualified function call, it looks for a Tcl namespace + with a name equal to the function's full namespace URI inside + ::dom::xpathFunc, and a Tcl command named for the local part of the + function's name inside that namespace. If it finds such a Tcl command, it + is executed with at least the following arguments, to describe the current + XPath context: +

+ +
ctxNode
+
The domNode object command of the XPath context node.
+ + +
pos
+
+ The XPath context position, in zero-based form - that is, the return + value of the standard XPath position() function in the context + would be $pos - 1. +
+ + +
nodeListType
+
+ The type name for nodeList, as for the + selectNodes method's typeVar. +
+ + +
nodeList
+
+ The list of the current worked on XPath step result (as selectNodes would return + them) in document order. ctxNode will be equal to [lindex $nodeList $pos]. +
+ +

+ If the function call includes any arguments, two arguments will be + appended to the command's argument list for each one: +

+ +
type
+
+ The argument's type name, as for selectNodes's + typeVar. +
+ + +
val
+
+ The argument's value, as selectNodes would return + it in an XPath expression's result set. +
+ +

+ The command is required to return a 1- or 2-element Tcl list to provide + the result of the XPath function call. If the result list has two + elements, the first is the result's XPath type name, and the second is an + appropriately encoded value (note that the attrnodes type name is + not supported): +

+ +
bool
+
Tcl boolean value acceptable to Tcl_GetBooleanFromObj.
+ + +
number
+
+ Tcl numeric value acceptable to Tcl_GetSizeIntFromObj or + Tcl_GetDoubleFromObj. +
+ + +
string
Simple string.
+ + +
nodes
Tcl list of domNode object commands.
+ + +
attrvalues
Alias for string.
+ +

+ If the result list has only one element, it is treated as a simple string. + It is an error for the result to have zero elements, more than two + elements, or to be invalid as a Tcl list, and it is an error if the + val of a two-part result does not match the requirements described + above for its type. +

+ +

EXAMPLES

+ A simple workalike for the XPath 2/3 fn:matches() function, not + otherwise available in an XPath 1.0 engine such as tDOM's: + 

proc ::dom::xpathFunc::regmatch {
+    ctxNode pos nodeListType nodeList
+    inputType inputVal patternType patternVal
+} {
+    set input [::dom::xpathFuncHelper::coerce2string $inputType $inputVal]
+    set pattern [::dom::xpathFuncHelper::coerce2string $patternType $patternVal]
+    return [list bool [regexp -- $pattern $input]]
+}
+ +

HELPER PROCS

+ The ::dom::xpathFuncHelper namespace contains helper procs for the + convenience of scripted XPath functions: +

+ +
coerce2number type val +
+
+ Given a type and val as provided to scripted XPath + functions in their argument lists, convert the val to a number in a + manner appropriate for its type: +
+ +
empty
Always zero.
+ + +
number
Unchanged.
+ + +
string
+
+ Unchanged. (Note that no error is raised if val is not + numeric.) +
+ + +
attrvalues
+value's first element.
+ + +
nodes
+
+ The result of the number() XPath function called on the + first node in the list. +
+ + +
attrnodes
+
+ The value of the single attribute assumed to be in value. + Note that no error is raised if this value is non-numeric. +
+ +
+
+ + +
coerce2string type val +
+
+ As for coerce2number, but convert val to a + pure string: +
+ +
empty
The empty string.
+ + +
number
Unchanged.
+ + +
string
Unchanged.
+ + +
attrvalues
+value's first element.
+ + +
nodes
+
+ The result of the string() XPath function called on the + first node in the list. +
+ + +
attrnodes
+
+ The value of the single attribute assumed to be in value. +
+ +
+
+ +
+ +

LIMITS

+ Custom XPath function names are limited to 200 characters, + including any namespace URI and the :: Tcl namespace + separator between it and the local part. Function calls may have + a maximum of 22 arguments (the argument values itself may be + large nodesets). If you really need more this limits may be + adjusted by build time defines. Tcl commands created with the + deprecated Tcl_CreateCommand interface cannot be used + as scripted XPath functions. +

You must not alter any of the DOM trees from which nodes are + provided to a scripted XPath function as argument (this is true + for the ctxNode argument as well as for the nodes in the nodeList + argument). Use them strictly read-only. Ignoring this advice may + have any unpredictable results including segmentation faults or + security problems.

+ +

KEYWORDS

XPath

+
+Contents · Index · Keywords · Repository +
+ + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/LICENSE b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/LICENSE new file mode 100644 index 00000000..4ef86b53 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2023 Neofytos Dimitriou + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/pkgIndex.tcl new file mode 100644 index 00000000..11bf8df2 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/pkgIndex.tcl @@ -0,0 +1 @@ +package ifneeded tjson 1.0.25 [list load [file join $dir tcl9tjson1025.dll]] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/readme.md b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/readme.md new file mode 100644 index 00000000..cc1d865e --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/readme.md @@ -0,0 +1,159 @@ +# tjson + +TCL/C extension for parsing, manipulating, and querying JSON. + +## Examples +``` +package require tjson + +# Parse JSON string and return a simple TCL structure +# ::tjson::json_to_simple json_string + +::tjson::json_to_simple {{"a": 1, "b": true, "c": [1, 2, 3], "d": {"d1":"a", "d2":"b"}}} true +=> a 1 b 1 c {1 2 3} d {d1 a d2 b} + +# Parse JSON string and return a typed TCL structure +# ::tjson::json_to_typed json_string + +::tjson::json_to_typed {{"a": 1, "b": true, "c": [1, 2, 3], "d": {"d1":"a", "d2":"b"}}} +=> M {a {N 1} b {BOOL 1} c {L {{N 1} {N 2} {N 3}}} d {M {d1 {S a} d2 {S b}}}} + +# Serialize a typed TCL structure to JSON. +# ::tjson::typed_to_json typed_spec + +::tjson::typed_to_json {M {a {N 1} b {BOOL 1} c {L {{N 1} {N 2} {N 3}}} d {M {d1 {S a} d2 {S b}}}}} +=> {"a": 1, "b": true, "c": [1, 2, 3], "d": {"d1": "a", "d2": "b"}} + +# Escape JSON string +# ::tjson::escape_json_string string + +::tjson::escape_json_string "hello\"world\n" +=> hello\"world\n +``` + +## Build the tjson extension + +The following works for Linux and MacOS. For windows, see the [Windows Build Instructions](docs/windows.md). + +```bash +For TCL: +```bash +# Build the TCL extension +wget https://github.com/jerily/tjson/archive/refs/tags/v1.0.25.tar.gz +tar -xzf v1.0.25.tar.gz +export TJSON_DIR=$(pwd)/tjson-1.0.25 +cd ${TJSON_DIR} +mkdir build +cd build +cmake .. +# or if TCL is not in the default path (/usr/local/lib): +# change "TCL_LIBRARY_DIR" and "TCL_INCLUDE_DIR" to the correct paths +# cmake .. -DTCL_LIBRARY_DIR=/usr/local/lib -DTCL_INCLUDE_DIR=/usr/local/include +cmake --build . +cmake --install . +# tclsh8.6 ../examples/example1.tcl +``` + +For NaviServer using Makefile: +``` +cd ${TJSON_DIR} +make +make install +``` + +## TCL Commands + +* **::tjson::json_to_simple** *json_string* + - returns a simple TCL structure (e.g. list, dict, or string) +* **::tjson::json_to_typed** *json_string* + - returns a typed TCL structure (pairs of types and values, M for object, L for list, S for string, N for number, BOOL for boolean) +* **::tjson::typed_to_json** *typed_spec* + - returns a JSON string from a typed TCL structure (like the one returned by ::tjson::json_to_typed) +* **::tjson::parse** *json_string* *?varname?* + - returns a handle to manipulate the JSON string +* **::tjson::create** *typed_spec* *?varname?* + - returns a handle to manipulate the JSON of the typed TCL structure +* **::tjson::destroy** *handle* + - destroys the JSON node structure for the given handle +* **::tjson::size** *handle* + - returns the size of the JSON node structure for the given handle +* **::tjson::add_item_to_object** *handle* *key* *typed_spec* + - adds an item to an object using the typed format +* **::tjson::replace_item_in_object** *handle* *key* *typed_spec* + - replaces an item in an object using the given typed format +* **::tjson::delete_item_from_object** *handle* *key* + - deletes an item from an object +* **::tjson::get_object_item** *handle* *key* + - gets an item from an object +* **::tjson::add_item_to_array** *handle* *typed_spec* + - adds an item to an array using the typed format +* **::tjson::insert_item_in_array** *handle* *index* *typed_spec* + - inserts an item at the given 0 based index and shifts all the existing items to the right +* **::tjson::replace_item_in_array** *handle* *index* *typed_spec* + - replaces an item at the given 0 based index +* **::tjson::delete_item_from_array** *handle* *index* + - deletes an item at the given 0 based index and shifts all the existing items to the left +* **::tjson::get_array_item** *handle* *index* + - gets an item at the given 0 based index +* **::tjson::get_child_items** *handle* + - gets all the child items of an object or array +* **::tjson::get_string** *handle* + - returns the string key of the node +* **::tjson::get_valuestring** *handle* + - returns the string value of the node +* **::tjson::is_number** *handle* + - returns true if node holds a number +* **::tjson::is_bool** *handle* + - returns true if node holds a boolean value +* **::tjson::is_string** *handle* + - returns true if node holds a string value +* **::tjson::is_null** *handle* + - returns true if node holds a nullß +* **::tjson::to_simple** *handle* + - returns a simple TCL structure (e.g. list, dict, or string) for the given node +* **::tjson::to_typed** *handle* + - returns a typed TCL structure for the given node +* **::tjson::to_json** *handle* + - returns a JSON string for the given node +* **::tjson::to_pretty_json** *handle* + - returns a prettified JSON string for the given node +* **::tjson::query** *handle* *jsonpath* + - returns a list of handles for the given JSON path expression +* **::tjson::custom_to_typed** *custom_spec* + - returns a typed TCL structure for the given custom (triple notation / bson) spec +* **::tjson::typed_to_custom** *typed_spec* + - returns a custom (triple notation / bson) spec from a typed TCL structure (like the one returned by ::tjson::custom_to_typed) + + +## Typed TCL Notation/Spec + +| JSON Type | Spec Type | Example | +|-----------|-----------|---------------------------------------------------------------------------| +| Object | M | {M {a {N 1} b {BOOL 1} c {L {{N 1} {N 2} {N 3}}}} | +| Array | L | {L {{N 1} {N 2} {N 3}}}
{L {{S "this"} {S "is"} {S "a"} {S "test"}}} | +| String | S | {S a} | +| Number | N | {N 1} | +| Boolean | BOOL | {BOOL 1} | + + +## JSONPath Syntax + +| JSONPath Expression | Description | +|---------------------|-----------------------------------------------------------------------------------------------------------| +| $ | The root object or array | +| .property | Selects the specified property in a parent object | +| ['property'] | Selects the specified property in a parent object. Be sure to put single quotes around the property name. | +| [n] | Selects the *n*-th element from an array. Indexes are 0-based. | +| [start:end] | Selects array elements from the start index and up to, but not including, end index. | +| [start:] | Selects array elements from the start index to the end of the array. | +| [:end] | Selects array elements from the first element up to, but not including, the end index. | +| [-n:] | Selects the last *n* elements in the array. | + + + + + + + + + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/tcl9tjson1025.dll b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/tcl9tjson1025.dll new file mode 100644 index 00000000..8afe593a Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/tjson1.0.25/tcl9tjson1025.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/README.txt b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/README.txt new file mode 100644 index 00000000..38d628f3 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/README.txt @@ -0,0 +1,157 @@ +Tool Command Language (TCL) Transport Layer Security (TLS) Extension + +Intro +===== + +This package provides an extension which implements Secure Socket Layer (SSL) +and Transport Layer Security (TLS) encryption over Transmission Control +Protocol (TCP) network communication channels utilizing the OpenSSL library. + + +Description +=========== + +This extension works by creating a layered TCL Channel on top of an existing +bi-directional channel created by the TLS socket command. All existing socket +functionality is supported in addition to several new options. Both client and +server modes are supported. + + +Features +======== + +The package provides: +- Encrypted TCP communications layered on TCL channels. +- Status of encrypted channels. +- View X.509 certificate contents. + + +Documentation +============= + +See the doc directory for the full usage documentation. + + +Compatibility +============= + +TCL +--- + +This package requires TCL 8.5 or later. It will also work with TCL 9, but it is +not binary compatible between major TCL versions. This means if this extension +is built with TCL 8.x it will not load into TCL 9 or vice versa. It is best +to compile both separately then install them with the compatible TCL versions. + +OpenSSL +------- + +This package is compatible with OpenSSL v1.1.1 or later, though 3.2 or later is +preferred. See http://www.openssl.org/. Please note that there are a few API +incompatibilities between OpenSSL 1.1.1 and 3.x, so if this extension is built +against OpenSSL 1.1.1 it is not binary compatible with OpenSSL 3.x or vice +versa. + +TCLTLS +------ + +There were several changes made in the callback command arguments between +versions 1.7 and 2.0. See doc/tls.html for what changed and library/tls.tcl +for example handler functions that are backwards compatible. + + +Installation +============ + +This package uses the TCL Extension Architecture (TEA) to build and install on +any supported Unix, Mac, or MS Windows system. It depends on the OpenSSL +libraries being available prior to building the TCLTLS extension. + +UNIX and Linux +-------------- + +The standard TEA config, make, and install process is supported. + + $ cd tcltls + $ ./configure --enable-64bit + $ make + $ make test + $ make install + +The supported configure options include all of the standard TEA configure +script options, plus: + + --disable-tls1 disable TLS1 protocol + --disable-tls1_1 disable TLS1.1 protocol + --disable-tls1_2 disable TLS1.2 protocol + --disable-tls1_3 disable TLS1.3 protocol + --enable-debug enable debugging mode and output more status + --enable-ssl-fastpath enable using the underlying file descriptor for talking directly to the SSL library + --enable-hardening enable hardening attempts + --enable-static-ssl enable static linking to the SSL library + +If either TCL or OpenSSL are installed in non-standard locations, the following +configure options are available. For all options, see ./configure --help. + + --with-tcl= path to where tclCondig.sh file resides + --with-tclinclude= directory containing the public Tcl header files + --with-openssl-dir= path to root directory of OpenSSL installation + --with-openssl-includedir= path to include directory of OpenSSL installation + --with-openssl-libdir= path to lib directory of OpenSSL installation + --with-openssl-pkgconfig= path to root directory of OpenSSL pkg-config directory + + +MacOS +----- + +The standard TEA installation process is supported. Use the --with-tcl option +to set the TCL path if the ActiveState or other non-Apple version of TCL is to +be used. + + $ cd tcltls + $ ./configure --with-tcl=/Library/Frameworks/Tcl.framework/ + $ make + $ make test + $ make install + + +Windows +------- + +If installing with MinGW, use the TEA build process. If using MS Visual C +(MSVC), see win/README.txt for the build and installation instructions. + + +Certificate Validation +---------------------- + +If OpenSSL is not installed on the system, the Certificate Authority (CA) +provided certificates must be downloaded and installed with the software. +These are used for certificate validation. The CURL team makes them available +at https://curl.se/docs/caextract.html. Look for the cacert.pem file. + + +Copyrights +========== + +Original TLS Copyright (C) 1997-2000 Matt Newman +TLS 1.4.1 Copyright (C) 2000 Ajuba Solutions +TLS 1.6 Copyright (C) 2008 ActiveState Software Inc. +TLS 1.7 Copyright (C) 2016 Matt Newman, Ajuba Solutions, ActiveState + Software Inc, Roy Keene +TLS 1.8-2.0 Copyright (C) 2023-2024 Brian O'Hagan + +Acknowledgments +=============== + +Non-exclusive credits for TLS are: + Original work: Matt Newman @ Novadigm + Updates: Jeff Hobbs @ ActiveState + Tcl Channel mechanism: Andreas Kupries + Impetus/Related work: tclSSL (Colin McCormack, Shared Technology) + SSLtcl (Peter Antman) + +License +======= + +This code is licensed under the same terms as the Tcl Core. diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/html/tls.html b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/html/tls.html new file mode 100644 index 00000000..aa163b89 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/html/tls.html @@ -0,0 +1,914 @@ + + + +tls - Tcl TLS extension + + + + + +
+

tls(n) 2.0b2 tls "Tcl TLS extension"

+

Name

+

tls - binding to the OpenSSL library for encrypted socket and I/O channel communications

+
+ + +

Description

+

This extension provides TCL script access to Secure Socket Layer (SSL) +communications using the Transport Layer Security (TLS) protocol. It provides a +generic binding to OpenSSL, utilizing the +Tcl_StackChannel API in TCL 8.4 or later. These sockets behave exactly +the same as channels created using the built-in socket command, but +provide additional options for controlling the SSL/TLS session.

+
+

Compatibility

+

This extension is compatible with OpenSSL 1.1.1 or later. It requires Tcl +version 8.5 or later and will work with Tcl 9.0.

+
+

Commands

+

The following are the commands provided by the TcLTLS package. See +Examples for example usage and the "demos" directory for +more example usage.

+
+
tls::init ?-option? ?value? ?-option value ...?
+

Optional function to set the default options used by tls::socket. If you +call tls::import directly, the values set by this command have no effect. +This command supports all of the same options as the tls::socket command, +though you should limit your options to only the TLS related ones.

+
tls::socket ?-option? ?value? ?-option value ...? host port
+

This is a helper function that utilizes the underlying commands socket +and tls::import to create the connection. It behaves the same as the +native TCL socket command, but also supports the tls::import +command options with one additional option. It returns the channel handle id +for the new socket. Additional options are:

+
+
-autoservername bool
+

If true, automatically set the -servername argument to the +host argument. Prior to TclTLS 2.0, the default is false. +Starting in TclTLS 2.0, the default is true unless -servername +is also specified.

+
+
tls::socket -server command ?-option? ?value? ?-option value ...? port
+

Same as previous command, but instead creates a server socket for clients to +connect to just like the Tcl socket -server command. It returns the +channel handle id for the new socket.

+
tls::import channel ?-option? ?value? ?-option value ...?
+
+
tls::starttls channel ?-option? ?value? ?-option value ...?
+

Start TLS encryption on TCL channel channel via a stacked channel. It +need not be a socket, but must provide bi-directional flow. Also sets session +parameters for SSL handshake. Valid options are:

+
+
-alpn list
+

List of protocols to offer during Application-Layer Protocol Negotiation +(ALPN). For example: h2 and http/1.1, but not h3 or +quic. This option is new for TclTLS 1.8.

+
-cadir directory
+

Specifies the directory where the Certificate Authority (CA) certificates are +stored. The default is platform specific and can be set at compile time. The +default location can be overridden by the SSL_CERT_DIR environment +variable. See Certificate Validation for more details.

+
-cafile filename
+

Specifies the file with the Certificate Authority (CA) certificates to use in +PEM file format. The default is "cert.pem", in the OpenSSL +directory. The default file can be overridden by the SSL_CERT_FILE environment +variable. See Certificate Validation for more details.

+
-castore URI
+

Specifies the Uniform Resource Identifier (URI) for the Certificate Authority +(CA) store, which may be a single container or a catalog of containers. +Starting with OpenSSL 3.2 on MS Windows, set to "org.openssl.winstore://" +to use the built-in MS Windows Certificate Store. +See Certificate Validation for more details. +This option is new for TclTLS 1.8.

+
-certfile filename
+

Specifies the name of the file with the certificate to use in PEM format +as the local (client or server) certificate. It also contains the public key.

+
-cert string
+

Specifies the certificate to use as a DER encoded string (X.509 DER).

+
-cipher string
+

Specifies the list of ciphers to use for TLS 1.2 and earlier connections. +String is a colon ":" separated list of ciphers. +Ciphers can be combined using the "+" character. +Prefixes can be used to permanently remove "!", delete "-", or +move to the end "+" a specified cipher. +Keywords @STRENGTH (sort by algorithm key length), +@SECLEVEL=n (set security level to n), and +DEFAULT (use default cipher list, at start only) can also be specified. +See the OpenSSL +documentation for the full list of valid values.

+
-ciphersuites string
+

Specifies the list of cipher suites to use for TLS 1.3 as a colon +":" separated list of cipher suite names. See the +OpenSSL +documentation for the full list of valid values. +This option is new for TclTLS 1.8.

+
-command callback
+

Specifies the callback command to be invoked at several points during the +handshake to pass errors, tracing information, and protocol messages. +See Callback Options for more info.

+
-dhparams filename
+

Specifies the Diffie-Hellman (DH) parameters file.

+
-keyfile filename
+

Specifies the private key file. The default is to use the file +specified by the -certfile option.

+
-key string
+

Specifies the private key to use as a DER encoded string (PKCS#1 DER).

+
-model channel
+

Force this channel to share the same SSL_CTX structure as the +specified channel, and therefore share config, callbacks, etc.

+
-password callback
+

Specifies the callback command to invoke when OpenSSL needs to obtain a +password. This is typically used to unlock the private key of a certificate. +The callback should return a password string. This option has changed for +TclTLS 1.8. See Callback Options for more info.

+
-post_handshake bool
+

Allow post-handshake session ticket updates. This option is new for TclTLS 1.8.

+
-request bool
+

Request a certificate from the peer during the SSL handshake. This is needed +to do Certificate Validation. Starting in TclTLS 1.8, the default is +true for client connections. Starting in TclTLS 2.0, if set to +false and -require is true, then this will be +overridden to true. +See Certificate Validation for more details.

+
-require bool
+

Require a valid certificate from the peer during the SSL handshake. If this is +set to true, then -request must also be set to true and a either +-cadir, -cafile, -castore, or a platform default +must be provided in order to validate against. The default in TclTLS 1.8 and +earlier versions is false since not all platforms have certificates to +validate against in a form compatible with OpenSSL. Starting in TclTLS 2.0, +the default is true for client connections. +See Certificate Validation for more details.

+
-security_level integer
+

Specifies the security level (value from 0 to 5). The security level affects +the allowed cipher suite encryption algorithms, supported ECC curves, +supported signature algorithms, DH parameter sizes, certificate key sizes +and signature algorithms. The default is 1 prior to OpenSSL 3.2 and 2 +thereafter. Level 3 and higher disable support for session tickets and +only accept cipher suites that provide forward secrecy. +This option is new for TclTLS 1.8.

+
-server bool
+

Specifies whether to act as a server and respond with a server handshake when a +client connects and provides a client handshake. The default is false.

+
-servername hostname
+

Specify the peer's hostname. This is used to set the TLS Server Name Indication +(SNI) extension. Set this to the expected servername in the server's certificate +or one of the Subject Alternate Names (SAN). Starting in TclTLS 2.0, this will +default to the host from the tls::socket command.

+
-session_id binary_string
+

Specifies the session id to resume a session. Not supported yet. +This option is new for TclTLS 1.8.

+
-ssl2 bool
+

Enable use of SSL v2.The default is false. +OpenSSL 1.1+ no longer supports SSL v2, so this may not have any effect. +See the tls::protocols command for supported protocols.

+
-ssl3 bool
+

Enable use of SSL v3. The default is false. Starting in TclTLS 1.8, +use of SSL v3 if only available via a compile time option. +See the tls::protocols command for supported protocols.

+
-tls1 bool
+

Enable use of TLS v1. Starting in TclTLS 2.0, the default is false. +Note: TLS 1.0 needs SHA1 to operate, which is only available in security level +0 for Open SSL 3.0+. See the -security_level option.

+
-tls1.1 bool
+

Enable use of TLS v1.1. Starting in TclTLS 2.0, the default is false. +Note: TLS 1.1 needs SHA1 to operate, which is only available in security level +0 for Open SSL 3.0+. See the -security_level option.

+
-tls1.2 bool
+

Enable use of TLS v1.2. The default is true.

+
-tls1.3 bool
+

Enable use of TLS v1.3. The default is true. This is only available +starting with OpenSSL 1.1.1 and TclTLS 1.7.

+
-validatecommand callback
+

Specifies the callback command to invoke to validate the peer certificates +and other config info during the protocol negotiation phase. This can be used +by TCL scripts to perform their own Certificate Validation to supplement the +default validation provided by OpenSSL. The script must return a boolean true +to continue the negotiation. See Callback Options for more info. +This option is new for TclTLS 1.8.

+
+
tls::handshake channel
+

Forces the TLS negotiation handshake to take place immediately, and returns 0 +if handshake is still in progress (non-blocking), or 1 if the handshake was +successful. If the handshake failed, an error will be returned.

+
tls::shutdown channel
+
+
tls::unimport channel
+
+
tls::unstack channel
+

This terminates the SSL/TLS session by sending the "close_notify" message and +removes the top level stacked channel from channel, but it does not close +the socket. It is the compliment to tls::import by ending encryption of +a TCL channel. An error is thrown if TLS is not the top stacked channel type.

+
tls::status ?-local? channel
+

Returns the current status of an SSL channel. The result is a list of key-value +pairs describing the SSL, certificate, and certificate verification status. If +the SSL handshake has not yet completed, an empty list is returned. If the +-local option is specified, then the local certificate is used. +Returned values include:

+

SSL Status

+
+
alpn protocol
+

The protocol selected after Application-Layer Protocol Negotiation (ALPN). +This value is new for TclTLS 1.8.

+
cipher cipher
+

The current cipher in use for the session.

+
peername name
+

The peername from the certificate. +This value is new for TclTLS 1.8.

+
protocol version
+

The protocol version used for the connection: SSL2, SSL3, TLS1, TLS1.1, TLS1.2, +TLS1.3, or unknown. This value is new for TclTLS 1.8.

+
sbits n
+

The number of bits used for the session key.

+
signatureHashAlgorithm algorithm
+

The signature hash algorithm. +This value is new for TclTLS 1.8.

+
signatureType type
+

The signature type value. +This value is new for TclTLS 1.8.

+
verifyDepth n
+

Maximum depth for the certificate chain verification. Default is -1, to check all. +This value is new for TclTLS 1.8.

+
verifyMode list
+

List of certificate verification modes. +This value is new for TclTLS 1.8.

+
verifyResult result
+

Certificate verification result. +This value is new for TclTLS 1.8.

+
ca_names list
+

List of the Certificate Authorities used to create the certificate. +This value is new for TclTLS 1.8.

+
+

Certificate Status

+
+
all string
+

Dump of all certificate info. +This value is new for TclTLS 1.8.

+
version value
+

The certificate version.

+
serialNumber string
+

The serial number of the certificate as a hex string. +This value was changed from serial in TclTLS 1.8.

+
signature algorithm
+

Cipher algorithm used for certificate signature. +This value is new for TclTLS 1.8.

+
issuer string
+

The distinguished name (DN) of the certificate issuer.

+
notBefore date
+

The beginning date of the certificate validity.

+
notAfter date
+

The expiration date of the certificate validity.

+
subject string
+

The distinguished name (DN) of the certificate subject. Fields include: Common +Name (CN), Organization (O), Locality or City (L), State or Province (S), and +Country Name (C).

+
issuerUniqueID string
+

The issuer unique id. +This value is new for TclTLS 1.8.

+
subjectUniqueID string
+

The subject unique id. +This value is new for TclTLS 1.8.

+
num_extensions n
+

Number of certificate extensions. +This value is new for TclTLS 1.8.

+
extensions list
+

List of certificate extension names. +This value is new for TclTLS 1.8.

+
authorityKeyIdentifier string
+

Authority Key Identifier (AKI) of the Issuing CA certificate that signed the +SSL certificate as a hex string. This value matches the SKI value of the +Intermediate CA certificate. +This value is new for TclTLS 1.8.

+
subjectKeyIdentifier string
+

Subject Key Identifier (SKI) hash of the public key inside the certificate as a +hex string. Used to identify certificates that contain a particular public key. +This value is new for TclTLS 1.8.

+
subjectAltName list
+

List of all of the Subject Alternative Names (SAN) including domain names, sub +domains, and IP addresses that are secured by the certificate. +This value is new for TclTLS 1.8.

+
ocsp list
+

List of all Online Certificate Status Protocol (OCSP) URLs that can be used to +check the validity of this certificate. +This value is new for TclTLS 1.8.

+
certificate cert
+

The PEM encoded certificate.

+
signatureAlgorithm algorithm
+

Cipher algorithm used for the certificate signature. +This value is new for TclTLS 1.8.

+
signatureValue string
+

Certificate signature as a hex string. +This value is new for TclTLS 1.8.

+
signatureDigest version
+

Certificate signing digest as a hex string. +This value is new for TclTLS 1.8.

+
publicKeyAlgorithm algorithm
+

Certificate signature public key algorithm. +This value is new for TclTLS 1.8.

+
publicKey string
+

Certificate signature public key as a hex string. +This value is new for TclTLS 1.8.

+
bits n
+

Number of bits used for certificate signature key. +This value is new for TclTLS 1.8.

+
self_signed boolean
+

Whether the certificate signature is self signed. +This value is new for TclTLS 1.8.

+
sha1_hash hash
+

The SHA1 hash of the certificate as a hex string. +This value is new for TclTLS 1.8.

+
sha256_hash hash
+

The SHA256 hash of the certificate as a hex string. +This value is new for TclTLS 1.8.

+
+
tls::connection channel
+

Returns the current connection status of an SSL channel. The result is a list +of key-value pairs describing the connection. +This command is new for TclTLS 1.8. Returned values include:

+

SSL Status

+
+
state state
+

State of the connection.

+
servername name
+

The name of the connected to server.

+
protocol version
+

The protocol version used for the connection: SSL2, SSL3, TLS1, TLS1.1, TLS1.2, TLS1.3, or unknown.

+
renegotiation_allowed boolean
+

Whether protocol renegotiation is supported or not.

+
security_level level
+

The security level used for selection of ciphers, key size, etc.

+
session_reused boolean
+

Whether the session has been reused or not.

+
is_server boolean
+

Whether the connection is configured as a server (1) or client (0).

+
compression mode
+

Compression method.

+
expansion mode
+

Expansion method.

+
caList list
+

List of Certificate Authorities (CA) for X.509 certificate.

+
+

Cipher Info

+
+
cipher cipher
+

The current cipher in use for the connection.

+
standard_name name
+

The standard RFC name of cipher.

+
algorithm_bits n
+

The number of processed bits used for cipher.

+
secret_bits n
+

The number of secret bits used for cipher.

+
min_version version
+

The minimum protocol version for cipher.

+
cipher_is_aead boolean
+

Whether the cipher is Authenticated Encryption with Associated Data (AEAD).

+
cipher_id id
+

The OpenSSL cipher id.

+
description string
+

A text description of the cipher.

+
handshake_digest boolean
+

Digest used during handshake.

+
+

Session Info

+
+
alpn protocol
+

The protocol selected after Application-Layer Protocol Negotiation (ALPN).

+
resumable boolean
+

Whether the session can be resumed or not.

+
start_time seconds
+

Time since session started in seconds since epoch.

+
timeout seconds
+

Max duration of session in seconds before time-out.

+
lifetime seconds
+

Session ticket lifetime hint in seconds.

+
session_id binary_string
+

Unique session id for use in resuming the session.

+
session_ticket binary_string
+

Unique session ticket for use in resuming the session.

+
ticket_app_data binary_string
+

Unique session ticket application data.

+
master_key binary_string
+

Unique session master key.

+
session_cache_mode mode
+

Server cache mode (client, server, or both).

+
+
tls::ciphers ?protocol? ?verbose? ?supported?
+

Without any options, it returns a list of all symmetric ciphers for use with the +-cipher option. With protocol, only the ciphers supported for that +protocol are returned. See the tls::protocols command for the supported +protocols. If verbose is specified as true then a verbose, human readable +list is returned with additional information on the cipher. If supported +is specified as true, then only the ciphers supported for protocol will be listed. +The supported arg is new for TclTLS 1.8.

+
tls::protocols
+

Returns a list of the supported SSL/TLS protocols. Valid values are: +ssl2, ssl3, tls1, tls1.1, tls1.2, and +tls1.3. Exact list depends on OpenSSL version and compile time flags. +This command is new for TclTLS 1.8.

+
tls::version
+

Returns the OpenSSL version string.

+
+
+

Certificate Validation

+

PKI and Certificates

+

Using the Public Key Infrastructure (PKI), each user creates a private key that +only they know about and a public key they can exchange with others for use in +encrypting and decrypting data. The process is the sender encrypts their data +using their private key and the receiver's public key. The data is then sent +to the receiver. In a similar manner, the receiver uses their private key and +the sender's public key to decrypt the data. This provides data integrity, to +ensure the data can't be viewed or altered during transport. See the +-key and -keyfile options for how to specify the private key. +Also see the -password option for how to provide the password.

+

In order to provide authentication, i.e. ensuring someone is who they say they +are, the public key and user identification info is stored in a X.509 +certificate and that certificate is authenticated (i.e. signed) by a Certificate +Authority (CA). Users can then exchange these certificates during the TLS +initialization process and check them against the root CA certificates to ensure +they are valid. This is handled by OpenSSL via the -request and +-require options. See the -cadir, -cadir, and +-castore options for how to specify where to find the CA certificates. +Optionally, in a future release, they can also be checked against the Certificate +Revocation List (CRL) of revoked certificates. Certificates can also be +self-signed, but they are by default not trusted unless you add them to your +certificate store.

+

Typically when visiting web sites, only the client needs to check the server's +certificate to ensure it is valid. The server doesn't need to check the client +certificate unless you need to authenticate with them to login, etc. See the +-cert and -certfile options if you need to provide a certificate.

+
+

Summary of command line options

+

The following options are used for peer certificate validation:

+
+
-cadir directory
+

Specifies the directory where the Certificate Authority (CA) certificates are +stored. The default is platform specific, but is usually "/etc/ssl/certs" on +Linux/Unix systems. The default location can be overridden by the +SSL_CERT_DIR environment variable.

+
-cafile filename
+

Specifies the file with the Certificate Authority (CA) certificates to use in +PEM file format. The default is "cert.pem", in the OpenSSL +directory. On Linux/Unix systems, this is usually "/etc/ssl/ca-bundle.pem". +The default file can be overridden by the SSL_CERT_FILE environment +variable.

+
-castore URI
+

Specifies the Uniform Resource Identifier (URI) for the Certificate Authority +(CA) store, which may be a single container or a catalog of containers. +Starting with OpenSSL 3.2 on MS Windows, set to "org.openssl.winstore://" +to use the built-in MS Windows Certificate Store. Starting in TclTLS 2.0, this +is the default if -cadir, -cadir, and -castore are +not specified. This store only supports root certificate stores.

+
-request bool
+

Request a certificate from the peer during the SSL handshake. This is needed +to do Certificate Validation. Starting in TclTLS 1.8, the default is +true for client connections. Starting in TclTLS 2.0, if set to +false and -require is true, then this will be +overridden to true. In addition, the client can manually inspect and +accept or reject each certificate using the -validatecommand option.

+
-require bool
+

Require a valid certificate from the peer during the SSL handshake. If this is +set to true, then -request must also be set to true and a either +-cadir, -cafile, -castore, or a platform default +must be provided in order to validate against. The default in TclTLS 1.8 and +earlier versions is false since not all platforms have certificates to +validate against in a form compatible with OpenSSL. Starting in TclTLS 2.0, +the default is true for client connections.

+
+
+

When are command line options needed?

+

In TclTLS 1.8 and earlier versions, certificate validation is +NOT enabled by default. This limitation is due to the lack of a common +cross platform database of Certificate Authority (CA) provided certificates to +validate against. Many Linux systems natively support OpenSSL and thus have +these certificates installed as part of the OS, but MacOS and MS Windows do not. +Staring in TclTLS 2.0, the default for client connections has been changed to +require certificate validation by default. In order to use the -require +option, one of the following must be true:

+
    +

  • On Linux and Unix systems with OpenSSL already installed or if the CA +certificates are available in PEM format, and if they are stored in the +standard locations, or if the SSL_CERT_DIR or SSL_CERT_FILE +environment variables are set, then -cadir, -cadir, +and -castore aren't needed.

    • +

  • If OpenSSL is not installed in the default location, or when using Mac OS +or MS Windows and OpenSSL is installed, the SSL_CERT_DIR and/or +SSL_CERT_FILE environment variables or the one of the -cadir, +-cadir, or -castore options must be defined.

    • +

  • On MS Windows, starting in OpenSSL 3.2, it is now possible to access the +built-in Windows Certificate Store from OpenSSL. This can be utilized by +setting the -castore option to "org.openssl.winstore://". +In TclTLS 2.0, this is the default value if -cadir, +-cadir, and -castore are not specified.

    • +

  • If OpenSSL is not installed or the CA certificates are not available in PEM +format, the CA certificates must be downloaded and installed with the user +software. The CURL team makes them available at +CA certificates extracted +from Mozilla in the "cacert.pem" file. You must then either set the +SSL_CERT_DIR and/or SSL_CERT_FILE environment variables or the +-cadir or -cafile options to the CA cert file's install +location. It is your responsibility to keep this file up to date.

    • +
+
+
+

Callback Options

+

As previously described, each channel can be given their own callbacks +to handle intermediate processing by the OpenSSL library, using the +-command, -password, and -validate_command options +passed to either of tls::socket or tls::import. +Unlike previous versions of TclTLS, only if the callback generates an error, +will the bgerror command be invoked with the error information.

+

Values for Command Callback

+

The callback for the -command option is invoked at several points during the +OpenSSL handshake and during routine operations. See below for the possible +arguments passed to the callback script. Values returned from the callback are +ignored.

+
+
error channelId message
+

This form of callback is invoked whenever an error occurs during the initial +connection, handshake, or I/O operations. The message argument can be +from the Tcl_ErrnoMsg, OpenSSL function ERR_reason_error_string(), +or a custom message. This callback is new for TclTLS 1.8.

+
info channelId major minor message type
+

This form of callback is invoked by the OpenSSL function +SSL_set_info_callback() during the initial connection and handshake +operations. The arguments are:

+
+
major
+

Major category for error. Valid enums are: handshake, alert, +connect, accept.

+
minor
+

Minor category for error. Valid enums are: start, done, read, +write, loop, exit.

+
message
+

Descriptive message string which may be generated either by +SSL_state_string_long() or SSL_alert_desc_string_long(), +depending on the context.

+
type
+

For alerts, the possible values are: warning, +fatal, and unknown. For others, info is used. +This argument is new for TclTLS 1.8.

+
+
message channelId direction version content_type message
+

This form of callback is invoked by the OpenSSL function +SSL_set_msg_callback() whenever a message is sent or received during the +initial connection, handshake, or I/O operations. It is only available when +OpenSSL is complied with the enable-ssl-trace option. This callback is +new for TclTLS 1.8. The arguments are:

+
+
direction
+

Direction is either Sent or Received.

+
version
+

Version is the protocol version.

+
content_type
+

Content type is the message content type.

+
message
+

Message is more info from the SSL_trace API.

+
+
session channelId session_id session_ticket lifetime
+

This form of callback is invoked by the OpenSSL function +SSL_CTX_sess_set_new_cb() whenever a new session id is sent by the +server during the initial connection and handshake and also during the session +if the -post_handshake option is set to true. This callback is new for +TclTLS 1.8. The arguments are:

+
+
session_id
+

Session Id is the current session identifier

+
session_ticket
+

Ticket is the session ticket info

+
lifetime
+

Lifetime is the ticket lifetime in seconds.

+
+
verify channelId depth cert status error
+

This callback was moved to -validatecommand in TclTLS 1.8.

+
+
+

Values for Password Callback

+

The callback for the -password option is invoked by TclTLS whenever OpenSSL needs +to obtain a password. See below for the possible arguments passed to the +callback script. The user provided password is expected to be returned by the +callback.

+
+
password rwflag size
+

Invoked when loading or storing an encrypted PEM certificate. The arguments are:

+
+
rwflag
+

The read/write flag is 0 for reading/decryption or 1 for writing/encryption. +The latter can be used to determine when to prompt the user to confirm. +This argument is new for TclTLS 1.8.

+
size
+

The size is the maximum length of the password in bytes. +This argument is new for TclTLS 1.8.

+
+
+
+

Values for Validate Command Callback

+

The callback for the -validatecommand option is invoked during the handshake +process in order for the application to validate the provided value(s). See +below for the possible arguments passed to the callback script. If not +specified, OpenSSL will accept all valid certificates and extensions. To reject +the value and abort the connection, the callback should return 0. To accept the +value and continue the connection, it should return 1. To reject the value, but +continue the connection, it should return 2. This callback is new for TclTLS 1.8.

+
+
alpn channelId protocol match
+

For servers, this form of callback is invoked when the client ALPN extension is +received. If match is true, then protocol is the first +-alpn protocol option in common to both the client and server. +If not, the first client specified protocol is used. This callback is called +after the Hello and SNI callbacks.

+
hello channelId servername session_id
+

For servers, this form of callback is invoked during client hello message +processing. The purpose is so the server can select the appropriate certificate +to present to the client, and to make other configuration adjustments relevant +to that server name and its configuration. It is called before the SNI and ALPN +callbacks.

+
sni channelId servername
+

For servers, this form of callback is invoked when the Server Name Indication +(SNI) extension is received. The servername argument is the client +provided server name specified in the -servername option. The +purpose is so when a server supports multiple names, the right certificate +can be used. It is called after the Hello callback but before the ALPN +callback.

+
verify channelId depth cert status error
+

This form of callback is invoked by OpenSSL when a new certificate is received +from the peer. It allows the client to check the certificate verification +results and choose whether to continue or not. It is called for each +certificate in the certificate chain. This callback was moved from +-command in TclTLS 1.8. The arguments are:

+
+
depth
+

The depth is the integer depth of the certificate in the certificate chain, +where 0 is the peer certificate and higher values going up to the Certificate +Authority (CA).

+
cert
+

The cert argument is a list of key-value pairs similar to those returned by +tls::status.

+
status
+

The status argument is the boolean validity of the current certificate where 0 +is invalid and 1 is valid.

+
error
+

The error argument is the error message, if any, generated by +X509_STORE_CTX_get_error().

+
+
+

Reference implementations of these callbacks are provided in "tls.tcl" +as tls::callback, tls::password, and tls::validate_command +respectively. Note that these are only sample implementations. In a more +realistic deployment you would specify your own callback scripts on each TLS +channel using the -command, -password, and +-validate_command options.

+

The default behavior when the -command and -validate_command +options are not specified, is for TclTLS to process the associated library +callbacks internally. The default behavior when the -password option +is not specified is for TclTLS to process the associated library callbacks by +attempting to call tls::password. The difference between these two +behaviors is a consequence of maintaining compatibility with earlier +implementations.

+

The use of the reference callbacks tls::callback, tls::password, +and tls::validate_command is not recommended. They may be removed from future releases.

+
+
+

Debug

+

For most debugging needs, the -callback option can be used to provide +sufficient insight and information on the TLS handshake and progress. If +further troubleshooting insight is needed, the compile time option +--enable-debug can be used to get detailed execution flow status.

+

TLS key logging can be enabled by setting the environment variable +SSLKEYLOGFILE to the name of the file to log to. Then whenever TLS key +material is generated or received it will be logged to the file. This is useful +for logging key data for network logging tools to use to decrypt the data.

+

The tls::debug variable provides some additional control over the +debug logging in the tls::callback, tls::password, and +tls::validate_command default handlers in "tls.tcl". +The default value is 0 with higher values producing more diagnostic output, +and will also force the verify method in tls::callback to accept the +certificate, even if it is invalid when the -validatecommand +option is set to tls::validate_command.

+

The use of the variable tls::debug is not recommended. +It may be removed from future releases.

+
+

Examples

+

The following are example scripts to download a webpage and file using the +http package. See Certificate Validation for when the +-cadir, -cafile, and -castore options are also +needed. See the "demos" directory for more example scripts.

+

Example #1: Download a web page

+
+package require http
+package require tls
+set url "https://www.tcl.tk/"
+http::register https 443 [list ::tls::socket -autoservername 1 -require 1]
+# Get URL
+set token [http::geturl $url]
+# Check for error
+if {[http::status $token] ne "ok"} {
+    puts [format "Error %s" [http::status $token]]
+}
+# Save web page to file
+set ch [open example.html wb]
+puts $ch [http::data $token]
+close $ch
+# Cleanup
+::http::cleanup $token
+
+

Example #2: Download a file

+
+package require http
+package require tls
+set url "https://wiki.tcl-lang.org/sitemap.xml"
+http::register https 443 [list ::tls::socket -autoservername 1 -require 1]
+# Open output file
+set filename [file tail $url]
+set ch [open $filename wb]
+# Get file
+set token [::http::geturl $url -blocksize 65536 -channel $ch]
+# Check for error
+if {[http::status $token] ne "ok"} {
+    puts [format "Error %s" [http::status $token]]
+}
+# Cleanup
+close $ch
+::http::cleanup $token
+
+
+

Special Considerations

+

The capabilities of this package can vary enormously based upon how the +linked to OpenSSL library was configured and built. New versions may obsolete +older protocol versions, add or remove ciphers, change default values, etc. +Use the tls::protocols command to obtain the supported +protocol versions.

+
+

Error Messages

+

Some OpsnSSl error messages have cryptic meanings. This is a list of messages +along with their true meaning.

+
+
packet length too long
+

Client has tried to connect to a HTTP server on the plain-text port instead of the SSL/TLS port.

+
unexpected eof while reading
+

Peer has closed the connection without sending the "close notify" shutdown alert.

+
wrong version number
+

Client has tried to connect to a non-HTTP server on a non-TLS (i.e. plain text) port.

+
+
+

See Also

+

OpenSSL, http, socket

+
+

Keywords

+

I/O, IP Address, OpenSSL, SSL, TCP, TLS, TclTLS, asynchronous I/O, bind, certificate, channel, connection, domain name, host, https, network, network address, socket, tls

+
+

Category

+

tls

+
+ +
diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/license.terms b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/license.terms new file mode 100644 index 00000000..1968f88a --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/license.terms @@ -0,0 +1,38 @@ +This software is copyrighted by Matt Newman and other parties. +The following terms apply to all files associated with the software +unless explicitly disclaimed in individual files. + +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. diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/pkgIndex.tcl new file mode 100644 index 00000000..62db4f48 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/pkgIndex.tcl @@ -0,0 +1,33 @@ +# -*- tcl -*- +# Tcl package index file, version 1.1 +# +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded tls 2.0b2 [list apply {{dir} { + # Load library + load [file join $dir tcl9tls20b2.dll] [string totitle tls] + + # Source init file + set initScript [file join $dir tls.tcl] + if {[file exists $initScript]} { + source -encoding utf-8 $initScript + } + }} $dir] +} else { + if {![package vsatisfies [package provide Tcl] 8.5]} {return} + package ifneeded tls 2.0b2 [list apply {{dir} { + # Load library + if {[string tolower [file extension tls20b2.dll]] in [list .dll .dylib .so]} { + # Load dynamic library + load [file join $dir tls20b2.dll] [string totitle tls] + } else { + # Static library + load {} [string totitle tls] + } + + # Source init file + set initScript [file join $dir tls.tcl] + if {[file exists $initScript]} { + source -encoding utf-8 $initScript + } + }} $dir] +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/tcl9tls20b2.dll b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/tcl9tls20b2.dll new file mode 100644 index 00000000..9de8fa98 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/tcl9tls20b2.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tls.tcl b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/tls.tcl similarity index 65% rename from src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tls.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/tls.tcl index e8a4ede6..d9c3a4f9 100644 --- a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tls.tcl +++ b/src/vfs/punk9win.vfs/lib_tcl9/tls2.0b2/tls.tcl @@ -1,10 +1,12 @@ # -# Copyright (C) 1997-2000 Matt Newman +# Support functions for the TLS extension +# +# Copyright (C) 1997-2000 Matt Newman # namespace eval tls { variable logcmd tclLog variable debug 0 - + # Default flags passed to tls::import variable defaults {} @@ -15,7 +17,7 @@ namespace eval tls { # Over-ride this if you are using a different socket command variable socketCmd if {![info exists socketCmd]} { - set socketCmd [info command ::socket] + set socketCmd [info command ::socket] } # This is the possible arguments to tls::socket and tls::init @@ -28,30 +30,39 @@ namespace eval tls { #### iopts: [tls::import] option ### How many arguments the following the option to consume variable socketOptionRules { - {0 -async sopts 0} - {* -myaddr sopts 1} - {0 -myport sopts 1} - {* -type sopts 1} - {* -cadir iopts 1} - {* -cafile iopts 1} - {* -cert iopts 1} - {* -certfile iopts 1} - {* -cipher iopts 1} - {* -command iopts 1} - {* -dhparams iopts 1} - {* -key iopts 1} - {* -keyfile iopts 1} - {* -password iopts 1} - {* -request iopts 1} - {* -require iopts 1} - {* -autoservername discardOpts 1} - {* -servername iopts 1} - {* -ssl2 iopts 1} - {* -ssl3 iopts 1} - {* -tls1 iopts 1} - {* -tls1.1 iopts 1} - {* -tls1.2 iopts 1} - {* -tls1.3 iopts 1} + {0 -async sopts 0} + {* -myaddr sopts 1} + {0 -myport sopts 1} + {* -type sopts 1} + {* -alpn iopts 1} + {* -cadir iopts 1} + {* -cafile iopts 1} + {* -castore iopts 1} + {* -cert iopts 1} + {* -certfile iopts 1} + {* -cipher iopts 1} + {* -ciphersuites iopts 1} + {* -command iopts 1} + {* -dhparams iopts 1} + {* -key iopts 1} + {* -keyfile iopts 1} + {* -password iopts 1} + {* -post_handshake iopts 1} + {* -request iopts 1} + {* -require iopts 1} + {* -securitylevel iopts 1} + {* -autoservername discardOpts 1} + {* -server iopts 1} + {* -servername iopts 1} + {* -session_id iopts 1} + {* -ssl2 iopts 1} + {* -ssl3 iopts 1} + {* -tls1 iopts 1} + {* -tls1.1 iopts 1} + {* -tls1.2 iopts 1} + {* -tls1.3 iopts 1} + {* -validatecommand iopts 1} + {* -vcmd iopts 1} } # tls::socket and tls::init options as a humane readable string @@ -70,7 +81,7 @@ proc tls::_initsocketoptions {} { # Do not re-run if we have already been initialized if {[info exists socketOptionsSwitchBody]} { - return + return } # Create several structures from our list of options @@ -81,43 +92,43 @@ proc tls::_initsocketoptions {} { set options(1) [list] set argSwitchBody [list] foreach optionRule $socketOptionRules { - set ruleServer [lindex $optionRule 0] - set ruleOption [lindex $optionRule 1] - set ruleVarToUpdate [lindex $optionRule 2] - set ruleVarArgsToConsume [lindex $optionRule 3] - - foreach server [list 0 1] { - if {![string match $ruleServer $server]} { - continue - } - - lappend options($server) $ruleOption - } - - switch -- $ruleVarArgsToConsume { - 0 { - set argToExecute { - lappend @VAR@ $arg - set argsArray($arg) true - } - } - 1 { - set argToExecute { - incr idx - if {$idx >= [llength $args]} { - return -code error "\"$arg\" option must be followed by value" - } - set argValue [lindex $args $idx] - lappend @VAR@ $arg $argValue - set argsArray($arg) $argValue - } - } - default { - return -code error "Internal argument construction error" - } - } - - lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] + set ruleServer [lindex $optionRule 0] + set ruleOption [lindex $optionRule 1] + set ruleVarToUpdate [lindex $optionRule 2] + set ruleVarArgsToConsume [lindex $optionRule 3] + + foreach server [list 0 1] { + if {![string match $ruleServer $server]} { + continue + } + + lappend options($server) $ruleOption + } + + switch -- $ruleVarArgsToConsume { + 0 { + set argToExecute { + lappend @VAR@ $arg + set argsArray($arg) true + } + } + 1 { + set argToExecute { + incr idx + if {$idx >= [llength $args]} { + return -code error "\"$arg\" option must be followed by value" + } + set argValue [lindex $args $idx] + lappend @VAR@ $arg $argValue + set argsArray($arg) $argValue + } + } + default { + return -code error "Internal argument construction error" + } + } + + lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] } # Add in the final options @@ -144,7 +155,7 @@ proc tls::initlib {dir dll} { # the tls dll. We choose to make them siblings of the executable. package require starkit set dst [file nativename [file dirname $starkit::topdir]] - foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] { + foreach sdll [glob -nocomplain -directory $dir -tails libssl32.dll libcrypto*.dll libssl*.dll libssp*.dll] { catch {file delete -force $dst/$sdll} catch {file copy -force $dir/$sdll $dst/$sdll} } @@ -207,12 +218,12 @@ proc tls::socket {args} { set args [lreplace $args $idx [expr {$idx+1}]] set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" - set options $socketOptionsServer + set options $socketOptionsServer } else { set server 0 set usage "wrong # args: should be \"tls::socket ?options? host port\"" - set options $socketOptionsNoServer + set options $socketOptionsNoServer } # Combine defaults with current options @@ -247,13 +258,20 @@ proc tls::socket {args} { set host [lindex $args [expr {$argc-2}]] set port [lindex $args [expr {$argc-1}]] - # If an "-autoservername" option is found, honor it - if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} { - if {![info exists argsArray(-servername)]} { - set argsArray(-servername) $host - lappend iopts -servername $host - } - } + # If an "-autoservername" option is found, honor it + if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} { + if {![info exists argsArray(-servername)]} { + set argsArray(-servername) $host + lappend iopts -servername $host + } + } + + # Use host as SNI server name without -autoservername and -servername args + if {![info exists argsArray(-autoservername)] && + ![info exists argsArray(-servername)]} { + set argsArray(-servername) $host + lappend iopts -servername $host + } lappend sopts $host $port } @@ -305,31 +323,81 @@ proc tls::_accept { iopts callback chan ipaddr port } { log 2 "tls::_accept - called \"$callback\" succeeded" } } + # -# Sample callback for hooking: - -# -# error -# verify -# info +# Sample callback for status data from OpenSSL # -proc tls::callback {option args} { +proc tls::callback {option chan args} { variable debug - #log 2 [concat $option $args] - switch -- $option { - "error" { - foreach {chan msg} $args break + "error" { + lassign $args msg log 0 "TLS/$chan: error: $msg" } - "verify" { - # poor man's lassign - foreach {chan depth cert rc err} $args break + "info" { + set type "" + lassign $args major minor msg type + + if {$msg ne ""} { + append state ": $msg" + } + # For tracing + upvar #0 tls::$chan cb + set cb($major) $minor + + log 2 "TLS/$chan: $major/$minor: $state" + } + "message" { + lassign $args direction version content_type msg + + log 0 "TLS/$chan: info: $direction $msg" + } + "session" { + lassign $args session_id ticket lifetime + + log 0 "TLS/$chan: session: lifetime $lifetime" + } + "verify" { + # Backwards compatible for v1.7 + return [tls::validate_command $option $chan {*}$args] + } + default { + return -code error "bad option \"$option\":\ + must be one of error, info, message, or session" + } + } +} + +# +# Sample callback when return value is needed. New for TLS 1.8+. +# +proc tls::validate_command {option chan args} { + variable debug + + switch -- $option { + "alpn" { + lassign $args protocol match + + log 0 "TLS/$chan: alpn: $protocol $match" + } + "hello" { + lassign $args servername + + log 0 "TLS/$chan: hello: $servername" + } + "sni" { + lassign $args servername + + log 0 "TLS/$chan: sni: $servername" + } + "verify" { + lassign $args depth cert rc err array set c $cert - if {$rc != "1"} { + if {$rc ne "1"} { log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" } else { log 2 "TLS/$chan: verify/$depth: $c(subject)" @@ -340,31 +408,19 @@ proc tls::callback {option args} { return $rc } } - "info" { - # poor man's lassign - foreach {chan major minor state msg} $args break - - if {$msg != ""} { - append state ": $msg" - } - # For tracing - upvar #0 tls::$chan cb - set cb($major) $minor - - log 2 "TLS/$chan: $major/$minor: $state" - } default { return -code error "bad option \"$option\":\ - must be one of error, info, or verify" + must be one of alpn, hello, sni, or verify" } } + return 1 } proc tls::xhandshake {chan} { upvar #0 tls::$chan cb if {[info exists cb(handshake)] && \ - $cb(handshake) == "done"} { + $cb(handshake) eq "done"} { return 1 } while {1} { @@ -378,7 +434,10 @@ proc tls::xhandshake {chan} { } } -proc tls::password {} { +# +# Sample callback to get password when needed. Args are new for TLS 1.8+. +# +proc tls::password {{option password} {rwflag 0} {size 0}} { log 0 "TLS/Password: did you forget to set your passwd!" # Return the worlds best kept secret password. return "secret" @@ -388,7 +447,7 @@ proc tls::log {level msg} { variable debug variable logcmd - if {$level > $debug || $logcmd == ""} { + if {$level > $debug || $logcmd eq ""} { return } set cmd $logcmd diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/What-is-New-in-TkTreeCtrl.html b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/What-is-New-in-TkTreeCtrl.html new file mode 100644 index 00000000..d8ff541e --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/What-is-New-in-TkTreeCtrl.html @@ -0,0 +1,3648 @@ + + + + + + + + + + What's New in TkTreeCtrl + +

What's New in TkTreeCtrl 2.4.2

+

Changed how the scroll position is calculated.
+

+
The x/y scroll position has always been +relative to the top-left corner of the widget, when it should really be +relative to the top-left corner of the content area (i.e., the area +inside the borders and headers).  In every previous version, +showing the header would often result in the item visible at the top of +the content area becoming obscured by the header.  The developer +was often forced to add a call [$T yview moveto 0] +as a workaround after creating a treectrl and filling it with +items.  With the new behavior, changing the height (or visibility) +of the headers or borders preserves the scroll position relative to the +top-left corner of the content area.
+
+

New text-element option for positioning the "...".

The new -elidepos text-element option accepts a value of start, middle or end +to control where eliding long lines occurs.  This only works +for single-line text.   Multi-line text is always elided at the +end.
+

New MouseWheel bindings
+

+ +
    +
  • Holding down the Shift key while rotating the mousewheel results in horizontal scrolling.
    • +
  • On Mac OS X, holding down the Option key while rotating the mousewheel results in faster scrolling (10 times normal).
    +
    • +
+

Bug Fixes

+
    +
  • [Bug 3502497]  Builds created with --enable-gtk would change the system locale from "C" which Tcl requires.
    • +
  • [Bug 3520259]  The active/inactive state of a toplevel +containing a treectrl wasn't being tracked properly.  This only +affected Mac OS X, and resulted in headers not having the correct +appearance in some cases.
    • +
  • [Bug 3461526]  Improper memory alignment caused a crash when creating headers on HP-UX ia64 systems.
    • +
  • Fixed compilation of gradient-related code on Mac OS X 64-bit systems.
    • +
  • Fixed Brian Griffin's "1-in-a-million crash" caused by passing a non-static struct to Tcl_GetIndexFromObjStruct().
    +
    • +
+
+

What's New in TkTreeCtrl 2.4.1

+ +

Bug Fixes

+
    +
  • [BUG 3421503] Creating a new treectrl widget would crash the application if the default value of either of the -buttonbitmap or -buttonimage options was changed using the Tk option database.
    • +
  • [BUG 3421503] Random crashes could result when using hidden columns due to writing past the end of an array.
    +
    • +
+

What's New in TkTreeCtrl 2.4

Changes since 2.4b2:
+ +
    +
  • There were no changes since 2.4b2.
    • +
+Changes since 2.4b1:
+
    +
  • Fixed the header config option -text being treated like a per-state option.
    • +
  • Fixed rectangle and 3D border drawing on X11 due to 16-bit +coordinates.  When items or headers were very wide, rectangles and +borders wouldn't be drawn correctly.
    • +
  • Fixed dragging headers in locked columns not displaying correctly.
    • +
  • Fixed [identify] when right-locked headers were drawn over +left-locked headers, the point was reported as being in the left-locked +headers.
    • +
  • Fixed a library-script error when dragging headers when only locked columns were visible.
    • +
  • Fixed -canvaspady being ignored when only locked columns were visible.
    • +
  • Fixed the column-resize proxy line going past the right edge of a column when resizing right-locked columns.
    • +
  • Right-locked columns are always resized by their left edge +now.  Previously, only the leftmost and rightmost right-locked +columns were resized by their left edge, which was inconsistent and +weird.
    • +
  • If an instance element was displaying its master's -textvariable string, the instance element would not be redisplayed when that -textvariable variable was modified.
    • +
  • The spans of dragged headers are restricted to the range of +dragged columns, and the spans of non-dragged headers are terminated if +they reach the first dragged column.
    • +
  • Improved column-spanning behavior.  See "Column Spanning" below.
    • +
  • Fixed widget borders not being redrawn if an <Expose> event didn't also overlap the content area.
    • +
  • Fixed the -background and -borderwidth header options being ignored in the tail column.
    • +
  • Fixed a few memory leaks with the new column header code.
    +
    • + +
+

Header Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + +
New
+		Comment
header create
+ 		Creates a new row of column headers.  The result is a unique ID for that header-row.
+
header delete
+ 		Deletes one or more header-rows.  The top header-row, created when a treectrl is created, cannot be deleted.
+
header cget
+header configure
+ 		These commands work on both entire header-rows and individual columns within header-rows.  The column configure command may also be used to configure column headers in the top header-row.
+
header bbox
+header compare
+header count
+header element
+header id
+header image
+header span
+header state
+header style
+header text
+header tag
+ 		These commands have the same syntax as the item subcommands of the same name.
+Header-rows are actually implemented as items.
+
+The header image and header text +commands will change either the first image or text element in a custom +style assigned to a column header, or the -image and -text options of a +column header when no custom style is assigned.
+
+The header state command operates on header states, which are distinct from item states. See the updated section called STATES in the manual.
+
header dragcget
+header dragconfigure
+ 		Same as the column dragcget and column dragconfigure commands.
+
+The visual feedback when dragging column headers has changed.  As +a result, the following options are deprecated and have no effect:
+
    +
  • -imagecolor
    • +
  • -indicatorcolor
    • +
  • -indicatorside
    • +
+ +
+

Column Configuration Options
+

+ + + + + + + +
Option
+		Comment
+
+
-arrow direction
-arrowbitmap bitmap
-arrowgravity direction
-arrowimage image
-arrowpadx amount
-arrowpady amount
-arrowside side
-background color
-bitmap bitmap
-borderwidth size
-button boolean
-font fontName
-image image
-imagepadx amount
-imagepady amount
-justify justification
-state state
-text text
-textcolor color
-textlines count
-textpadx amount
-textpady amount
+
+ 		All +these options related to column headers are no longer a part of a +column itself.  Instead, these options were moved to the new +column header API.
+
+These options can still be accessed using column cget and column configure, but only for the top row of column headers.
+
+To access these options in header-rows other than the top row, use the header cget and header configure command.
+
+

Element Command

+ + + + + + + + + + + +
Arguments Changed
+		Comment
element create
+element cget
+ 		The new option -statedomain accepts a value of item or header.  The default value is item.  +This option is used to distinguish between elements used in items and +elements used in column headers, since items and headers have a +different +set of state flags.  The value of this option cannot  be changed.
+
+ + +

+ + + +

Item Command

+ + + + + + +
New
+		Comment
item state define
+item state linkage
+item state names
+item state undefine
+ + 		All the old subcommands of the widget state command are now in the updated item state +command.  This was done because items and headers have a different +set of states.  Defining new header states is done using the new header state command.
+
+

Style Command

+ + + + + + + + + + +
Arguments Changed
+		Comment
style create
+style cget
+ 		The new option -statedomain accepts a value of item or header.  The default value is item.  +This option is used to distinguish between styles used in items and +styles used in column headers, since items and headers have a different +set of state flags.  The value of this option cannot  be changed.
+
style layout
+ 		A new style layout option was added called -center.  The -center option allows one or more elements to be centered within a style.
+
+

+

TreeCtrl Command

+ + + + + + + + + + +
Arguments/Result Changed
+		Comment
bbox
+		Three new areas are defined, header.left, header.none, and header.right, +to get the bounds of the different groups of locked/unlocked column +headers.  The words after "header." are each possible value of the +column option -lock.
+
identify
+ 		To make the result of this +command easier to use, especially with the new column header code, a +new option was added that sets the elements of an array variable rather +than returning the result as a list.
+ 
.t identify -array id $x $y
+The above call will alter the array variable named "id" with info about what is under the given coordinates.
+
+

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + + + + +
NewComment
-headerfont
+ 		This +is the font used for drawing text in column headers.  The default +value is TkHeadingFont where that font is defined (usually on Tk 8.5+), +otherwise it is the default listbox font.  On Mac OS X, +TkHeadingFont is the small system font used for drawing text in the +fixed-height headers.
+ This new option results in a different default look to column text on X11, where TkHeadingFont is a bold font.
+
-headerfg
+-headerforeground
+ 		This is the foreground text +color used when drawing text in column headers.  On Gtk+, the +system theme may override this color.
+

Headers

+ + +The treectrl widget now supports multiple rows of column headers.  +In the documentation, an entire row of column headers is referred to as +a header-row.
+
    +
  • There is always one header-row with the unique ID "0".  It may +also be referred to using the header description "first". This top +header-row cannot be deleted.
    • +
  • Configuring column header options (such as -image and -text) in the top header-row can be done using column configure, the same as in previous versions. To configure column header options in specific header-rows, the header configure command must be used.
    +
    • +
  • Column spanning is supported using the header span command.
    • +
  • The appearance of column headers may be customized using styles. +When creating elements and styles for use in column headers, the +"-statedomain header" option must be used. +
    .t element create MyHeaderElement text -statedomain header
    .t style create MyHeaderStyle -statedomain header
    +
    • +
+

Element Changes

+
    +
  • There is a brand-new element type called header which displays a themed (or non-themed) column header background and sort arrow.
    +
    • +
  • To support the new column header code - which is implemented using +styles - bitmap, image, and text elements are offset by 1,1 pixels +when displayed in a column header that is in the "pressed" state.
    • + +
  • The default color of text elements in column headers is -headerforeground, not -foreground.
    • +
  • The default font of text elements in column headers is -headerfont, not -font.
    +
    • +
+

+Event Changes +

+
    +
  • The <ColumnDrag> and <Header> events have a new substitution character, %H, which is replaced by the unique ID of the header-row involved.
    • +
  • A new event, <ColumnDrag-indicator>, is generated whenever the place to drop a dragged column header is updated.
    • +
  • A new event, <Header-state>, is generated whenever the state of an individual column header is changed during mouse-pointer events.
    +
    • +
+

Column Spanning

Previously, a style spanning more than one +column would request all of its width in the first column of the span. +Now, a style distributes its width across all the visible columns in a +span, taking into account the -minwidth, -width, and -maxwidth column options.
+
+Also, when calculating the needed height of an item or header, spans +were ignored.  Only the width of the first column in a span was +considered when calculating the needed height of a style.  As a +result, an item might appear much taller than it needed when lines of +text were wrapping.
+

Demo Changes

+ +
    +
  • A new demo called "Headers" was added to demonstrate multiple rows +of column headers and customizing the appearance of column headers +using styles.
    • +
  • The "Column Spanning" demo was updated to take advantage of the new column-spanning algorithm.  Previously, the -width +option of each column needed to be set to the width of the "Span 1" +style, otherwise the columns would have been as wide as the widest +style in that column, and resizing columns caused gaps to appear +between styles.
    • +
  • The three "Gradients" demos were updated to take advantage of the new column-spanning algorithm.  Previously, the -width +of the text elements displaying long lines of descriptive text was set +to the total width of the columns.  If the text was allowed to +wrap, the height of the items would be wrong since spans were +ignored.  Now the text wraps nicely when columns are resized.
    +
    • + +

What's New in TkTreeCtrl 2.3.2

+

Bug Fixes

+
    +
  • Fixed a bug where elements could expand too much, due to not accounting for the padding of elements in a -union correctly.
    • +
  • Build fix: don't use GNU Make conditionals in the Makefile.  +Instead, parts of the name of the archive created by the 'dist-win' +target are calculated in configure.ac.
    +
    • +
  • Build fix: make sure $MATH_LIBS (including -lm on AIX) is added to the list of link libraries on Unix platforms.
    • +
  • Build fix: removed trailing commas from some enum declarations to make strict C89 compilers happy (i.e., AIX).
    • +
  • Build fix: the Mac OS X SDK prior to version 10.5 does not have CGFloat defined.
    • +
  • Build fix: the Microsoft Platform SDK does not include +<vsstyle.h>, unlike the Windows SDK, therefore that header file +is no longer used.
    +
    • +
+

What's New in TkTreeCtrl 2.3.1

+

Style Configuration Options

+ + + + + + +
NewComment
-buttony
+ 		This +option allows you to specify the distance from the top of an item that +the expand/collapse button is drawn.  When the value of this +option is unspecified, the button is centered vertically in the item.
+
+

Demo Changes

+
    +
  • The Style Editor now has 2 scale widgets to make testing the -expand and -squeeze layout options easier.
    • +
  • Rewrote the "Outlook Express (Folders)" demo to use a single item style instead of 4 different styles.
    +
    • + +
  • Fixed an off-by-1 error in the placement of the iMovie demo name-editing entry widget.
    • + +
+

Bug Fixes

+
    +
  • 64bit: Fixed pointer truncation leading to crashes when memory allocations exceeded 4GB.
    • +
  • 64bit: Lots of casting to quiet MSVC compiler warnings.
    • +
  • 64bit: Fixed shellicon debug build failure when using MSVC.
    +
    • +
  • Removed the use of <gdiplus.h> which broke MinGW-w64 builds and MinGW32 cross-compilation.
    • +
  • Fixed panic() when running the X11 debug build.
    • +
  • Use Tcl_PrintDouble() and Tcl_NewDoubleObj() instead of the %g +specifier to fix a bug reported on comp.lang.tcl where the floating +point numbers passed to the scrollbar command contained a comma (due to +a locale issue).
    +
    • +
  • Hit-testing of buttons now considers the vertical placement and +size of buttons. Previously, the [identify] command would report that +the given coordinates were over a button no matter how tall the item +was.
    • +
  • Mac OS X: Column header layout was broken, resulting in incorrect +justification of the header bitmap/image/text as well as the sort arrow +being drawn overtop the bitmap/image/text.
    • +
  • The needed width of all item styles in a column was not being recalculated when deleting items.
    • +
  • The needed width of column headers was not being recalculated when the -usetheme option changed.
    +
    • + +
  • Some commands, such as [item bbox], would return incorrect +results if called after a column was resized but before the next +display update.
    • +
  • The calculation of the minimum size needed by a style was broken +when -squeeze layout was used except for -squeeze=x -orient=horizontal.
    • +
  • The -itembackground colors were not being drawn when a transparent -backgroundimage was used.
    • +
+ +
+

What's New in TkTreeCtrl 2.3

+ +Changes since 2.3b1 +
    +
  • Removed the gradient api command.
    • +
  • New option -enabled may be passed to the item create command.
    +
    • +
  • The Escape key cancels any drag-and-drop in progress with the TreeCtrlFileList bindings.
    • +
  • With -selectmode=single the marquee is not used with the TreeCtrlFileList bindings.
    • +
  • Fixed the <Escape> key causing an error when the last visible item was selected.
    • +
  • Updated the documentation to include -gridleftcolor and -gridrightcolor.
    • +
  • Added a section to the documentation titled THE CANVAS and linked to that section wherever the canvas is mentioned.
    +
    • +
+

Column Configuration Options

+ + + + + + + + + + + + + + + + + +
New
+		Comment
-gridleftcolor
+-gridrightcolor
+ 		So-called "grid lines". These +two options specify a color or gradient to draw on the left and/or +right edge of the column.  The lines are drawn overtop an item's +style and down in the whitespace region below any items.
+
Usage Changed
+		How it changed
+
-itembackground
+ 		Item background colors can be a Tk color or a gradient name.
+
+Item background colors are now +drawn below items in the whitespace region even when item wrapping is +being used.  Previously item background colors were not drawn +below items when wrapping was used.
+
-textcolor
+ 		This is now a per-state option, just like the -background option, which may be incompatible.  +If you previously specified a Tk color name with a space in it, such as +"light blue", then you will need to make the value a proper list:
+ 
$T column configure $C -textcolor [list "light blue"]
+When this option is unspecified (the default), the system theme can +specify the color.  Currently that behavior is only used with the +Gtk+ build of treectrl.
+
+

Item Command

+ + + + + + + + + + + + + + + + + +
New
+		Comment
buttonstate
+ 		The value of this option can be active, normal or pressed.  +This is used to change the appearance of the expand/collapse +buttons.  On Gtk+ the buttons change appearance when the mouse +pointer is over them and when they are clicked.  On Mac OS X the +buttons change appearance when they are clicked.  On MS Windows +the buttons change appearance when the mouse pointer is over them, but +only when the Explorer theme is used (see the new theme setwindowtheme command).
+
Arguments Changed
+		What changed
+
create
+ 		New option -enabled.
+
collapse
+expand
+toggle
+ 		A new option -animate +was added to support animated disclosure triangles on Gtk+ and Mac OS +X.  The library scripts pass the -animate option when clicking on +a button, but not when toggling items using the keyboard.
+
+

Marquee Configuration Options

+ + + + + + + + + + +
NewComment
-fill
+ 		Specifies the fill color for the +selection rectangle.  The value can be a Tk color or a gradient +name or an empty string (the default).  When this option isn't an +empty string the dotted outline is not drawn.  By specifying the +name of a semi-transparent gradient a modern-looking selection +rectangle can be achieved.
+
-outline
+ 		Specifies the outline color for +the selection rectangle.  The value can be a Tk color, a gradient name, or an empty +string which is the default.  When this option isn't an empty +string the dotted outline is not drawn.
+
+

Style Layout Options

+ + + + + + +
Behavior Changed
+		What changed
+
-union
+ 		Previously, nesting -union elements had undefined behavior.  Now it is ok to include an element with -union layout in another element's -union list.
+
+

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NewComment
-bgimage
+ 		This is a synonym for the -backgroundimage option.
+
-bgimageanchorControls +the alignment of the -backgroundimage.  The value is a standard Tk +anchor position such as "nw", "se" or "center", etc.  The image is +aligned to the content area when the image doesn't scroll, otherwise +the image is aligned to the canvas.  The default is "nw".
+
-bgimageopaque
+ 		A boolean that indicates whether +or not the -backgroundimage is partially transparent.  This is +needed because there is no way to tell in Tk whether an image contains +transparency.  The default is true, so if you use a transparent +-backgroundimage you must set this to false.
+
-bgimagescroll
+ 		Controls whether the +-backgroundimage scrolls along with the items or remains locked in +place.  The value can be an emptry string for no scrolling, "x" +for horizontal scrolling only, "y" for vertical scrolling only, or "xy" +(the default) for scrolling in both directions.
+
-bgimagetile
+ 		Controls whether the +-backgroundimage is tiled along the x and y axes.  The value can +be "", "x", "y" or "xy" (the default).
+
-buttontracking
+ 		On Mac OS X and Gtk+ the +expand/collapse buttons don't toggle when they are clicked, only when +the mouse button is released over them, like regular pushbuttons.  +The value of this option is a boolean; when true the buttons toggle +when the mouse button is released, when false the buttons toggle when +clicked.  The default is true on Mac OS X and Gtk+, false on Win32 and X11.
+
-canvaspadx
+-canvaspady
+ 		These options allow whitespace +margins around the edges of the canvas.  This is useful for 2D +views where you don't want the items to butt against the window +borders.  The value of each option is a list of one or two screen +distances specifying the width of the left/right margins and the height +of the top/bottom margins respectively.
+
-itemgapx
+-itemgapy
+ 		These options allow whitespace gaps between adjacent items.  +This is useful for 2D views such as an icon view in a file browser or +an image thumbnail list.  The value of each option is a screen +distance defaulting to zero.
+
-xscrollsmoothing
+-yscrollsmoothing
+ 		When these options are set to +true and the xview or yview commands are called to scroll by "units", +scrolling occurs according to the -xscrollincrement or +-yscrollincrement options, and all other scrolling is done as if the +-xscrollincrement or -yscrollincrement options were set to 1.  The +effect is that when dragging the scrollbar thumb scrolling is very +smooth, but when clicking the scrollbar buttons scrolling is done in +coarser increments.
+
Usage +ChangedHow +it changed
-columnresizemode
+ 		The default value is "realtime", it used to be "proxy".
+
-showlines
+ 		The default value is false on Mac OS X and Gtk+, true on Win32 and X11.
+
-usetheme
+ 		The default value is now true.  Complete reversal from previous versions, head for the hills.
+
+

TreeCtrl Command

+ + + + + + + + + + + + + + + + + + + + + + + + + +
NewComment
gradientLinear +gradients!  There are a number of issues when using gradients, see +the demos and the relevant sections in the manual page for more info.
+
theme
+ 		The theme platform command returns the API used to draw themed parts of the treectrl.
+
    +
  • On Mac OS X the result +is always aqua.
    • +
  • On MS Windows the result is visualstyles if the +uxtheme.dll was loaded and visual themes are in use, otherwise X11 is +returned to indicate the Tk Xlib calls are drawing the themed parts.
    • +
  • On Unix systems the result is gtk if the Gtk+ version of treectrl +was built, otherwise X11 is returned.
    • +
+ MS Windows only: The theme setwindowtheme command takes the name of an application whose theme should be used.  If you call...
+ + 
$T theme setwindowtheme "Explorer"
+
+ ...on Windows 7 the disclosure triangles of the Explorer file browser will be used rather than +/- buttons.
+
+

Gtk+ Theme

+
    +
  • Pass --enable-gtk=yes to +configure to build a Gtk+ version of treectrl.  This requires +proper pkg-config setup for the gtk+-2.0 and gdk-pixbuf-xlib-2.0 +libraries.
    • +
  • Leave the column option -textcolor={} so the theme colors will be used for column header labels.
    +
    • +
  • Leave the new widget option -buttontracking=yes for native behavior when clicking buttons.
    +
    • +
  • BUG: Currently the theme does not change when the system theme changes.
    +
    • +
+

Rect Element

+
    +
  • Rounded rectangles can be drawn using the new rect element configuration options -rx and -ry.  +These options specify the radius of the corners as screen +distances.  The values are restricted to a maximum of half the +width or height of the rectangle when being displayed.
    • +
  • The -open option is now +per-state.  See the "Outlook Express (Newsgroup)" demo where the +active outline of the selection rectangle appears to span across +columns.  In previous versions that required 3 different styles.
    • +
  • The -fill and -outline options can be a Tk color or a gradient.
    +
    • + +
+

Library Scripts

+
    +
  • The treectrl window gets the focus after a <ButtonPress-2> event begins scan-dragging.
    • +
  • The Escape key cancels any drag-and-drop in progress with the TreeCtrlFileList bindings.
    • +
  • With -selectmode=single the marquee is not used with the TreeCtrlFileList bindings.
    +
    • + + + +
  • Added some hackery to the TreeCtrlFileList bindings for emulating the complicated selection behavior of Windows 7 Explorer:
    +
      +
    • Added TreeCtrl::FileListEmulateWin7 to indicate the Windows 7 behavior should be used.
      • +
    • Added TreeCtrl::SetSensitiveMarquee, just like +TreeCtrl::SetSensitive but indicates which elements respond to the +selection rectangle. Typically this is the same as the elements passed +toTreeCtrl::SetSensitive with the addition of the selection rectangle elements.
      • +
    +
    • + +
+

Build Changes

+ +
    +
  • Added macosx/ unix/ and win/ subdirectories with platform-specific code in each.
    +
    • +
  • The --enable-cocoa +configure option was removed when building on Mac OS X.  Instead +the configure script determines whether Tk was built using the Cocoa +API by examining the TK_LIBS variable.
    • +
  • Cross-compiling on a Unix host using the MingW toolchain should +work out-of-the-box now.  If the --host configure option contains +"mingw32" then TEA_PLATFORM is set to "windows".
    • +
  • The 'make clean' target does a better job cleaning what it +should.  It doesn't remove the .manifest file generated by +configure (make distclean does that), only the linker-generated +.manifest when building with MSVC is removed.  Resource file +objects are cleaned as well.
    • +
  • Various tweaks were made to allow building using the Visual Studio 2008 compiler.
    +
    • +
  • Updated to TEA 3.9.
    • +
+

Shellicon Package

+
    +
  • The shellicon package is used to display native file and folder icons on MS Windows.  It was updated with a new option -useselected.  The value of -useselected may be always, auto or never to control whether the selected version of an icon should be drawn.  The default is auto meaning draw the selected icon if the item is selected.
    • +
+

Demo Changes

+
    +
  • Added "Explorer (Details, Win7)" and "Explorer (Large Icons, +Win7)" demos which very closely match the appearance and behavior of +the Windows 7 file explorer.  These demos use gradients, rounded +rectangles and the new -canvaspadx, -canvaspady, -itemgapx and +-itemgapy options.
    • +
  • New demos "Gradients", "Gradients II" and "Gradients II" demonstrate and describe various gradient features.
    +
    • +
  • The "Column Spanning" demo uses gradients.
    • +
  • The ::tk::mac::iconBitmap is used where available for native filesystem icons on Mac OS X.
    +
    • +
  • Fixed a bug with increasing/decreasing the font size if the font size was negative (i.e. on X11).
    • +
  • New options were added to the context menu: -bgimageanchor, +-bgimageopaque, -bgimagescroll, -bgimagetile, -buttontracking, +-xscrollsmoothing and -yscrollsmoothing.
    +
    • + +
+

Bug Fixes

+
    +
  • Fixed non-themed expand/collapse buttons being one pixel too large on Mac OS X.
    • +
  • Fixed dotted line and dotted rectangle drawing on Mac OS X.
    • +
  • Fixed the column option -arrowpady being broken for -arrowimage, -arrowbitmap and when themed arrows were drawn. It only worked when the X11 fallback was used.
    • +
  • Fix +"Bug 3104147 - Error after widget was destroyed".  Various [after] +callbacks did not check that the treectrl still existed.
    • +
  • Fix +"Bug 3104148 - column "202" doesn't exist".  Check that the +previously-highlighted column exists before configuring its state in +MotionInHeader.
    • +
  • Fixed <Left> and <Right> arrow keys not moving to adjacent items when some items had -wrap=true.
    • +
  • Fixed error with autoscanning when the content area was completely obscurred by locked columns.
    • +
  • Fixed the ordering of some entries in the treectrl option table.
    • +
  • Fixed the <Escape> key causing an error when the last visible item was selected.
    +
    • + +
+ + + +
+

What's New in TkTreeCtrl 2.2.10

+ + +

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
IgnoredComment
-doublebufferThis option no longer has any effect but was left in to +avoid incompatibilities. + Instead, the amount of double-buffering is chosen depending +on +the platform.  Modern platforms such as Mac OS X double-buffer +each toplevel whereas older platforms such as Windows XP do not.
+ +

Text Element Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NewComment
-lmargin1Specifies how much the first line of text should be +indented.
+ +
-lmargin2Specifies how much the 2nd or greater lines should be +indented when a line of text wraps.
+ +

Mac OS X support for Tk 8.6

+ +Tk 8.6 dropped support for the Carbon API in favor of the modern Cocoa +API on Mac OS X. TkTreeCtrl was updated to build using either Carbon +(Tk 8.4/8.5) or Cocoa (Tk 8.6). If you are using the back-port of the +Cocoa version with Tk 8.5 you can pass the --enable-cocoa=yes +configure option when configuring TkTreeCtrl.
+ +

Build Changes

+ +
    + +
  • Updated to TEA version 3.7 which supports +the MODULE_SCOPE +macro.  As a result, private symbols are not exported by the +treectrl shared library on platforms that support it (i.e., gcc's __visibility__("hidden")).
    • + +
+ +

Bug Fixes

+ +
    + +
  • Fixed a crash during error processing in [item +create] due to missing return statements for the -count and -height +options.
    • + +
  • Fixed a bug where all item styles would be lost when +deleting the +3rd or greater column. This bug affected any item that never had a +column record allocated for the 3rd or greater column (usually because +no style had been assigned).
    • + +
  • Fixed a crash in the [item span] command when specifying +"all" for the item description.
    • + +
  • The pkgIndex.tcl file correctly handles installation +directories with space or bracket characters.
    • + +
  • Removed C++ style comments and a spurious semicolon for C89 +AIX compliance. [BUG 2886595]
    + +
    • + +
  • Fixed [item sort -decreasing] not being a "stable" sort. +[BUG ID 2909930]
    • +
  • Fixed flickering of the dragimage under Windows 7; this requires more doublebuffering than WinXP even with Aero.
    • +
  • Use more double-buffering on the dragimage to fix flickering/slowness (tested on Ubuntu VM).
    +
    • +
  • Fixed drawing of column/row proxy lines where XOR isn't supported (i.e. MacOSX Cocoa).
    • +
  • Fixed the loupe (screen capture) command under Windows 7; tested on Win7 x64 (with and without Aero) and on WinXP x32.
    • +
  • Fixed an X server error caused by adding a bad rectangle to an +XRegion while processing <Expose> events.  This would show +up with -doublebuffer=window while resizing the window. [BUG 3015429]
    +
    • + + + +
+ +

Demo Changes

+ +
    + +
  • The "Layout" demo uses the new Text element option +-lmargin2.
    • +
  • Fixed an undefined-variable error when double-clicking between column headers on X11 in the "Random" demo.
    • +
  • Fixed the resizing of items containing child windows when the +Tile theme changes in the "Big List" demo.  Also added some +comments.
    • +
  • Disabled the dynamic-appearing scrollbars under X11 where I saw some infinite looping.
    +
    • + + +
+ +
+

What's New in TkTreeCtrl 2.2.9

+ +

TreeCtrl Command

+ + + + + + + + + + + + + + + + + + + + + + +
Arguments/Result +ChangedWhat +changed
seeOLD: $T see $item
+ +NEW: $T see $item ?$column? ?-center xy?
+ +You can specify a particular column to scroll into view horizontally.
+ +The -center option will center the item/column in the window instead of +performing the minimal amount of scrolling to bring it into view at the +edge of the window.
+ +
+ +

Item Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
-wrapWhen this option is true an item will be the first in a +horizontal (when the treectrl option -orient=horizontal) +or a vertical (when the treectrl option -orient=vertical) +range of items.  See the new "iMovie (Wrap)" demo.
+ +
+ +

Bug Fixes

+ +
    + +
  • Fixed a compile error on SunOS due to DUMP_ALLOC being +defined in the system headers.
    • + +
  • Fixed a bug that caused a panic in B_IncrementFind when +calling +the [see] command before the widget had displayed itself for the first +time.
    • + +
  • Fixed a library script error when attempting to drag a +column header when the window was so small the items weren't visible.
    • + +
  • Fixed two cases where the whitespace would not be properly +erased when items being deleted caused scrolling.
    • + +
  • Fixed column headers being drawn overtop of the bottom edge +of window borders if the window was very short.
    • + +
+ +

Demo Changes

+ +
    + +
  • Added the "iMovie (Wrap)" demo to demonstrate the new item +option -wrap.
    • + +
+ +
+

What's New in TkTreeCtrl 2.2.8

+ +

Bug Fixes

+ +
    + +
  • Fixed a bug that caused a panic in Range_ItemUnderPoint. +Thanks to SF.net user 'nobody' who found the problem.
    • + +
  • Fixed reading an uninitialized variable when calculating +column header layout.
    • + +
+ +
+

What's New in TkTreeCtrl 2.2.7

+ +

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
-showrootchildbuttonsSimilar to -showrootlines, +this boolean option controls the display of expand/collapse buttons +next to child items of the root item.
+ +
+ +

Indentation change/fix

+ +
Previously with -showroot=0, -showbuttons=0, and -showrootlines=0 +there was still an extra level of indentation displayed to the left of +the root's children. The only way to remove all indentation +from the +root's children was to set -showlines=0 +as well.  This is no longer the case and now behaves +as expected. With the new -showrootchildbuttons +option it is now possible to remove all indentation from the root's +children without affecting the display of buttons/lines on deeper items.
+ +

Library Script Changes

+ +

treectrl.tcl:

+ +
    + +
  • The <Left> and <Right> key +bindings will collapse and expand the active item if -orient=vertical and + -wrap={}. + Otherwise the previous behavior of setting the active item to +an adjacent item is used.
    • + +
+ +

Bug Fixes

+ +
    + +
  • Fixed corruption/crash with ".t column configure -foo" with +no option value if -foo is an invalid option.
    • + +
+ +
+

What's New in TkTreeCtrl 2.2.6

+ +

Bug Fixes

+ +
    + +
  • Fixed ".t item bbox" returning bogus values when asking for +the +bounds of a column or element in a list with many items (integer +overflow).
    • + +
  • Fixed a segfault on Win64 machines when the system theme +changed.
    • + +
  • Fixed a panic on Win64 when drawing the the marquee and +drag-image dotted rectangles due to a too-small struct.
    • + +
+ +
+

What's New in TkTreeCtrl 2.2.5

+ +

+Issues regarding the incompatibility of 8.4 built TkTreeCtrl working in +8.5 +were resolved. The Mac OS X API issues noted for 2.2.4 remain (they +relate to difficult to reconcile core drawing changes). +

+ +

+A Windows DLL manifest is now embedded to address native theme drawing +issues. +

+ +
+

What's New in TkTreeCtrl 2.2.4

+ +

NOTE regarding Tk version compatibility

+ +

+Under Mac OSX some internal changes to Tk 8.4.15 and Tk 8.4.17 result +in +incompatibilities: +

+ +
    + +
  • This version of TkTreeCtrl built for Tk 8.4.15 will work +with Tk 8.4.15 and 8.4.16 only + (under Mac OSX).
    • + +
  • This version of TkTreeCtrl built for Tk 8.4.17 will work +with Tk 8.4.17 only (under Mac OSX).
    • + +
+ +

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
-columntagexpr
+ +-itemtagexpr		These boolean options can be used to turn off tag +expressions in column descriptions and item descriptions. + When the value of these options is false the +characters (', ')', '&', '|', '^' +and '!' have no special significance when using tags in column/item +descriptions. This is useful for applications which may have +arbitrary tags applied to columns or items.
+ +

Bug Fixes

+ +
    + +
  • Fixed partially-exposed transparent photo images not being +redrawn when scrolling under X11.
    • + +
  • Fixed potential crash with Windows theme if the system +theme was changed.
    • + +
  • Fixed ".t +item cget -button" always returning 0 when the value of +this option wasn't auto.
    • + +
  • Fixed a drawing issue under Mac OSX where parts of the +window would not be erased properly under Tk 8.4.15+ and Tk 8.5a7+.
    • + +
  • Fixed crashes under Mac OSX with Tk 8.4.17 and Tk 8.5.0.
    • + +
  • Fixed an old bug caused by a MSVC compiler optimization bug +that +stopped items being redrawn when the only change in appearance was the +expand/collapse button needing to be redrawn.
    • + +
+ +

Misc Changes

+ +
    + +
  • Changed the item +sort code to be a "stable" sort. This means that the +pre-sort order of two equal items is used as a tie-breaker.
    • + +
+ +

Demo Changes

+ +
    + +
  • Added "Increase Font Size" and "Decrease Font Size" menu +commands.  Also the Console font is not changed when running +under Tk 8.5.
    • + +
+ +
+

What's New in TkTreeCtrl 2.2.3

+ +

Build Changes

+ +
    + +
  • When building with configure on Windows the +--enable-shellicon option will run configure in the shellicon/ +subdirectory.
    • + +
  • 'make dist' will create the source distribution +tktreectrl-VERSION.tar.gz.
    • + +
  • 'make dist-win' will create the Windows binary distribution +tktreectrl-VERSION-win32.zip.
    • + +
+ +

Bug Fixes

+ +
    + +
  • Fixed flickering when redrawing the borders with +"-doublebuffer window" when the widget was resized or parts of it were +exposed.
    • + +
  • Fixed undefined reference to vsnprintf when +building with the MS compiler under Windows; it should be _vsnprintf.
    • + +
  • Fixed a symbol conflict with Python 2.5 on ELF-based +systems which also defines a symbol "Ellipsis".
    • + +
+ +
+

What's New in TkTreeCtrl 2.2.2

+ +

Column Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
-itemjustifyThis option allows item styles to be justified +separately +from the image/text in the column header. If the value of this +option is unspecified (the default), then item styles are justified +according to the -justify +option of the column.
+ +

Item Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
Usage +ChangedHow +it changed
-buttonThe value of this option can now be the word auto (or any +abbreviation) in which case a button is drawn only when the item has at +least one child item with its item option -visible set to true.
+ +

Style Layout Changes

+ +
    + +
  • The element option -draw +of every element type is now deprecated. Use the new style layout +option -draw +instead.
    • + +
  • The new per-state style layout option -visible +controls the visibility of an element. When the value of this option +evaluates to false for a given state, the element consumes no space in +the layout and is not displayed. If none of the elements surrounded by +an element with -union +layout are visible, then the element with -union layout is not +displayed.
    • + +
+ +

Item Descriptions

+ +
    + +
  • The index argument to the child and sibling modifiers +can now take the form "end?-integer?".
    • + +
+ +
+
.t item id "root child end-1" ; # get the second-to-last child of the root item
+ +
+ +

Bug Fixes

+ +
    + +
  • Text elements were requesting some height from the style +layout +when displaying an empty string. If you were depending on this +behaviour, it is suggested that you set the height of the text element +using the -minheight +or -height +style layout options.
    • + +
  • Window elements might not be scrolled along with the rest +of the +list if the area needing to be redrawn due to scrolling was obscurred +by other windows. This could only happen on Win32.
    • + +
  • The ellipsis "..." in text elements is now always displayed +if +the text element has less space than is needed to display its string. +Previously the ellipsis would disappear when there wasn't room for a +single character plus the ellipsis.
    • + +
  • Fixed a layout bug with multi-line text elements when the +unsqueezed element did not require a multi-line layout but the squeezed +element did.
    • + +
+ +
+

What's New in TkTreeCtrl 2.2.1

+ +

Bug Fixes

+ +
    + +
  • Fixed panic with -xscrollincrement=0, -showheader=yes, no +visible items and headers wider than the window.
    • + +
  • Fixed the wrong loop variable being used when calculating +onscreen columns for an item which resulted in a random crash.
    • + +
  • Fixed a crash when invalidating a column of an item if the +column wasn't the first in a span.
    • + +
  • Fixed a leak on X11 where the clipping region was not being +freed after drawing dotted rectangles.
    • + +
+ +
+

What's New in TkTreeCtrl 2.2

+ +

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
DeprecatedWhat +to use +instead
-defaultstyleThe -itemstyle option of a column.
+ +

TreeCtrl Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Arguments/Result +ChangedWhat +changed
contentboxThe return value is an empty string if the +content area is totally obscurred by column headers, borders, and/or +locked columns. Typically this will only happen if the window is too +small.
selection getAccepts 2 optional arguments to allow in-place lindex and lrange queries of +the selection. For example:
+ + 
.t selection get 0       ; # the first selected item
.t selection get end     ; # the last selected item
.t selection get 1 end-1 ; # every selected item except the first and last
+ +
NewComment
bboxReturns the bounding box of different areas of the +window. For example:
+ + 
.t bbox
+ +will return the bounds of the window, and:
+ + 
.t bbox header
+ +will return the bounds of the column headers, and:
+ + 
.t bbox content
+ +will return the same result as the [contentbox] command, and:
+ + 
.t bbox left
.t bbox right
+ +will return the bounds of the left-locked and right-locked columns.
+ +

Column Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Renamed
+ + 		New +name
-tag-tags
NewComment
-lockThis option allows columns to stick to the left or +right edge +of the window. Locked columns can scroll vertically but not +horizontally. Valid values for this option are none (the default), left or right.
-itemstyleSpecifies the name of a style to set in this column for +newly-created items. This option replaces the treectrl option +-defaultstyle.
-uniformThese two options +operate the same as the grid geometry manager options of the same name. +For example:
+ + 
.t column configure 0 -uniform a
.t column configure 1 -uniform a
+ +will give columns 0 and 1 the same requested width, whichever is the +larger of the two columns. And:
+ + 
.t column configure 0 -uniform a -weight 2
.t column configure 1 -uniform a
+ +will give column 0 twice the maximum of the requested widths of columns +0 and 1. And:
+ + 
.t column configure 0 -expand yes -weight 2
.t column configure 1 -expand yes
+ +will give column 0 twice the extra space as column 1.
-weight
+ +

Column Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Arguments/Result +ChangedWhat +changed
column countTakes an optional column-description argument; the +result is +the number of columns that match the column description. For example:
+ + 
.t column count visible
+ +will return the number of columns whose -visible option is true, and:
+ + 
.t column count {tag a^b}
+ +will return the number of columns with either tag "a" or "b", but not +both.
NewComment
column tag addColumns can have +a list of tag names. Previously only a single tag was allowed. The tail column no +longer has the word "tail" as a tag, but it is still referred to by the +word "tail" in column descriptions.
column tag expr
column tag names
column tag remove
+ +

Item Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
-tagsTags are textual labels applied to items to group them. +Tags +do not affect the appearance or behaviour of items. Tags can be used in +item descriptions to operate on multiple items. More information can be +found in the man page.
+ +

Item Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Arguments/Result +ChangedWhat +changed
item countTakes an optional item-description argument; the result +is the number of items that match the item description. For example:
+ + 
.t item count visible
+ +will return the number of items that are displayed (i.e., those +whose ancestors are all expanded, -visible options are true, etc), and:
+ + 
.t item count {tag a^b}
+ +will return the number of items with either tag "a" or "b", but not +both.
item createNew option -tags +specifies an initial list of tags for created items.
item idReturns a list of item ids if the item description +matches multiple items. For example:
+ + 
.t item id all
+ +will return a list of ids for all items, and:
+ + 
.t item id "$item children"
+ +will return the ids of every child of an item.
NewComment
item descendantsReturns the ids of the children, grandchildren, etc of +an item.
item enabledGets and sets the enabled +state for items. All items are enabled when first created. Disabled +items cannot be selected, and are ignored by the default key-navigation +and mouse bindings.
item tag addAdd tags to items. For example:
+ + 
.t item tag add all {a b c}
+ +will add tags "a", "b" and "c" to every item.
+ +
item tag exprEvaluate a tag expression against items. For example:
+ + 
.t item tag expr $item a
+ +returns 1 if an item has tag "a". Also:
+ + 
.t item tag expr $item a||b
+ +returns 1 if  an item has tag "a" or "b".
item tag namesReturn a list of tag names assigned to items. For +example:
+ + 
.t item tag names $item
+ +returns the tag list for an item, and:
+ + 
.t item tag names all
+ +returns every tag assigned to any item.
item tag removeRemove tags from items. For example:
+ + 
.t item tag remove all {b c}
+ +will remove tags "b" and "c" from any items that have them.
+ +

Text Element

+ +The new option -underline +draws an underline under a single character of the displayed text.
+ +

Window Element

+ +Window elements can now be properly clipped so they don't draw over the +column header, borders, or outside the bounds of the item +columns they occupy. This is accomplished by making the window you want +to display a child of a borderless frame widget, and setting the new -clip option of the +window element to TRUE. So if your program displays a canvas widget in +a window element, you would change this code:
+ +
set canvas [canvas .t.canvas ...]
.t item element configure $item $column myElement -window $canvas
+ +to this:
+ +
set frame [frame .t.clip -borderwidth 0]
set canvas [canvas $frame.canvas ...]
.t item element configure $item $column myElement -window $frame -clip yes
+ +The -clip +option tells the window element to manage the geometry of both the -window +widget (i.e, +the frame) and its first child widget (i.e., the canvas). In this case, +the frame widget is kept sized and positioned so that it is never +out-of-bounds. You can see this in the "Big List" and "Firefox Privacy" +demos. +

Item Descriptions

+ +New keywords were added to allow multiple items to be specified by an item description:
+ +
    + +
  • The keyword list +specifies a list of other item descriptions: + 
    .t item id "list [list $a $b $c]"
    + +
    • + +
  • The keyword range +operates like the item +range command: + 
    .t item id "range $first $last"
    + +
    • + +
+ +New modifiers were added to match multiple items: +
    + +
  • The modifier ancestors +operates like the item +ancestors command: + 
    .t item id "$item ancestors"
    + +
    • + +
  • The modifier children +operates like the item +children command: + 
    .t item id "$item children"
    + +
    • + +
  • The modifier descendants +operates like the item +descendants command: + 
    .t item id "$item descendants"
    + +
    • + +
+ +New qualifiers were added to refine which items are matched:
+ +
    + +
  • The qualifier depth +matches items at a given depth in the heirarchy:
    • + +
+ +
+
.t item id "all depth 2" ; # find all items that are children of the root's children
.t item id "depth 2" ; # ditto
+ +
+ +
    + +
  • The qualifier !visible +matches items that are not displayed: + 
    .t item id "first !visible" ; # find the first item that is not displayed
    + +
    • + +
  • The qualifier state +matches items that have certain states set (or not set if '!' is used): + 
    .t item id "first state {selected !open}" ; # find the first item that is selected and collapsed
    + +
    • + +
  • The qualifier tag +matches items that meet a tag expression: + 
    .t item id "$item children tag {a && !b}" ; # find children of $item that have tag "a" but not tag "b"
    + +
    • + +
+ +
+ +The keyword all +may now be followed by a list of qualifiers. For example:
+ +
.t item id "all !visible state myState" ; # find every item that is not displayed with user-defined state "myState"
+ +A list of qualifiers may be used as the first part of an item +description. This gives the same result as  "all" followed by +the +qualifiers. For example:
+ +
+
.t item id "!visible state myState" ; # same as the previous example
+ +
+ +

Column Descriptions

+ +New keywords list +and +range can be used to +match multiple columns.
+ +New qualifiers state, +tag, !tail and !visible can be used +to restrict which columns are specified.
+ +The keyword all +may be followed by a list of qualifiers.
+ +A list of qualifiers may used as the first part of a column +description. This gives the same result as  "all" followed by +the +qualifiers. +

Multi-item and multi-column commands

+ +Many commands can now operate on multiple items and/or columns by using +the improved item descriptions and column descriptions mentioned above. +For example: +
+
.t column configure "range 1 10" -tags {a b c}
.t column delete "tag a"
.t column id "tag {a || b}"
.t item configure "depth 1" -button yes
.t item count visible
.t item element configure "root children" all elem1 -text "Hello"
.t item id "visible"
.t item image all all image1
.t item style map "tag {a && !b}" "tag c" style2 {style1.elem1 style2.elem2}
.t item style set all all style1
.t item state forcolumn all all state1
.t item state set "tag current" ~mouseover
.t item remove "state selected"
.t item span "range 1 10" "range 10 last" 2
.t item text "root children" all "Hello"
+ +
+ +

Demo Changes

+ +
    + +
  • New demo "My Computer". Demonstrates disabled items used as +headers.
    • + +
  • New demo "Column Locking". Demonstrates columns that do not +scroll horizontally.
    • + +
  • The "Big List" and "Firefox Privacy" demos were changed to +use the new -clip +option of window elements.
    • + +
+ +

Misc Changes

+ +
    + +
  • The tail column header will not be drawn if the tail +column's -visible +option is false. This can look nicer with some themes.
    • + +
  • The -itembackground +colors for a column are now extended below any items in the simplest +(and most typical) case where the treectrl's -orient option is +vertical and -wrap +option is unspecified. The height of the rows is determined by the -itemheight or -minitemheight +options; if neither of those options is specified, then -itembackground +colors are not drawn below the items.
    • + +
  • If -itembackground +colors are specified for the tail column, then they are drawn.
    • + +
  • Memory usage is improved, especially for text elements.
    • + +
+ +

Bug Fixes

+ +
    + +
  • item create: +Fixed bug where -nextsibling +and -prevsibling +options could specify an orphan item.
    • + +
  • item delete: +Stopped items possibly being double-deleted by nested calls through <Selection> +and <ItemDelete> +binding scripts.
    • + +
  • item expand, item collapse, item toggle: Only +operate on items which exist when the command is called, not any that +might get created by <Expand> +or <Collapse> +binding scripts.
    • + +
  • Fixed a crash and a redisplay problem when a master element +was +configured with a -textvariable and the associated variable changed.
    • + +
  • When a style with window elements spanned more than one +column, the window might be improperly sized during display updates.
    • + +
  • Windows in window elements would not always be unmapped if +columns or items were hidden, or if the span of an item-column changed.
    • + +
  • The disclosure triangles (i.e., the item buttons) are drawn +without a white background under OSX.
    • + +
+ +
+

What's New in TkTreeCtrl 2.1.1

+ +

Column Command

+ + + + + + + + + + + + + + + + + + + + + + +
Arguments/Result +ChangedWhat +changed
column delete
+ + 		Added an optional second argument allowing a range of +columns to be deleted.
+ +

Bug Fixes

+ +
    + +
  • The item sort +command +will be much faster in many cases. There was a silly error in the +pivot-finding code of quicksort which resulted in the slow-down.
    • + +
  • A column header will be redisplayed if an image in +the header is altered.
    • + +
  • Fixed bus errors on some Unix systems due to alignment +problems.
    • + +
+ +

Other Changes

+ +
    + +
  • The Tk caret is now positioned over the active item when it +changes. The Tk caret is used for the Magnifier accessibility +application and IME on Windows, as well as XIM under Unix.
    • + +
  • Improved the appearance of the column headers under OSX.
    • + +
  • Added <MouseWheel> support to OSX.
    • + +
  • Changing the -visible option of an item could be slow if +any +items were selected. That is because non-visible items may not be part +of the selection. A change was made so that changes to the selection +caused by modifying the -visible option of an item do not occur until +the next display update.
    • + +
+ +

Demo Changes

+ +
    + +
  • New demo "Column Spanning". Demonstrates a 100-column list +where styles span from 1 to 20 columns each.
    • + +
  • The loupe +command (which performs screen capture to an image) is now implemented +on Windows and OSX thanks to Jeff Hobbs.
    • + +
  • The screen-magnifier image now resizes with the "loupe" +window.
    • + +
+ +
+

What's New in TkTreeCtrl 2.1

+ +This version should be backwards compatible with 2.0, except for a few +obscure changes.
+ +

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NewComment
-itemwidth
+ +
-itemwidthequalDeprecates the column -widthhack option.
-itemwidthmultipleDeprecates the column -stepwidth option.
+ +

Column Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
DeprecatedWhat +to use +instead
-stepwidthtreectrl's -itemwidthmultiple option
-widthhacktreectrl's -itemwidthequal option
+ +

Element Command

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
element perstateLike [item element perstate].
+ +

Item Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
-heightOverrides the treectrl's -itemheight option
+ +

Item Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
DeprecatedWhat +to use +instead
item element actualitem element perstate
item complexitem element configure
Behaviour +ChangedWhat +changed
item bboxNo longer returns an error if no style had been +assigned to the column.
item state forcolumnNo longer returns an error if no style had been +assigned to the column.
item style setDoes nothing when replacing a style with the same +style. +Previously the old style was freed before assigning the new style, +losing the element config info if the old and new styles were the same.
+ + Potential +incompatibility
Arguments/Result +ChangedWhat +changed
item createAdded options: -count -height, -nextsibling, -open, +-parent, +-prevsibling, and -returnid. Multiple items may be created with one +call using the -count option.
item element configureMultiple elements in multiple columns may be configured +with +a single call. Use '+' to separate elements, and ',' to separate +columns. See the docs.
item style setWhen no column is specified, returns a list of one +style name +per column. Previously, the list would have less values than the number +of columns if no styles had ever been assigned to the rightmost +column(s).
+ + Potential +incompatibility
item textWhen no column is specified, returns a list of one +string per column.
NewComment
item imagePartner to the [item text] command.
item element perstateNot really new, just renamed from [item element actual] +to +better describe what it does. Accepts a new optional argument which +specifies the state to use when determining the value of the per-state +option.
+ +
+ +The following options no longer return a default value if the per-state +option itself does not have a value specified:
+ +
    + +
  • bitmap -foreground, -background
    • + +
  • border -relief
    • + +
  • text -fill, -font
    • + +
+ + Potential +incompatibility
item spanA style may now be displayed over multiple adjacent +columns.
+ +
+ +

Notify +Command

+ + + + + + + + + + + + + + + + + + + + + + +
NewComment
notify unbind
+ + 		Let's you unbind all scripts from an object with one +call.
+ +

Style Layout Changes

+ +
    + +
  • Column justification will now affect the position of +elements in 2 situations which previously had no effect (Potential incompatibility):
    • + +
+ +
    + +
  1. If a -detach element had a fixed width larger than the +other elements.
    2. + +
  2. If an element had -iexpand x specified as well as +-maxwidth, leaving some space available.
    3. + +
+ +

Element Changes

+ +
    + +
  • Bitmap, image and text elements are drawn clipped if given +less space than they need.
    • + +
  • Fixed line wrapping of text elements. It did not work for +single lines of text at all (Potential +incompatibility).
    • + +
  • The text -wrap option can now be none to disable line +wrapping.
    • + +
+ +

Event Changes

+ +
    + +
  • The new static event <ItemVisibility> +is generated when items become visible on screen and when items are no +longer visible on screen. +This event allows you to create really big lists by only assigning +styles when items are about to be displayed. See the EVENTS AND SCRIPT +SUBSTITUTIONS section in the help +file, and the new demo "Big List".
    • + +
+ +

Other Changes

+ +
    + +
  • On WinXP, the column header sort arrow is drawn like +Explorer draws it if -usetheme +is true.
    • + +
+ +

Demo Changes

+ +
    + +
  • New demo "Big List". Demonstrates the new <ItemVisibility> +event, using <Expand-before> to add items on demand, and +column spanning.
    • + +
  • The context menu has a Span +submenu that lets you manipulate column spanning in items. See +the item span +command in the help file.
    • + +
  • Under WinXP, the "Explorer" demos will use the new shellicon +extension if available. This extension allows a treectrl to display +file/folder icons using the Win32 Shell API. It may work on other +versions of Windows but it hasn't been tested.
    • + +
+ +
+

What's New in TkTreeCtrl 2.0

+ +

TreeCtrl Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
ReplacedWhat +to use +instead
-openbuttonimage-buttonimage
-closedbuttonimage-buttonimage
-openbuttonbitmap-buttonbitmap
-closedbuttonbitmap-buttonbitmap
Usage +ChangedHow +it changed
-backgroundmodeThe values "index" and "visindex" are deprecated. The +value +"order" should be used instead of "index", and +"ordervisible" should be used instead of "visindex". This brings +agreement with the new "item order" command which replaces the "item +index" command.
-treecolumnThis used to be any integer value which may or may not +have +corresponded to an actual column. Now the value must be a valid column +description, or an empty string to indicate no column should display +buttons/lines.
New
+
-backgroundimage
+
-columnprefix
+
-columnresizemode
+
-itemprefix
+
-minitemheight
+
-usetheme
+
+ +

TreeCtrl Commands

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
DeprecatedWhat +to use +instead
compareitem compare
indexitem id
numcolumnscolumn count
numitemsitem count
rangeitem range
+ +

Column Configuration Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
RemovedWhat +to use +instead
-relief
+ + 		-state
-sunken-state
Renamed
+ + 		New +name
-arrowpad-arrowpadx
Usage +ChangedHow +it changed
-backgroundThis is now a per-state option. See COLUMNS in the help +file +for valid state names.
New
+ +
+
-arrowbitmap
+ +
+
-arrowimage
+
-arrowpady
+
-maxwidth
+
-resize
+
-state
+
-textlines
+
+ +

Column Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
DeprecatedWhat +to use +instead
column indexcolumn id
Arguments/Result +ChangedWhat +changed
column configure
+ + 		A column description of "all" is allowed if at least +one +option-value pair is given.
+ +
column createThe result is a unique identifier. Previously the +result was +an +index in the list of columns.
column deleteA column description of "all" is allowed.
NewComment
column compare
+
column countreplaces "numcolumns"
column dragconfigure
+
column dragcget
+
column idreplaces "column index"
column list
+
column order
+
+ +

Item Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
RemovedWhat +to use +instead
item indexitem order
NewComment
item comparereplaces "compare"
item countreplaces "numitems"
item idreplaces "index"
item orderreplaces "item index"
item rangereplaces "range"
+ +

Notify Command

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Arguments/Result +ChangedWhat +changed
notify generate
+ + 		Added optional percentsCommand +argument
notify installOld syntax (supported but deprecated):
+ + 
notify install event eventName
+ + 
notify install detail eventName detail
+ +New syntax:
+ + 
notify install <eventName>
+ + 
notify install <eventName-detail>
+ +
notify linkageOld syntax (supported but deprecated):
+ +
+ 
notify linkage eventName
+ + 
notify linkage eventName detail
+ +
+ +New syntax:
+ +
+ 
notify linkage <eventName>
+ + 
notify linkage <eventName-detail>
+ +
+ +
notify uninstallsee notify +install +above
+ +

Style Layout Options

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Usage +ChangedHow +it changed
-iexpandTwo new flags "x' and "y" are allowed. Previously, only +the +-ipadx and -ipady padding could be expanded by this option. The new xy +flags expand the display area of the element, not the padding. To +update your code, you will probably want to change this:
+ +
+ 
$T style layout $S $E -iexpand we
+ +
+ +to this:
+ +
+ 
$T style layout $S $E -iexpand x
+ +
+ +Keep in mind that -union elements are not affected by -iexpand xy, +since the size of a -union element is determined by the elements it +surrounds.
New
+ +
+
-height
+
-maxheight
+
-maxwidth
+
-minheight
+
-minwidth
+
-sticky
+
-width
+
+ +

Element Changes

+ +
    + +
  • A new element type window +was added. +See the new demo "Firefox Privacy" and the ELEMENTS section in the help +file.
    • + +
  • All element types have a new +per-state boolean option called -draw.
    • + +
  • The text +element type +has a new option called -textvariable. +See the new demo +"Textvariable" and the ELEMENTS section in the help file.
    • + +
+ +

Event Changes

+ +
    + +
  • 2 new %-substitution characters %P +and %? are +allowed in binding +scripts. See the EVENTS AND SCRIPT SUBSTITUTIONS section in the help +file.
    • + +
  • The new static event <ItemDelete> +is generated when items are deleted. See the EVENTS AND SCRIPT +SUBSTITUTIONS section in the help file.
    • + +
+ +

Library Script Changes

+ +

filelist-bindings.tcl:

+ +
    + +
  • The Priv(edit) variable, which is used to specify which +text +elements may be edited, now has the same format as Priv(sensitive). +Previously only elements in the first column could be edited.
    • + +
  • 3 new commands in the TreeCtrl namespace should be used to +access +the Priv(dragimage), Priv(edit) and Priv(sensitive) variables. The +commands are SetDragImage, SetEditable and SetSensitive.
    • + +
  • Two new dynamic events <Edit-begin> +and <Edit-end> +are +generated when editing a file name.
    • + +
+ +

treectrl.tcl:

+ +
    + +
  • On OSX/Aqua, the Command key is used to perform +discontinuous +selection. Previously the Control key was used but Command is specified +by Apple's user-interface guidelines.
    • + +
+ +

Other Changes

+ +
    + +
  • On WinXP, the column headers and open/close buttons are +drawn +using the system theme if -usetheme +is true. The sort arrow is drawn the old-fashioned way.
    • + +
  • On OSX/Aqua,  the column headers and open/close +buttons are +drawn +using the system theme if -usetheme +is true. The sort arrow will be drawn by the Appearance Manager as +well. This will override the -arrowside +and -arrowgravity +options.
    • + +
  • Columns can be moved by drag-and-drop. See column dragconfigure +in the help +file.
    • + +
  • Columns can be specified in new ways. See the COLUMN +DESCRIPTION +section in the help file.
    • + +
  • Added new section DYNAMIC EVENTS to the help file.
    • + +
  • Added new section PER-STATE OPTIONS to the help file.
    • + +
  • The new style layout option -indent +allows elements to be displayed in the button/line area. See the style layout command +in the help +file and the new demo "Firefox Privacy".
    • + +
  • The new item description end +is equivalent to last.
    • + +
  • If you +have version 1.1 +installed, replace the old pkgIndex.tcl file with the one from this +version (but replace the version number 2.0 with 1.1). Otherwise the old pkgIndex.tcl +file will +set the TREECTRL_LIBRARY variable which will override where the library +scripts are found.
    • + +
+ +

Demo Changes

+ +
    + +
  • New demo "Firefox Privacy". Demonstrates the new window element type +and -indent +style layout option.
    • + +
  • New demo "Textvariable". Demonstrates the new -textvariable option +of the text +element.
    • + +
  • Added a new Event Browser window to display events +generated by +the main treectrl widget.
    • + +
  • The context menu can be popped up in all the demo lists. A +<Control-ButtonPress-1> binding for this was added under +OSX/Aqua.
    • + +
  • In the "Explorer" demos, the file name is hidden while +editing +the file name.
    • + +
+ + \ No newline at end of file diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/biglist.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/biglist.tcl new file mode 100644 index 00000000..ab07b538 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/biglist.tcl @@ -0,0 +1,468 @@ +# Copyright (c) 2005-2011 Tim Baker + +# A nice feature of the element type "window" is the -clip option. +set ::clip 1 + +namespace eval DemoBigList {} + +proc DemoBigList::Init {T} { + + variable Priv + + set Priv(noise) 0 + + # + # Configure the treectrl widget + # + + $T configure -selectmode extended \ + -showroot no -showbuttons no -showlines no \ + -showrootlines no + + if {$::clip} { + $T configure -xscrollincrement 4 -yscrollincrement 4 + } else { + # Hide the borders because child windows appear on top of them + $T configure -borderwidth 0 -highlightthickness 0 + } + + # + # Create columns + # + + $T column create -expand yes -text Item -itembackground {#F7F7F7} -tags colItem + $T column create -text "Item ID" -justify center -itembackground {} -tags colID + $T column create -text "Parent ID" -justify center -itembackground {} -tags colParent + + # Specify the column that will display the heirarchy buttons and lines + $T configure -treecolumn colItem + + # + # Create elements + # + + set Priv(bg) $::SystemButtonFace + set outline gray70 + + $T item state define openW + $T item state define openE + $T item state define openWE + + $T element create eRectTop rect -outline $outline -fill $Priv(bg) \ + -outlinewidth 1 -open {wes openWE es openE ws openW} -rx 7 + $T element create eRectBottom rect -outline $outline -fill $Priv(bg) \ + -outlinewidth 1 -open n -rx 7 + + # Title + $T element create elemBorderTitle border -relief {sunken open raised {}} \ + -thickness 1 -filled yes -background $::SystemButtonFace + $T element create elemTxtTitle text \ + -font [list DemoFontBold] + + # Citizen + $T element create elemTxtItem text + $T element create elemTxtName text \ + -fill [list blue {}] + + # Citizen info + $T element create elemWindow window + if {$::clip} { + $T element configure elemWindow -clip yes + } + + # + # Create styles using the elements + # + + set S [$T style create styTitle] + $T style elements $S {elemBorderTitle elemTxtTitle} + $T style layout $S elemTxtTitle -expand news + $T style layout $S elemBorderTitle -detach yes -indent no -iexpand xy + + set S [$T style create styItem] + $T style elements $S {eRectTop elemTxtItem elemTxtName} + $T style layout $S eRectTop -detach yes -indent no -iexpand xy \ + -draw {yes open no {}} -padx {2 0} + $T style layout $S elemTxtItem -expand ns + $T style layout $S elemTxtName -expand ns -padx {20} + + set S [$T style create styID] + $T style elements $S {eRectTop elemTxtItem} + $T style layout $S eRectTop -detach yes -indent yes -iexpand xy -draw {yes open no {}} + $T style layout $S elemTxtItem -padx 6 -expand ns + + set S [$T style create styParent] + $T style elements $S {eRectTop elemTxtItem} + $T style layout $S eRectTop -detach yes -indent yes -iexpand xy \ + -draw {yes open no {}} -padx {0 2} + $T style layout $S elemTxtItem -padx 6 -expand ns + + set S [$T style create styCitizen] + $T style elements $S {eRectBottom elemWindow} + $T style layout $S eRectBottom -detach yes -indent no -iexpand xy \ + -padx 2 -pady {0 1} + $T style layout $S elemWindow -pady {0 2} + + # + # Create 10000 items. Each of these items will hold 10 child items. + # + + set index 1 + foreach I [$T item create -count 10000 -parent root -button yes -open no \ + -height 20 -tags title] { + set Priv(titleIndex,$I) $index + incr index 10 + } + + # This binding will add child items to an item just before it is expanded. + $T notify bind $T { + DemoBigList::ExpandBefore %T %I + } + + # In this demo there are 100,000 items that display a window element. + # It would take a lot of time and memory to create 100,000 Tk windows + # all at once when initializing the demo list. + # The solution is to assign item styles only when items are actually + # visible to the user onscreen. + # + # This binding will assign styles to items when they are displayed and + # clear the styles when they are no longer displayed. + $T notify bind $T { + DemoBigList::ItemVisibility %T %v %h + } + + set Priv(freeWindows) {} + set Priv(nextWindowId) 0 + set Priv(prev) "" + + GetWindowHeight $T + + # When the Tile/Ttk theme changes, recalculate the height of styCitizen + # windows. + if {$::tile} { + bind DemoBigList <> { + after idle BigListThemeChanged [DemoList] + } + } + + bind DemoBigList { + if {[lindex [%W identify %x %y] 0] eq "header"} { + TreeCtrl::DoubleButton1 %W %x %y + } else { + DemoBigList::Button1 %W %x %y + } + break + } + bind DemoBigList { + DemoBigList::Button1 %W %x %y + break + } + bind DemoBigList { + DemoBigList::Motion %W %x %y + } + + bind DemoBigListChildWindow { + set x [expr {%X - [winfo rootx [DemoList]]}] + set y [expr {%Y - [winfo rooty [DemoList]]}] + DemoBigList::Motion [DemoList] $x $y + } + + bindtags $T [list $T DemoBigList TreeCtrl [winfo toplevel $T] all] + + return +} + +# DemoBigList::GetWindowHeight +# +# Calculate and store the height of one of the windows used to display citizen +# information. Since item styles are assigned on-the-fly (see the +# BigListItemVisibility procedure) we need to know the height an item would +# have if it had the "styCitizen" style assigned so the scrollbars are set +# properly. +# +# Arguments: +# T The treectrl widget. + +proc DemoBigList::GetWindowHeight {T} { + variable Priv + # Create a new window just to get the requested size. This will be the + # value of the item -height option for some items. + set w [NewWindow $T root] + update idletasks + if {$::clip} { + set height [winfo reqheight [lindex [winfo children $w] 0]] + } else { + set height [winfo reqheight $w] + } + # Add 2 pixels for the border and gap + incr height 2 + set Priv(windowHeight) $height + FreeWindow $T $w + return +} + +# DemoBigList::ExpandBefore -- +# +# Handle the event. If the item already has child items, +# then nothing happens. Otherwise 1 or more items are created as children +# of the item being expanded. +# +# Take advantage of the event to create child items +# immediately prior to expanding a parent item. +# +# Arguments: +# T The treectrl widget. +# I The item whose children are about to be displayed. + +proc DemoBigList::ExpandBefore {T I} { + + variable Priv + + set parent [$T item parent $I] + if {[$T item numchildren $I]} return + + # Title + if {[$T item tag expr $I title]} { + set index $Priv(titleIndex,$I) + set threats {Severe High Elevated Guarded Low} + set names1 {Bill John Jack Bob Tim Sam Mary Susan Lilian Jeff Gary + Neil Margaret} + set names2 {Smith Hobbs Baker Furst Newel Gates Marshal McNoodle + Marley} + + # Add 10 child items to this item. Each item represents 1 citizen. + # The styles will be assigned in BigListItemVisibility. + foreach I [$T item create -count 10 -parent $I -open no -button yes \ + -height 20 -tags citizen] { + set name1 [lindex $names1 [expr {int(rand() * [llength $names1])}]] + set name2 [lindex $names2 [expr {int(rand() * [llength $names2])}]] + set Priv(itemIndex,$I) $index + set Priv(name,$I) "$name1 $name2" + set Priv(threat,$I) [lindex $threats [expr {int(rand() * 5)}]] + incr index + } + return + } + + # Citizen + if {[$T item tag expr $I citizen]} { + + # Add 1 child item to this item. + # The styles will be assigned in BigListItemVisibility. + $T item create -parent $I -height $Priv(windowHeight) -tags info + } + + return +} + +# DemoBigList::ItemVisibility -- +# +# Handle the event. Item styles are assigned or cleared +# when item visibility changes. +# +# Take advantage of the event to update the appearance of +# items just before they become visible onscreen. +# +# Arguments: +# T The treectrl widget. +# visible List of items that are now visible. +# hidden List of items that are no longer visible. + +proc DemoBigList::ItemVisibility {T visible hidden} { + + variable Priv + + # Assign styles and configure elements in each item that is now + # visible on screen. + foreach I $visible { + set parent [$T item parent $I] + + # Title + if {[$T item tag expr $I title]} { + set first $Priv(titleIndex,$I) + set last [expr {$first + 10 - 1}] + set first [format %06d $first] + set last [format %06d $last] + $T item span $I colItem 3 + $T item style set $I colItem styTitle + $T item element configure $I \ + colItem elemTxtTitle -text "Citizens $first-$last" + continue + } + + # Citizen + if {[$T item tag expr $I citizen]} { + set index $Priv(itemIndex,$I) + $T item style set $I colItem styItem colID styID colParent styParent + $T item element configure $I \ + colItem elemTxtItem -text "Citizen $index" + elemTxtName \ + -textvariable ::DemoBigList::Priv(name,$I) , \ + colParent elemTxtItem -text $parent , \ + colID elemTxtItem -text $I + $T item state forcolumn $I colItem openE + $T item state forcolumn $I colID openWE + $T item state forcolumn $I colParent openW + continue + } + + # Citizen info + if {[$T item tag expr $I info]} { + set w [NewWindow $T $parent] + $T item style set $I colItem styCitizen + $T item span $I colItem 3 + $T item element configure $I colItem \ + elemWindow -window $w + } + } + + # Clear the styles of each item that is no longer visible on screen. + foreach I $hidden { + + # Citizen info + if {[$T item tag expr $I info]} { + # Add this window to the list of unused windows + set w [$T item element cget $I colItem elemWindow -window] + FreeWindow $T $w + } + $T item style set $I colItem "" colParent "" colID "" + } + return +} + +proc DemoBigList::NewWindow {T I} { + variable Priv + + # Check the list of unused windows + if {[llength $Priv(freeWindows)]} { + set w [lindex $Priv(freeWindows) 0] + set Priv(freeWindows) [lrange $Priv(freeWindows) 1 end] + if {$::clip} { + set f $w + set w [lindex [winfo children $f] 0] + } + + if {$Priv(noise)} { dbwin "reuse window $w" } + + # No unused windows exist. Create a new one. + } else { + set id [incr Priv(nextWindowId)] + if {$::clip} { + set f [frame $T.clip$id -background blue] + set w [frame $f.frame$id -background $Priv(bg)] + } else { + set w [frame $T.frame$id -background $Priv(bg)] + } + # Name: label + entry + label $w.label1 -text "Name:" -anchor w -background $Priv(bg) + $::entryCmd $w.entry1 -width 24 + + # Threat Level: label + menubutton + label $w.label2 -text "Threat Level:" -anchor w -background $Priv(bg) + if {$::tile} { + ttk::combobox $w.mb2 -values {Severe High Elevated Guarded Low} \ + -state readonly -width [string length "Elevated"] + } else { + menubutton $w.mb2 -indicatoron yes -menu $w.mb2.m \ + -width [string length Elevated] -relief raised + menu $w.mb2.m -tearoff no + foreach label {Severe High Elevated Guarded Low} { + $w.mb2.m add radiobutton -label $label \ + -value $label \ + -command [list $w.mb2 configure -text $label] + } + } + + # Button + set message \ + "After abducting and probing these people over the last\n\ + 50 years, the only thing we've learned for certain is that\n\ + one in ten just doesn't seem to mind." + if {$::thisPlatform ne "windows"} { + set message [string map {\n ""} $message] + } + $::buttonCmd $w.b3 -text "Anal Probe Wizard..." -command [list tk_messageBox \ + -parent . -message $message -title "Anal Probe 2.0"] + + grid $w.label1 -row 0 -column 0 -sticky w -padx {0 8} + grid $w.entry1 -row 0 -column 1 -sticky w -pady 4 + grid $w.label2 -row 1 -column 0 -sticky w -padx {0 8} + grid $w.mb2 -row 1 -column 1 -sticky w -pady 4 + grid $w.b3 -row 3 -column 0 -columnspan 2 -sticky we -pady {0 4} + + AddBindTag $w DemoBigListChildWindow + AddBindTag $w TagIdentify + + if {$Priv(noise)} { dbwin "create window $w" } + } + + # Tie the widgets to the global variables for this citizen + $w.entry1 configure -textvariable ::DemoBigList::Priv(name,$I) + $w.mb2 configure -textvariable ::DemoBigList::Priv(threat,$I) + if {!$::tile} { + foreach label {Severe High Elevated Guarded Low} { + $w.mb2.m entryconfigure $label -variable ::DemoBigList::Priv(threat,$I) + } + } + if {$::clip} { return $f } + return $w +} + +proc DemoBigList::FreeWindow {T w} { + variable Priv + + # Add the window to our list of free windows. DemoClear will actually + # delete the window when the demo changes. + lappend Priv(freeWindows) $w + if {$Priv(noise)} { dbwin "free window $w" } + return +} + +proc DemoBigList::Button1 {w x y} { + variable ::TreeCtrl::Priv + focus $w + $w identify -array id $x $y + set Priv(buttonMode) "" + if {$id(where) eq "header"} { + TreeCtrl::ButtonPress1 $w $x $y + } elseif {$id(where) eq "item"} { + set item $id(item) + # click a button + if {$id(element) eq ""} { + TreeCtrl::ButtonPress1 $w $x $y + return + } + if {[$w item tag expr $item !info]} { + $w item toggle $item + } + } + return +} + +proc DemoBigList::Motion {w x y} { + variable Priv + $w identify -array id $x $y + if {$id(where) eq "item"} { + set item $id(item) + if {[$w item tag expr $item !info]} { + if {$item ne $Priv(prev)} { + $w configure -cursor hand2 + set Priv(prev) $item + } + return + } + } + if {$Priv(prev) ne ""} { + $w configure -cursor "" + set Priv(prev) "" + } + return +} + +proc DemoBigList::ThemeChanged {T} { + variable Priv + GetWindowHeight $T + if {[$T item id {first visible tag info}] ne ""} { + $T item conf {tag info} -height $Priv(windowHeight) + } + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/bitmaps.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/bitmaps.tcl new file mode 100644 index 00000000..0383c58a --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/bitmaps.tcl @@ -0,0 +1,84 @@ +# Copyright (c) 2002-2011 Tim Baker + +namespace eval DemoBitmaps {} + +proc DemoBitmaps::Init {T} { + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode browse -orient horizontal -wrap "5 items" \ + -showheader no -backgroundimage sky + + $T configure -canvaspadx 6 -canvaspady 6 -itemgapx 4 -itemgapy 4 + + # + # Create columns + # + + $T column create -itembackground {gray90 {}} -tags C0 + + # + # Create elements + # + + $T element create elemTxt text -fill [list $::SystemHighlightText {selected focus}] + $T element create elemSelTxt rect -fill [list $::SystemHighlight {selected focus}] \ + -showfocus yes + $T element create elemSelBmp rect -outline [list $::SystemHighlight {selected focus}] \ + -outlinewidth 4 + $T element create elemBmp bitmap \ + -foreground [list $::SystemHighlight {selected focus}] \ + -background linen \ + -bitmap {question {selected}} + + # + # Create styles using the elements + # + + set S [$T style create STYLE -orient vertical] + $T style elements $S {elemSelBmp elemBmp elemSelTxt elemTxt} + $T style layout $S elemSelBmp -union elemBmp \ + -ipadx 6 -ipady 6 + $T style layout $S elemBmp -pady {0 6} -expand we + $T style layout $S elemSelTxt -union elemTxt -ipadx 2 + $T style layout $S elemTxt -expand we + + # Set default item style + $T column configure C0 -itemstyle $S + + # + # Create items and assign styles + # + + set bitmapNames [list error gray75 gray50 gray25 gray12 hourglass info \ + questhead question warning] + + foreach name $bitmapNames { + set I [$T item create] + $T item text $I C0 $name + $T item element configure $I C0 elemBmp -bitmap $name + $T item lastchild root $I + } + + foreach name $bitmapNames { + set I [$T item create] + $T item style set $I C0 $S + $T item text $I C0 $name +if 1 { + $T item element configure $I C0 elemBmp -bitmap $name \ + -foreground [list brown {}] \ + -background {"" {}} +} else { + $T item element configure $I C0 elemBmp -bitmap $name \ + -foreground [list $::SystemHighlight {selected focus} brown {}] \ + -background {"" {}} +} + $T item lastchild root $I + } + + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/column-lock.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/column-lock.tcl new file mode 100644 index 00000000..79b2bd67 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/column-lock.tcl @@ -0,0 +1,334 @@ +# Copyright (c) 2006-2011 Tim Baker + +namespace eval DemoColumnLock {} + +proc DemoColumnLock::Init {T} { + + variable Priv + + InitPics *checked + + # + # Configure the treectrl widget + # + + $T configure \ + -showbuttons no \ + -showlines no \ + -showroot no \ + -xscrollincrement 40 -xscrolldelay 50 -xscrollsmoothing yes \ + -yscrollincrement 0 -yscrolldelay 50 -yscrollsmoothing yes + + # + # Create columns + # + + for {set i 0} {$i < 100} {incr i} { + $T column create -text "C$i" -tags C$i -width [expr {40 + 20 * ($i % 2)}] -justify center + } + $T column configure first -text LEFT -lock left -width "" + $T column configure last -text RIGHT -lock right -width "" + + $T item state define CHECK + $T item state define mouseover + + # + # Create styles for the left-locked column, and create items + # + + $T element create label1.bg rect -fill {gray80 mouseover gray {}} + $T element create label1.text text + $T style create label1 -orient horizontal + $T style elements label1 {label1.bg label1.text} + $T style layout label1 label1.bg -detach yes -iexpand xy + $T style layout label1 label1.text -expand wns -padx 2 + + for {set i 1} {$i <= 10} {incr i} { + set I [$T item create -tags R$i -parent root] + $T item style set $I C0 label1 + $T item text $I C0 "R$i" + } + + $T element create label2.bd border -background $::SystemButtonFace \ + -relief raised -thickness 2 -filled yes + $T element create label2.text text + $T style create label2 -orient horizontal + $T style elements label2 {label2.bd label2.text} + $T style layout label2 label2.bd -detach yes -iexpand xy + $T style layout label2 label2.text -expand news -padx 2 -pady 2 + + for {set i 11} {$i <= 20} {incr i} { + set I [$T item create -tags R$i -parent root] + $T item style set $I C0 label2 + $T item text $I C0 "R$i" + } + + $T element create label3.div rect -fill black -height 2 + $T element create label3.text text + $T style create label3 -orient horizontal + $T style elements label3 {label3.div label3.text} + $T style layout label3 label3.div -detach yes -expand n -iexpand x + $T style layout label3 label3.text -expand ws -padx 2 -pady 2 + + for {set i 21} {$i <= 30} {incr i} { + set I [$T item create -tags R$i -parent root] + $T item style set $I C0 label3 + $T item text $I C0 "R$i" + } + + $T element create label4.rect rect -fill {#e0e8f0 mouseover} + $T element create label4.text text + $T element create label4.w window -clip yes -destroy yes + $T style create label4 -orient vertical + $T style elements label4 {label4.rect label4.text label4.w} + $T style layout label4 label4.rect -detach yes -iexpand xy + $T style layout label4 label4.text -expand we -padx 2 -pady 2 + $T style layout label4 label4.w -iexpand x -padx 2 -pady {0 2} + + for {set i 31} {$i <= 40} {incr i} { + set I [$T item create -tags R$i -parent root] + $T item style set $I C0 label4 + $T item element configure $I C0 label4.text -textvariable ::DemoColumnLock::Priv(R$i) + set clip [frame $T.clipR${I}C0 -borderwidth 0] + $::entryCmd $clip.e -width 4 -textvariable ::DemoColumnLock::Priv(R$i) + $T item element configure $I C0 label4.w -window $clip + set Priv(R$i) "R$i" + } + + # + # Create styles for the right-locked column + # + + $T element create labelR1.bg rect -fill {gray80 mouseover gray {}} + $T element create labelR1.img image -image {checked CHECK unchecked {}} + $T style create labelR1 -orient horizontal + $T style elements labelR1 {labelR1.bg labelR1.img} + $T style layout labelR1 labelR1.bg -detach yes -iexpand xy + $T style layout labelR1 labelR1.img -expand news -padx 2 -pady 2 + + $T element create labelR2.bd border -background $::SystemButtonFace \ + -relief raised -thickness 2 -filled yes + $T element create labelR2.img image -image {checked CHECK unchecked {}} + $T style create labelR2 -orient horizontal + $T style elements labelR2 {labelR2.bd labelR2.img} + $T style layout labelR2 labelR2.bd -detach yes -iexpand xy + $T style layout labelR2 labelR2.img -expand news -padx 2 -pady 2 + + $T element create labelR3.div rect -fill black -height 2 + $T element create labelR3.img image -image {checked CHECK unchecked {}} + $T style create labelR3 -orient horizontal + $T style elements labelR3 {labelR3.div labelR3.img} + $T style layout labelR3 labelR3.div -detach yes -expand n -iexpand x + $T style layout labelR3 labelR3.img -expand news -padx 2 -pady 2 + + $T element create labelR4.rect rect -fill {#e0e8f0 mouseover} + $T element create labelR4.img image -image {checked CHECK unchecked {}} + $T style create labelR4 -orient vertical + $T style elements labelR4 {labelR4.rect labelR4.img} + $T style layout labelR4 labelR4.rect -detach yes -iexpand xy + $T style layout labelR4 labelR4.img -expand news -padx 2 -pady 2 + + $T item style set {range R1 R10} last labelR1 + $T item style set {range R11 R20} last labelR2 + $T item style set {range R21 R30} last labelR3 + $T item style set {range R31 R40} last labelR4 + + # + # Create styles for the non-locked columns + # + + $T item state define selN + $T item state define selS + $T item state define selW + $T item state define selE + + $T element create cell.bd rect -outline gray -outlinewidth 1 -open wn \ + -fill {gray80 mouseover #F7F7F7 CHECK} + set fill [list gray !focus $::SystemHighlight {}] + $T element create cell.selN rect -height 2 -fill $fill + $T element create cell.selS rect -height 2 -fill $fill + $T element create cell.selW rect -width 2 -fill $fill + $T element create cell.selE rect -width 2 -fill $fill + $T style create cell -orient horizontal + $T style elements cell {cell.bd cell.selN cell.selS cell.selW cell.selE} + $T style layout cell cell.bd -detach yes -iexpand xy + $T style layout cell cell.selN -detach yes -expand s -iexpand x -draw {no !selN} + $T style layout cell cell.selS -detach yes -expand n -iexpand x -draw {no !selS} + $T style layout cell cell.selW -detach yes -expand e -iexpand y -draw {no !selW} + $T style layout cell cell.selE -detach yes -expand w -iexpand y -draw {no !selE} + + # NOTE 1: the following column descriptions are equivalent in this demo: + # "range {first next} {last prev}" + # "all lock none" (see note #2 below) + # "lock none !tail" + # The above item descriptions all specify the unlocked columns between + # the left-locked and right-locked columns. + + $T item style set "root children" "range {first next} {last prev}" cell + + $T element create windowStyle.rect rect -fill {#e0e8f0 mouseover #F7F7F7 CHECK} + $T element create windowStyle.text text + $T element create windowStyle.window window -clip yes -destroy yes + $T style create windowStyle -orient vertical + $T style elements windowStyle {windowStyle.rect windowStyle.text windowStyle.window} + $T style layout windowStyle windowStyle.rect -detach yes -iexpand xy + $T style layout windowStyle windowStyle.text -expand we -padx 2 -pady 2 + $T style layout windowStyle windowStyle.window -iexpand x -padx 2 -pady {0 2} + + # NOTE 2: "all lock none" also matches the tail column, however the + # [item style set] command does not operate on the tail column so it is + # ignored. Explicitly naming the tail column would result in an error + # however. Another example of this behaviour is [column delete all]. + + $T item style set "list {R2 R22}" "all lock none" windowStyle + + foreach C [$T column id "lock none !tail"] { + set Priv(C$C) [$T column cget $C -tags] + + set I R2 + set clip [frame $T.clipR${I}C$C -borderwidth 0] + $::entryCmd $clip.e -width 4 -textvariable ::DemoColumnLock::Priv(C$C) + $T item element configure $I $C windowStyle.window -window $clip + \ + windowStyle.text -textvariable ::DemoColumnLock::Priv(C$C) + + set I R22 + set clip [frame $T.clipR${I}C$C -borderwidth 0] + $::entryCmd $clip.e -width 4 -textvariable ::DemoColumnLock::Priv(C$C) + $T item element configure $I $C windowStyle.window -window $clip + \ + windowStyle.text -textvariable ::DemoColumnLock::Priv(C$C) + } + + bind DemoColumnLock { + DemoColumnLock::Button1 %W %x %y + } + bind DemoColumnLock { + DemoColumnLock::Motion1 %W %x %y + DemoColumnLock::Motion %W %x %y + } + bind DemoColumnLock { + DemoColumnLock::Motion %W %x %y + } + + set Priv(prev) "" + set Priv(selection) {} + + bindtags $T [list $T DemoColumnLock TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoColumnLock::Button1 {w x y} { + variable Priv + $w identify -array id $x $y + set Priv(selecting) 0 + if {$id(where) eq "item"} { + set item $id(item) + set column $id(column) + if {[$w column compare $column == last]} { + $w item state set $item ~CHECK + return + } + if {[$w column cget $column -lock] eq "none"} { + set Priv(corner1) [list $item $column] + set Priv(corner2) $Priv(corner1) + set Priv(selecting) 1 + UpdateSelection $w + } + } + return +} + +proc DemoColumnLock::Motion1 {w x y} { + variable Priv + $w identify -array id $x $y + if {$id(where) eq "item"} { + set item $id(item) + set column $id(column) + if {[$w column cget $column -lock] eq "none"} { + if {$Priv(selecting)} { + set corner [list $item $column] + if {$corner ne $Priv(corner2)} { + set Priv(corner2) $corner + UpdateSelection $w + } + } + } + } + return +} + +proc DemoColumnLock::Motion {w x y} { + variable Priv + $w identify -array id $x $y + if {$id(where) eq ""} { + # nothing + } elseif {$id(where) eq "header"} { + # nothing + } elseif {$id(where) eq "item"} { + set item $id(item) + set column $id(column) + set curr [list $item $column] + if {$curr ne $Priv(prev)} { + if {$Priv(prev) ne ""} { + eval $w item state forcolumn $Priv(prev) !mouseover + } + $w item state forcolumn $item $column mouseover + set Priv(prev) $curr + } + return + } + if {$Priv(prev) ne ""} { + eval $w item state forcolumn $Priv(prev) !mouseover + set Priv(prev) "" + } + return +} + +proc DemoColumnLock::UpdateSelection {w} { + variable Priv + + # Clear the old selection. + foreach {item column} $Priv(selection) { + $w item state forcolumn $item $column {!selN !selS !selE !selW} + } + set Priv(selection) {} + + # Order the 2 corners. + foreach {item1 column1} $Priv(corner1) {} + foreach {item2 column2} $Priv(corner2) {} + if {[$w item compare $item1 > $item2]} { + set swap $item1 + set item1 $item2 + set item2 $swap + } + if {[$w column compare $column1 > $column2]} { + set swap $column1 + set column1 $column2 + set column2 $swap + } + + # Set the state of every item-column on the edges of the selection. + $w item state forcolumn $item1 "range $column1 $column2" selN + $w item state forcolumn $item2 "range $column1 $column2" selS + $w item state forcolumn "range $item1 $item2" $column1 selW + $w item state forcolumn "range $item1 $item2" $column2 selE + + # Remember every item-column on the edges of the selection. + foreach item [list $item1 $item2] { + foreach column [$w column id "range $column1 $column2"] { + lappend Priv(selection) $item $column + } + } + foreach item [$w item id "range $item1 $item2"] { + foreach column [list $column1 $column2] { + lappend Priv(selection) $item $column + } + } + return +} + +proc DemoColumnLock::AddText {} { + set w [DemoList] + $w style elements cell {cell.bd label1.text cell.selN cell.selS cell.selW cell.selE} + $w item text visible {lock none} abc +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/demo.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/demo.tcl new file mode 100644 index 00000000..750d84ef --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/demo.tcl @@ -0,0 +1,2211 @@ +#!/bin/wish84.exe + +# Copyright (c) 2002-2013 Tim Baker + +set VERSION 2.5.2 + +package require Tk 8.4- + +set thisPlatform $::tcl_platform(platform) +if {$thisPlatform eq "unix" && [tk windowingsystem] eq "aqua"} { + set thisPlatform "macosx" +} + +switch -- [tk windowingsystem] { + aqua { set thisPlatform "macosx" } + classic { set thisPlatform "macintosh" } + win32 { set thisPlatform "windows" } + x11 { set thisPlatform "unix" } +} + +proc Platform {args} { + if {![llength $args]} { return $::thisPlatform } + return [expr {[lsearch -exact $args $::thisPlatform] != -1}] +} + +# Get full pathname to this file +set ScriptDir [file normalize [file dirname [info script]]] + +# Command to create a full pathname in this file's directory +proc Path {args} { + return [file normalize [eval [list file join $::ScriptDir] $args]] +} + +# Create some photo images on demand +proc InitPics {args} { + foreach pattern $args { + if {[lsearch [image names] $pattern] == -1} { + foreach file [glob -directory [Path pics] $pattern.gif] { + set imageName [file root [file tail $file]] + # I created an image called "file", which clobbered the + # original Tcl command "file". Then I got confused. + if {[llength [info commands $imageName]]} { + error "don't want to create image called \"$imageName\"" + } + image create photo $imageName -file $file + + # Hack -- Create a "selected" version too + image create photo ${imageName}Sel + ${imageName}Sel copy $imageName + imagetint ${imageName}Sel $::SystemHighlight 128 + } + } + } + return +} + +# http://wiki.tcl.tk/1530 +if {[info procs lassign] eq ""} { + proc lassign {values args} { + uplevel 1 [list foreach $args [linsert $values end {}] break] + lrange $values [llength $args] end + } +} + +if {[catch { + package require dbwin +}]} { + proc dbwin {s} { + puts [string trimright $s "\n"] + } +} +proc dbwintrace {name1 name2 op} { + dbwin $::dbwin +} +trace add variable ::dbwin write dbwintrace + +# This gets called if 'package require' won't work during development. +proc LoadSharedLibrary {} { + + switch -- $::thisPlatform { + macintosh { + set pattern treectrl*.shlb + } + macosx { + set pattern treectrl*.dylib + } + unix { + set pattern libtreectrl*[info sharedlibextension]* + } + windows { + set pattern treectrl*[info sharedlibextension] + } + } + + set SHLIB [glob -nocomplain -directory [Path ..] $pattern] + if {[llength $SHLIB] != 1} { + return 0 + } + + # When using configure/make, the "make demo" Makefile target sets the value of + # the TREECTRL_LIBRARY environment variable which is used by tcl_findLibrary to + # find our treectrl.tcl file. When *not* using configure/make, we set the value + # of TREECTRL_LIBRARY and load the shared library manually. Note that + # tcl_findLibrary is called by the Treectrl_Init() routine in C. + set ::env(TREECTRL_LIBRARY) [Path .. library] + + load $SHLIB + + return 1 +} + +puts "demo.tcl: Tcl/Tk [info patchlevel] [winfo server .]" + +# See if treectrl is already loaded for some reason +if {[llength [info commands treectrl]]} { + puts "demo.tcl: using previously-loaded treectrl package v[package provide treectrl]" + if {$VERSION ne [package provide treectrl]} { + puts "demo.tcl: WARNING: expected v$VERSION" + } + +# For 'package require' to work with the development version, make sure the +# TCLLIBPATH and TREECTRL_LIBRARY environment variables are set by your +# Makefile/Jamfile/IDE etc. +} elseif {![catch {package require treectrl $VERSION} err]} { + puts "demo.tcl: 'package require' succeeded" + +} else { + puts "demo.tcl: 'package require' failed: >>> $err <<<" + + if {[LoadSharedLibrary]} { + puts "demo.tcl: loaded treectrl library by hand" + + } else { + error "demo.tcl: can't load treectrl package" + } +} + +# Display path of shared library that was loaded +foreach list [info loaded] { + set file [lindex $list 0] + set pkg [lindex $list 1] + if {$pkg ne "Treectrl"} continue + puts "demo.tcl: using '$file'" + break +} +if {[info exists env(TREECTRL_LIBRARY)]} { + puts "demo.tcl: TREECTRL_LIBRARY=$env(TREECTRL_LIBRARY)" +} else { + puts "demo.tcl: TREECTRL_LIBRARY undefined" +} +puts "demo.tcl: treectrl_library=$treectrl_library" + +set tile 0 +set tileFull 0 ; # 1 if using tile-aware treectrl +catch { + if {[ttk::style layout TreeCtrl] ne ""} { + set tile 1 + set tileFull 1 + } +} +if {$tile == 0} { + catch { + package require tile 0.7.8 + namespace export style + namespace eval ::tile { + namespace export setTheme + } + namespace eval ::ttk { + namespace import ::style + namespace import ::tile::setTheme + } + set tile 1 + } +} +if {$tile} { + # Don't import ttk::entry, it messes up the edit bindings, and I'm not + # sure how to get/set the equivalent -borderwidth, -selectborderwidth + # etc options of a TEntry. + set entryCmd ::ttk::entry + set buttonCmd ::ttk::button + set checkbuttonCmd ::ttk::checkbutton + set radiobuttonCmd ttk::radiobutton + set scrollbarCmd ::ttk::scrollbar + set scaleCmd ::ttk::scale +} else { + set entryCmd ::entry + set buttonCmd ::button + set checkbuttonCmd ::checkbutton + set radiobuttonCmd ::radiobutton + set scrollbarCmd ::scrollbar + set scaleCmd ::scale +} + +option add *TreeCtrl.Background white +#option add *TreeCtrl.itemPrefix item +#option add *TreeCtrl.ColumnPrefix col + +if {$tile} { + set font TkDefaultFont +} else { + switch -- $::thisPlatform { + macintosh { + set font {Geneva 9} + } + macosx { + set font {{Lucida Grande} 13} + } + unix { + set font {Helvetica -12} + } + default { + # There is a bug on my Win98 box with Tk_MeasureChars() and + # MS Sans Serif 8. + set font {{MS Sans} 8} + } + } +} +array set fontInfo [font actual $font] +eval font create DemoFont [array get fontInfo] +option add *TreeCtrl.font DemoFont + +array set fontInfo [font actual $font] +set fontInfo(-weight) bold +eval font create DemoFontBold [array get fontInfo] + +array set fontInfo [font actual $font] +set fontInfo(-underline) 1 +eval font create DemoFontUnderline [array get fontInfo] + +proc SetDemoFontSize {size} { + font configure DemoFont -size $size + font configure DemoFontBold -size $size + font configure DemoFontUnderline -size $size + return +} +proc IncreaseFontSize {} { + set size [font configure DemoFont -size] + if {$size < 0} { + incr size -1 + } else { + incr size + } + SetDemoFontSize $size + return +} +proc DecreaseFontSize {} { + set size [font configure DemoFont -size] + if {$size < 0} { + incr size + } else { + incr size -1 + } + SetDemoFontSize $size + return +} + +# Demo sources +foreach file { + biglist + bitmaps + column-lock + explorer + firefox + gradients + gradients2 + gradients3 + headers + help + imovie + layout + mailwasher + mycomputer + outlook-folders + outlook-newgroup + random + span + table + textvariable + www-options +} { + source [Path $file.tcl] +} + +# Get default colors +set w [listbox .listbox] +set SystemButtonFace [$w cget -highlightbackground] +set SystemHighlight [$w cget -selectbackground] +set SystemHighlightText [$w cget -selectforeground] +destroy $w + +if {$thisPlatform == "unix"} { + # I hate that gray selection color + set SystemHighlight #316ac5 + set SystemHighlightText White +} + +proc MakeMenuBar {} { + set m [menu .menubar] + . configure -menu $m + set m2 [menu $m.mFile -tearoff no] + if {$::thisPlatform ne "unix" && [info commands console] ne ""} { + console eval { + wm title . "TkTreeCtrl Console" + if {[info tclversion] eq "8.4"} { + .console configure -font {Courier 9} + } + .console configure -height 8 +# ::tk::ConsolePrompt + wm geometry . +0-100 + } + $m2 add command -label "Console" -command { + if {[console eval {winfo ismapped .}]} { + console hide + } else { + console show + } + } + } else { +# uplevel #0 source ~/Programming/console.tcl + } + $m2 add command -label "Event Browser" -command EventsWindow::ToggleWindowVisibility + $m2 add command -label "Identify" -command IdentifyWindow::ToggleWindowVisibility + $m2 add command -label "Style Editor" -command ToggleStyleEditorWindow + $m2 add command -label "View Source" -command SourceWindow::ToggleWindowVisibility + $m2 add command -label "Magnifier" -command LoupeWindow::ToggleWindowVisibility + $m2 add separator + $m2 add checkbutton -label "Native Gradients" -command ToggleNativeGradients \ + -variable ::NativeGradients + $m2 add separator + $m2 add command -label "Increase Font Size" -command IncreaseFontSize + $m2 add command -label "Decrease Font Size" -command DecreaseFontSize + switch -- [Platform] { + macintosh - + macosx { + $m add cascade -label "TkTreeCtrl" -menu $m2 + } + unix - + windows { + $m2 add separator + $m2 add command -label "Quit" -command exit + $m add cascade -label "File" -menu $m2 + } + } + + if {$::tile} { + set m2 [menu $m.mTheme -tearoff no] + $m add cascade -label "Theme" -menu $m2 + foreach theme [lsort -dictionary [ttk::style theme names]] { + $m2 add radiobutton -label $theme -command [list ttk::setTheme $theme] \ + -variable ::DemoTheme -value $theme + } + $m2 add separator + $m2 add command -label "Inspector" -command ThemeWindow::ToggleWindowVisibility + } + + return +} + +namespace eval EventsWindow {} + +proc EventsWindow::Init {} { + set w [toplevel .events] + wm withdraw $w +# wm transient $w . + wm title $w "TkTreeCtrl Events" + + set m [menu $w.menubar] + $w configure -menu $m + set m1 [menu $m.m1 -tearoff 0] + $m1 add cascade -label "Static" -menu [menu $m1.m1 -tearoff 0] + $m1 add cascade -label "Dynamic" -menu [menu $m1.m2 -tearoff 0] + $m1 add command -label "Clear Window" -command "$w.f.t item delete all" \ + -accelerator Ctrl+X + $m1 add command -label "Rebuild Menus" -command "EventsWindow::RebuildMenus $w.f.t $m" + $m add cascade -label "Events" -menu $m1 + + bind $w "$w.f.t item delete all" + + TreePlusScrollbarsInAFrame $w.f 1 1 + pack $w.f -expand yes -fill both + + set T $w.f.t + + $T configure -showheader no -showroot no -showrootlines no -height 300 + $T column create -tags C0 + $T configure -treecolumn C0 + + $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e2 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + $T element create e4 rect -fill blue -width 100 -height 2 + + set S [$T style create s1] + $T style elements $S {e3 e1} + $T style layout $S e3 -union [list e1] -ipadx 1 -ipady {0 1} + + set S [$T style create s2] + $T style elements $S {e3 e1 e2} + $T style layout $S e1 -width 20 -sticky w + $T style layout $S e3 -union [list e1 e2] -ipadx 1 -ipady {0 1} + + set S [$T style create s3] + $T style elements $S {e4} + + $T column configure C0 -itemstyle s1 + + RebuildMenus $T $m + + wm protocol $w WM_DELETE_WINDOW "EventsWindow::ToggleWindowVisibility" + switch -- $::thisPlatform { + macintosh - + macosx { + wm geometry $w -40+40 + } + default { + wm geometry $w -0+0 + } + } + + return +} + +proc EventsWindow::RebuildMenus {T m} { + variable Priv + foreach event [lsort -dictionary [[DemoList] notify eventnames]] { + set details [lsort -dictionary [[DemoList] notify detailnames $event]] + foreach detail $details { + set pattern <$event-$detail> + set linkage [[DemoList] notify linkage $pattern] + lappend patterns $pattern $linkage + lappend patterns2($linkage) $pattern + } + if {![llength $details]} { + set pattern <$event> + set linkage [[DemoList] notify linkage $pattern] + lappend patterns $pattern $linkage + lappend patterns2($linkage) $pattern + } + } + + $m.m1.m1 delete 0 end + $m.m1.m2 delete 0 end + set menu(static) $m.m1.m1 + set menu(dynamic) $m.m1.m2 + foreach {pattern linkage} $patterns { + if {![info exists Priv(track,$pattern)]} { + set Priv(track,$pattern) 1 + } + $menu($linkage) add checkbutton -label $pattern \ + -variable ::EventsWindow::Priv(track,$pattern) \ + -command [list EventsWindow::ToggleEvent $T $pattern] + } + foreach linkage {static dynamic} { + $menu($linkage) add separator + $menu($linkage) add command -label "Toggle All" \ + -command [list EventsWindow::ToggleEvents $T $patterns2($linkage)] + } + + set Priv(events) {} + set Priv(afterId) "" + foreach {pattern linkage} $patterns { + [DemoList] notify bind $T $pattern { + EventsWindow::EventBinding %W %? + } + } + return +} + +proc EventsWindow::EventBinding {T charMap} { + variable Priv + lappend Priv(events) $charMap + if {$Priv(afterId) eq ""} { + set Priv(afterId) [after idle [list EventsWindow::RecordEvents $T]] + } + return +} + +proc EventsWindow::RecordEvents {T} { + variable Priv + set Priv(afterId) "" + set events $Priv(events) + set Priv(events) {} + if {![winfo ismapped .events]} return + if {[$T item numchildren root] > 2000} { + set N [expr {[$T item numchildren root] - 2000}] + $T item delete "root firstchild" "root child $N" + } + if {0 && [$T item count] > 1} { + set I [$T item create] + $T item style set $I 0 s3 + $T item lastchild root $I + } + set open 1 + if {[llength $events] > 50} { + set open 0 + } + foreach list $events { + RecordEvent $T $list $open + } + $T see "last visible" + return +} + +proc EventsWindow::RecordEvent {T list open} { + set I [$T item create -open $open] + array set map $list + $T item text $I C0 $map(P) + $T item lastchild root $I + foreach {char value} $list { + if {[string first $char "TWPed"] != -1} continue + set I2 [$T item create] + $T item style set $I2 C0 s2 + $T item element configure $I2 C0 e1 -text $char + e2 -text $value + $T item lastchild $I $I2 + $T item configure $I -button yes + } + return +} + +proc EventsWindow::ToggleWindowVisibility {} { + set w .events + if {![winfo exists $w]} { + Init + } + if {[winfo ismapped $w]} { + wm withdraw $w + } else { + wm deiconify $w + raise $w + } + return +} + +proc EventsWindow::ToggleEvent {T pattern} { + variable Priv + [DemoList] notify configure $T $pattern -active $Priv(track,$pattern) + return +} + +proc EventsWindow::ToggleEvents {T patterns} { + variable Priv + foreach pattern $patterns { + set Priv(track,$pattern) [expr {!$Priv(track,$pattern)}] + ToggleEvent $T $pattern + } + return +} + +namespace eval IdentifyWindow {} + +proc IdentifyWindow::Init {} { + set w .identify + toplevel $w + wm withdraw $w + wm title $w "TkTreeCtrl Identify" + set wText $w.text + text $wText -state disabled -width 70 -height 3 -font [[DemoList] cget -font] + $wText tag configure tagBold -font DemoFontBold + pack $wText -expand yes -fill both + wm protocol $w WM_DELETE_WINDOW "IdentifyWindow::ToggleWindowVisibility" + return +} + +proc IdentifyWindow::Update {T x y} { + set w .identify + if {![winfo exists $w]} return + if {![winfo ismapped $w]} return + set wText $w.text + $wText configure -state normal + $wText delete 1.0 end + set nearest [$T item id [list nearest $x $y]] + $wText insert end "x=" tagBold "$x " {} "y=" tagBold "$y " {} "nearest=" tagBold $nearest\n + $wText insert end "string: " + foreach {key val} [$T identify $x $y] { + $wText insert end $key tagBold " $val " + } + $wText insert end "\narray: " + $T identify -array id $x $y + switch -- $id(where) { + "header" { + set keys [list where header column element side] + } + "item" { + set keys [list where item column element button line] + } + default { + set keys [array names id] + } + } + foreach key $keys { + set val $id($key) + if {$val eq ""} { + set val "\"\"" + } + $wText insert end $key tagBold " $val " + } + $wText configure -state disabled + return +} + +proc IdentifyWindow::ToggleWindowVisibility {} { + set w .identify + if {![winfo exists $w]} { + Init + } + if {[winfo ismapped $w]} { + wm withdraw $w + } else { + wm deiconify $w + raise $w + } + return +} + +namespace eval SourceWindow {} + +proc SourceWindow::Init {} { + set w [toplevel .source] + wm withdraw $w +# wm transient $w . + set f [frame $w.f -borderwidth 0] + if {[lsearch -exact [font names] TkFixedFont] != -1} { + set font TkFixedFont + } else { + switch -- $::thisPlatform { + macintosh - + macosx { + set font {Geneva 9} + } + unix { + set font {Courier -12} + } + default { + set font {Courier 9} + } + } + } + text $f.t -font $font -tabs [font measure $font 12345678] -wrap none \ + -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" + $::scrollbarCmd $f.sv -orient vertical -command "$f.t yview" + $::scrollbarCmd $f.sh -orient horizontal -command "$f.t xview" + pack $f -expand yes -fill both + grid columnconfigure $f 0 -weight 1 + grid rowconfigure $f 0 -weight 1 + grid configure $f.t -row 0 -column 0 -sticky news + grid configure $f.sh -row 1 -column 0 -sticky we + grid configure $f.sv -row 0 -column 1 -sticky ns + + wm protocol $w WM_DELETE_WINDOW "SourceWindow::ToggleWindowVisibility" + switch -- $::thisPlatform { + macintosh - + macosx { + wm geometry $w +0+30 + } + default { + wm geometry $w -0+0 + } + } + + return +} + +proc SourceWindow::ShowSource {file} { + wm title .source "TkTreeCtrl Source: $file" + set path [Path $file] + set t .source.f.t + set chan [open $path] + $t delete 1.0 end + $t insert end [read $chan] + $t mark set insert 1.0 + close $chan + return +} + +proc SourceWindow::ToggleWindowVisibility {} { + set w .source + if {[winfo ismapped $w]} { + wm withdraw $w + } else { + wm deiconify $w + raise $w + } + return +} + +proc ToggleStyleEditorWindow {} { + set w .styleEditor + if {![winfo exists $w]} { + source [Path style-editor.tcl] + StyleEditor::Init [DemoList] + StyleEditor::SetListOfStyles + } elseif {[winfo ismapped $w]} { + wm withdraw $w + } else { + wm deiconify $w + raise $w + StyleEditor::SetListOfStyles + } + return +} + +namespace eval ThemeWindow {} +proc ThemeWindow::Init {} { + set w [toplevel .theme] + wm withdraw $w +# wm transient $w . + wm title $w "TkTreeCtrl Themes" + + set m [menu $w.menubar] + $w configure -menu $m + set m1 [menu $m.m1 -tearoff 0] + $m1 add command -label "Set List" -command ThemeWindow::SetList + $m add cascade -label "Theme" -menu $m1 + + TreePlusScrollbarsInAFrame $w.f 1 1 + pack $w.f -expand yes -fill both + + set T $w.f.t + + $T configure -showheader no -showroot no -showrootlines no -height 300 + $T column create -tags C0 + $T configure -treecolumn C0 + + $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + + set S [$T style create s1] + $T style elements $S {e3 e1} + $T style layout $S e3 -union [list e1] -ipadx 1 -ipady {0 1} + + $T column configure C0 -itemstyle s1 + + SetList + + wm protocol $w WM_DELETE_WINDOW "ThemeWindow::ToggleWindowVisibility" + + return +} + +proc ThemeWindow::ToggleWindowVisibility {} { + set w .theme + if {![winfo exists $w]} { + Init + } + if {[winfo ismapped $w]} { + wm withdraw $w + } else { + wm deiconify $w + raise $w + } + return +} + +proc ThemeWindow::SetList {} { + set w .theme + set T $w.f.t + + $T item delete all + # + # Themes + # + foreach theme [lsort -dictionary [ttk::style theme names]] { + set I [$T item create -button yes -open no -tags theme -parent root] + $T item text $I C0 $theme + ttk::style theme settings $theme { + set I2 [$T item create -button yes -open no -parent $I] + $T item text $I2 C0 ELEMENTS + # + # Elements + # + foreach element [lsort -dictionary [ttk::style element names]] { + # + # Element options + # + set options [ttk::style element options $element] + set I3 [$T item create -button [llength $options] -open no -tags element -parent $I2] + $T item text $I3 C0 $element + foreach option [lsort -dictionary $options] { + set I4 [$T item create -open no -tags {element option} -parent $I3] + $T item text $I4 C0 $option + } + } + # + # Styles + # + set I2 [$T item create -button yes -open no -parent $I] + $T item text $I2 C0 STYLES + set styles [list "."] ; # [ttk::style names] please! + foreach style [lsort -dictionary $styles] { + # + # Style options + # + set cfg [ttk::style configure $style] + set I3 [$T item create -button [llength $cfg] -open no -tags style -parent $I2] + $T item text $I3 C0 $style + foreach {option value} $cfg { + set I4 [$T item create -open no -tags {style option} -parent $I3] + $T item text $I4 C0 "$option $value" + } + } + } + } + return +} + +set ::NativeGradients 1 +proc ToggleNativeGradients {} { + [DemoList] gradient native $::NativeGradients + dbwin "native gradients is now $::NativeGradients" + return +} + +SourceWindow::Init +MakeMenuBar + +# http://wiki.tcl.tk/950 +proc sbset {sb first last} { + # Get infinite loop on X11 + if {$::thisPlatform ne "unix"} { + if {$first <= 0 && $last >= 1} { + grid remove $sb + } else { + grid $sb + } + } + $sb set $first $last + return +} + +proc TreePlusScrollbarsInAFrame {f h v} { + if {$::tileFull} { + frame $f -borderwidth 0 + } else { + frame $f -borderwidth 1 -relief sunken + } + treectrl $f.t -highlightthickness 0 -borderwidth 0 + if {[Platform unix]} { + $f.t configure -headerfont [$f.t cget -font] + } + $f.t configure -xscrollincrement 20 -xscrollsmoothing 1 +# $f.t configure -itemprefix item# -columnprefix column# + $f.t debug configure -enable no -display yes -erasecolor pink \ + -drawcolor orange -displaydelay 30 -textlayout 0 -data 0 -span 0 + if {$h} { + $::scrollbarCmd $f.sh -orient horizontal -command "$f.t xview" + # $f.t configure -xscrollcommand "$f.sh set" + $f.t notify bind $f.sh { sbset %W %l %u } + bind $f.sh "focus $f.t" + } + if {$v} { + $::scrollbarCmd $f.sv -orient vertical -command "$f.t yview" + # $f.t configure -yscrollcommand "$f.sv set" + $f.t notify bind $f.sv { sbset %W %l %u } + bind $f.sv "focus $f.t" + } + grid columnconfigure $f 0 -weight 1 + grid rowconfigure $f 0 -weight 1 + grid configure $f.t -row 0 -column 0 -sticky news + if {$h} { + grid configure $f.sh -row 1 -column 0 -sticky we + } + if {$v} { + grid configure $f.sv -row 0 -column 1 -sticky ns + } + + bind $f.t { + TreeCtrl::MarqueeBegin %W %x %y + set DebugExpose(x1) %x + set DebugExpose(y1) %y + break + } + bind $f.t { + TreeCtrl::MarqueeUpdate %W %x %y + set DebugExpose(x2) %x + set DebugExpose(y2) %y + break + } + bind $f.t { + TreeCtrl::MarqueeEnd %W %x %y + %W debug expose $DebugExpose(x1) $DebugExpose(y1) $DebugExpose(x2) $DebugExpose(y2) + break + } + + MakeListPopup $f.t + MakeHeaderPopup $f.t + + switch -- $::thisPlatform { + macintosh - + macosx { + bind $f.t { + ShowPopup %W %x %y %X %Y + } + bind $f.t { + ShowPopup %W %x %y %X %Y + } + } + unix - + windows { + bind $f.t { + ShowPopup %W %x %y %X %Y + } + } + } + + return +} + +proc ShouldShowLines {T} { + if {![$T cget -usetheme]} { + return 1 + } + switch -- [$T theme platform] { + aqua - + gtk { + return 0 + } + } + return 1 +} + +proc MakeMainWindow {} { + + wm title . "TkTreeCtrl Demo" + + switch -- $::thisPlatform { + macintosh - + macosx { + wm geometry . +6+30 + } + default { + wm geometry . +0+0 + } + } + + panedwindow .pw2 -orient horizontal -borderwidth 0 -sashwidth 6 + panedwindow .pw1 -orient vertical -borderwidth 0 -sashwidth 6 + + # Tree + scrollbar: demos + TreePlusScrollbarsInAFrame .f1 1 1 + .f1.t configure -showbuttons no -showlines no -showroot no -height 100 + .f1.t column create -text "List of Demos" -expand yes -button no -tags C0 + .f1.t configure -treecolumn C0 + + # Tree + scrollbar: styles + elements in list + TreePlusScrollbarsInAFrame .f4 1 1 + .f4.t configure -showlines [ShouldShowLines .f4.t] -showroot no -height 140 + .f4.t column create -text "Elements and Styles" -expand yes -button no -tags C0 + .f4.t configure -treecolumn C0 + + # Tree + scrollbar: styles + elements in selected item + TreePlusScrollbarsInAFrame .f3 1 1 + .f3.t configure -showlines [ShouldShowLines .f3.t] -showroot no + .f3.t column create -text "Styles in Item" -expand yes -button no -tags C0 + .f3.t configure -treecolumn C0 + + .pw1 add .f1 .f4 .f3 -height 150 + + # Frame on right + frame .f2 + + # Tree + scrollbars + TreePlusScrollbarsInAFrame .f2.f1 1 1 + [DemoList] configure -indent 19 + + # Give it a big border to debug drawing + if {!$::tileFull} { + [DemoList] configure -borderwidth 6 -relief ridge -highlightthickness 3 + } + + grid columnconfigure .f2 0 -weight 1 + grid rowconfigure .f2 0 -weight 1 + grid configure .f2.f1 -row 0 -column 0 -sticky news -pady 0 + + # Window to display result of "T identify" + bind TagIdentify { + if {"%W" ne [DemoList]} { + set x [expr {%X - [winfo rootx [DemoList]]}] + set y [expr {%Y - [winfo rooty [DemoList]]}] + } else { + set x %x + set y %y + } + IdentifyWindow::Update [DemoList] $x $y + } + AddBindTag [DemoList] TagIdentify + + .pw2 add .pw1 -width 200 + .pw2 add .f2 -width 450 + + pack .pw2 -expand yes -fill both + + bind [DemoList] { + set NativeGradients [expr {!$NativeGradients}] + ToggleNativeGradients + } + + ### + # A treectrl widget can generate the following built-in events: + # called when the active item changes + # called before an item is closed + # called after an item is closed + # called before an item is opened + # called after an item is opened + # called before items are deleted + # called when horizontal scroll position changes + # called when vertical scroll position changes + # called when items are added to or removed from the selection + # + # The application programmer can define custom events to be + # generated by the "notify generate" command. The following events + # are generated by the library scripts. + + [DemoList] notify install + [DemoList] notify install + + [DemoList] notify install + [DemoList] notify install + [DemoList] notify install + [DemoList] notify install + + [DemoList] notify install + [DemoList] notify install + [DemoList] notify install + + [DemoList] notify install + [DemoList] notify install + [DemoList] notify install + ### + + # This event is generated when a column's visibility is changed by + # the context menu. + [DemoList] notify install + + return +} + +proc DemoList {} { + return .f2.f1.t +} +proc demolist args { # console-friendly version + uplevel .f2.f1.t $args +} + +proc MakeListPopup {T} { + set m [menu $T.mTree -tearoff no] + + set m2 [menu $m.mCollapse -tearoff no] + $m add cascade -label Collapse -menu $m2 + + set m2 [menu $m.mExpand -tearoff no] + $m add cascade -label Expand -menu $m2 + + set m2 [menu $m.mBgImg -tearoff no] + $m2 add radiobutton -label none -variable Popup(bgimg) -value none \ + -command {$Popup(T) configure -backgroundimage ""} + $m2 add radiobutton -label feather -variable Popup(bgimg) -value feather \ + -command {$Popup(T) configure -bgimage $Popup(bgimg) -bgimageopaque no} + $m2 add radiobutton -label sky -variable Popup(bgimg) -value sky \ + -command {$Popup(T) configure -bgimage $Popup(bgimg) -bgimageopaque yes} + $m2 add separator + set m3 [menu $m2.mBgImgAnchor -tearoff no] + foreach anchor {nw n ne w center e sw s se} { + $m3 add radiobutton -label $anchor -variable Popup(bgimganchor) \ + -value $anchor \ + -command {$Popup(T) configure -bgimageanchor $Popup(bgimganchor)} + } + $m2 add cascade -label "Anchor" -menu $m3 + $m2 add separator + $m2 add checkbutton -label "Opaque" -variable Popup(bgimgopaque) \ + -command {$Popup(T) configure -bgimageopaque $Popup(bgimgopaque)} + $m2 add separator + $m2 add checkbutton -label "Scroll X" -variable Popup(bgimgscrollx) \ + -onvalue x -offvalue "" -command {$Popup(T) configure -bgimagescroll $Popup(bgimgscrollx)$Popup(bgimgscrolly)} + $m2 add checkbutton -label "Scroll Y" -variable Popup(bgimgscrolly) \ + -onvalue y -offvalue "" -command {$Popup(T) configure -bgimagescroll $Popup(bgimgscrollx)$Popup(bgimgscrolly)} + $m2 add separator + $m2 add checkbutton -label "Tile X" -variable Popup(bgimgtilex) \ + -onvalue x -offvalue "" -command {$Popup(T) configure -bgimagetile $Popup(bgimgtilex)$Popup(bgimgtiley)} + $m2 add checkbutton -label "Tile Y" -variable Popup(bgimgtiley) \ + -onvalue y -offvalue "" -command {$Popup(T) configure -bgimagetile $Popup(bgimgtilex)$Popup(bgimgtiley)} + $m add cascade -label "Background Image" -menu $m2 + + set m2 [menu $m.mBgMode -tearoff no] + foreach value {column order ordervisible row} { + $m2 add radiobutton -label $value -variable Popup(bgmode) -value $value \ + -command {$Popup(T) configure -backgroundmode $Popup(bgmode)} + } + $m add cascade -label "Background Mode" -menu $m2 + + $m add checkbutton -label "Button Tracking" -variable Popup(buttontracking) \ + -command {$Popup(T) configure -buttontracking $Popup(buttontracking)} + + set m2 [menu $m.mColumns -tearoff no] + $m add cascade -label "Columns" -menu $m2 + + set m2 [menu $m.mHeaders -tearoff no] + $m add cascade -label "Headers" -menu $m2 + + set m2 [menu $m.mColumnResizeMode -tearoff no] + $m2 add radiobutton -label proxy -variable Popup(columnresizemode) -value proxy \ + -command {$Popup(T) configure -columnresizemode $Popup(columnresizemode)} + $m2 add radiobutton -label realtime -variable Popup(columnresizemode) -value realtime \ + -command {$Popup(T) configure -columnresizemode $Popup(columnresizemode)} + $m add cascade -label "Column Resize Mode" -menu $m2 + + set m2 [menu $m.mDebug -tearoff no] + $m2 add checkbutton -label Data -variable Popup(debug,data) \ + -command {$Popup(T) debug configure -data $Popup(debug,data)} + $m2 add checkbutton -label Display -variable Popup(debug,display) \ + -command {$Popup(T) debug configure -display $Popup(debug,display)} + $m2 add checkbutton -label Span -variable Popup(debug,span) \ + -command {$Popup(T) debug configure -span $Popup(debug,span)} + $m2 add checkbutton -label "Text Layout" -variable Popup(debug,textlayout) \ + -command {$Popup(T) debug configure -textlayout $Popup(debug,textlayout)} + $m2 add separator + set m3 [menu $m2.mDelay -tearoff no] + foreach n {10 20 30 40 50 60 70 80 90 100} { + $m3 add radiobutton -label $n -variable Popup(debug,displaydelay) -value $n \ + -command {$Popup(T) debug configure -displaydelay $Popup(debug,displaydelay)} + } + $m2 add cascade -label "Display Delay" -menu $m3 + $m2 add separator + $m2 add checkbutton -label Enable -variable Popup(debug,enable) \ + -command {$Popup(T) debug configure -enable $Popup(debug,enable)} + $m add cascade -label Debug -menu $m2 +if 0 { + set m2 [menu $m.mBuffer -tearoff no] + $m2 add radiobutton -label "none" -variable Popup(doublebuffer) -value none \ + -command {$Popup(T) configure -doublebuffer $Popup(doublebuffer)} + $m2 add radiobutton -label "item" -variable Popup(doublebuffer) -value item \ + -command {$Popup(T) configure -doublebuffer $Popup(doublebuffer)} + $m2 add radiobutton -label "window" -variable Popup(doublebuffer) -value window \ + -command {$Popup(T) configure -doublebuffer $Popup(doublebuffer)} + $m add cascade -label Buffering -menu $m2 +} + set m2 [menu $m.mItemWrap -tearoff no] + $m add cascade -label "Item Wrap" -menu $m2 + + set m2 [menu $m.mLineStyle -tearoff no] + $m2 add radiobutton -label "dot" -variable Popup(linestyle) -value dot \ + -command {$Popup(T) configure -linestyle $Popup(linestyle)} + $m2 add radiobutton -label "solid" -variable Popup(linestyle) -value solid \ + -command {$Popup(T) configure -linestyle $Popup(linestyle)} + $m add cascade -label "Line style" -menu $m2 + + set m2 [menu $m.mOrient -tearoff no] + $m2 add radiobutton -label "Horizontal" -variable Popup(orient) -value horizontal \ + -command {$Popup(T) configure -orient $Popup(orient)} + $m2 add radiobutton -label "Vertical" -variable Popup(orient) -value vertical \ + -command {$Popup(T) configure -orient $Popup(orient)} + $m add cascade -label Orient -menu $m2 + + set m2 [menu $m.mSmoothing -tearoff no] + $m2 add checkbutton -label X -variable Popup(xscrollsmoothing) \ + -command {$Popup(T) configure -xscrollsmoothing $Popup(xscrollsmoothing)} + $m2 add checkbutton -label Y -variable Popup(yscrollsmoothing) \ + -command {$Popup(T) configure -yscrollsmoothing $Popup(yscrollsmoothing)} + $m add cascade -label "Scroll Smoothing" -menu $m2 + + set m2 [menu $m.mSelectMode -tearoff no] + foreach mode [list browse extended multiple single] { + $m2 add radiobutton -label $mode -variable Popup(selectmode) -value $mode \ + -command {$Popup(T) configure -selectmode $Popup(selectmode)} + } + $m add cascade -label Selectmode -menu $m2 + + set m2 [menu $m.mShow -tearoff no] + $m2 add checkbutton -label "Buttons" -variable Popup(showbuttons) \ + -command {$Popup(T) configure -showbuttons $Popup(showbuttons)} + $m2 add checkbutton -label "Header" -variable Popup(showheader) \ + -command {$Popup(T) configure -showheader $Popup(showheader)} + $m2 add checkbutton -label "Lines" -variable Popup(showlines) \ + -command {$Popup(T) configure -showlines $Popup(showlines)} + $m2 add checkbutton -label "Root" -variable Popup(showroot) \ + -command {$Popup(T) configure -showroot $Popup(showroot)} + $m2 add checkbutton -label "Root Button" -variable Popup(showrootbutton) \ + -command {$Popup(T) configure -showrootbutton $Popup(showrootbutton)} + $m2 add checkbutton -label "Root Child Buttons" -variable Popup(showrootchildbuttons) \ + -command {$Popup(T) configure -showrootchildbuttons $Popup(showrootchildbuttons)} + $m2 add checkbutton -label "Root Child Lines" -variable Popup(showrootlines) \ + -command {$Popup(T) configure -showrootlines $Popup(showrootlines)} + $m add cascade -label Show -menu $m2 + + set m2 [menu $m.mSpan -tearoff no] + $m add cascade -label Span -menu $m2 + + $m add checkbutton -label "Use Theme" -variable Popup(usetheme) \ + -command {$Popup(T) configure -usetheme $Popup(usetheme)} + + return +} + +proc MakeHeaderPopup {T} { + set m [menu $T.mColumn -tearoff no] + + ### Header + + set m1 [menu $m.mHeader -tearoff no] + $m add cascade -label "Header" -menu $m1 + + $m1 add checkbutton -label "Visible" -variable Popup(header,visible) \ + -command [list eval $T header configure \$Popup(header) -visible \$Popup(header,visible)] + + set m2 [menu $m1.mDnD -tearoff no] + $m1 add cascade -label "Drag and Drop" -menu $m2 + $m2 add checkbutton -label "Draw" -variable Popup(header,drag,draw) \ + -command [list eval $T header dragconfigure \$Popup(header) -draw \$Popup(header,drag,draw)] + $m2 add checkbutton -label "Enable" -variable Popup(header,drag,enable) \ + -command [list eval $T header dragconfigure \$Popup(header) -enable \$Popup(header,drag,enable)] + + ### Header column + + set m1 [menu $m.mHeaderColumn -tearoff no] + $m add cascade -label "Header Column" -menu $m1 + + set m2 [menu $m1.mArrow -tearoff no] + $m1 add cascade -label Arrow -menu $m2 + $m2 add radiobutton -label "None" -variable Popup(arrow) -value none \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrow none} + $m2 add radiobutton -label "Up" -variable Popup(arrow) -value up \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrow up} + $m2 add radiobutton -label "Down" -variable Popup(arrow) -value down \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrow down} + $m2 add separator + $m2 add radiobutton -label "Side Left" -variable Popup(arrow,side) -value left \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowside left} + $m2 add radiobutton -label "Side Right" -variable Popup(arrow,side) -value right \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowside right} + $m2 add separator + $m2 add radiobutton -label "Gravity Left" -variable Popup(arrow,gravity) -value left \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowgravity left} + $m2 add radiobutton -label "Gravity Right" -variable Popup(arrow,gravity) -value right \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -arrowgravity right} + + $m1 add checkbutton -label "Button" -variable Popup(button) \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -button $Popup(button)} + + set m2 [menu $m1.mJustify -tearoff no] + $m1 add cascade -label "Justify" -menu $m2 + $m2 add radiobutton -label "Left" -variable Popup(header,justify) -value left \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -justify left} + $m2 add radiobutton -label "Center" -variable Popup(header,justify) -value center \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -justify center} + $m2 add radiobutton -label "Right" -variable Popup(header,justify) -value right \ + -command {$Popup(T) header configure $Popup(header) $Popup(column) -justify right} + + set m2 [menu $m1.mSpan -tearoff no] + $m1 add cascade -label Span -menu $m2 + + ### Tree column + $m add command -label "Column" + + return +} + +proc MakeHeaderSubmenu {T H parentMenu} { + + ### Header + + set m1 [menu $parentMenu.mHeader$H -tearoff no] + + $m1 add checkbutton -label "Visible" -variable Popup(header,visible,$H) \ + -command [list eval $T header configure $H -visible \$Popup(header,visible,$H)] + + return $m1 +} + +proc MakeColumnSubmenu {T C parentMenu {menuName ""}} { + + ### Tree-column +if 1 { + if {$menuName ne ""} { + set m1 [menu $parentMenu.mColumn$menuName -tearoff no] + } else { + set m1 [menu $parentMenu.mColumn$C -tearoff no] + } +} else { + set m1 $parentMenu.mColumn$C + $m1 delete 0 end +} + $m1 add checkbutton -label "Expand" -variable Popup(column,expand,$C) \ + -command [list eval $T column configure $C -expand \$Popup(column,expand,$C)] + + set m2 [menu $m1.mItemJustify -tearoff no] + $m1 add cascade -label "Item Justify" -menu $m2 + $m2 add radiobutton -label "Left" -variable Popup(column,itemjustify,$C) -value left \ + -command [list $T column configure $C -itemjustify left] + $m2 add radiobutton -label "Center" -variable Popup(column,itemjustify,$C) -value center \ + -command [list $T column configure $C -itemjustify center] + $m2 add radiobutton -label "Right" -variable Popup(column,itemjustify,$C) -value right \ + -command [list $T column configure $C -itemjustify right] + $m2 add radiobutton -label "Unspecified" -variable Popup(column,itemjustify,$C) -value none \ + -command [list $T column configure $C -itemjustify {}] + + set m2 [menu $m1.mJustify -tearoff no] + $m1 add cascade -label "Justify" -menu $m2 + $m2 add radiobutton -label "Left" -variable Popup(column,justify,$C) -value left \ + -command [list $T column configure $C -justify left] + $m2 add radiobutton -label "Center" -variable Popup(column,justify,$C) -value center \ + -command [list $T column configure $C -justify center] + $m2 add radiobutton -label "Right" -variable Popup(column,justify,$C) -value right \ + -command [list $T column configure $C -justify right] + + set m2 [menu $m1.mLock -tearoff no] + $m1 add cascade -label Lock -menu $m2 + $m2 add radiobutton -label "Left" -variable Popup(column,lock,$C) -value left \ + -command [list $T column configure $C -lock left] + $m2 add radiobutton -label "None" -variable Popup(column,lock,$C) -value none \ + -command [list $T column configure $C -lock none] + $m2 add radiobutton -label "Right" -variable Popup(column,lock,$C) -value right \ + -command [list $T column configure $C -lock right] + + $m1 add checkbutton -label "Resize" -variable Popup(column,resize,$C) \ + -command [list eval $T column configure $C -resize \$Popup(column,resize,$C)] + $m1 add checkbutton -label "Squeeze" -variable Popup(column,squeeze,$C) \ + -command [list eval $T column configure $C -squeeze \$Popup(column,squeeze,$C)] + $m1 add checkbutton -label "Tree Column" -variable Popup(column,treecolumn,$C) \ + -command [list eval $T configure -treecolumn "\[expr {\$Popup(column,treecolumn,$C) ? $C : {}}\]"] + $m1 add checkbutton -label "Visible" -variable Popup(column,visible,$C) \ + -command [list eval $T column configure $C -visible \$Popup(column,visible,$C) \; \ + TreeCtrl::TryEvent $T DemoColumnVisibility {} [list C $C] ] + + return $m1 +} + +proc AddBindTag {w tag} { + + if {[lsearch -exact [bindtags $w] $tag] == -1} { + bindtags $w [concat [bindtags $w] $tag] + } + foreach child [winfo children $w] { + AddBindTag $child $tag + } + return +} + +MakeMainWindow + +InitPics sky feather + +proc ShowPopup {T x y X Y} { + global Popup + set Popup(T) $T + $T identify -array id $x $y + if {$id(where) ne ""} { + if {$id(where) eq "header"} { + set H $id(header) + set C $id(column) + set Popup(header) $H + set Popup(column) $C + set Popup(arrow) [$T header cget $H $C -arrow] + set Popup(arrow,side) [$T header cget $H $C -arrowside] + set Popup(arrow,gravity) [$T header cget $H $C -arrowgravity] + set Popup(button) [$T header cget $H $C -button] + set Popup(header,justify) [$T header cget $H $C -justify] + set Popup(header,visible) [$T header cget $H -visible] + + set Popup(header,drag,draw) [$T header dragcget $H -draw] + set Popup(header,drag,enable) [$T header dragcget $H -enable] + + set Popup(column,expand,$C) [$T column cget $C -expand] + set Popup(column,resize,$C) [$T column cget $C -resize] + set Popup(column,squeeze,$C) [$T column cget $C -squeeze] + set Popup(column,itemjustify,$C) [$T column cget $C -itemjustify] + if {$Popup(column,itemjustify,$C) eq ""} { set Popup(column,itemjustify) none } + set Popup(column,justify,$C) [$T column cget $C -justify] + set Popup(column,lock,$C) [$T column cget $C -lock] + set Popup(column,treecolumn,$C) [expr {[$T column id tree] eq $C}] + $T.mColumn delete "Column" + destroy $T.mColumn.mColumnX + set m1 [MakeColumnSubmenu $T $C $T.mColumn "X"] + $T.mColumn add cascade -label "Column" -menu $m1 + + set m $T.mColumn.mHeaderColumn.mSpan + $m delete 0 end + if {[$T column compare $C == tail]} { + $m add checkbutton -label 1 -variable Popup(span) + set Popup(span) 1 + } else { + set lock [$T column cget $C -lock] + set last [expr {[$T column order "last lock $lock"] - [$T column order $C] + 1}] + for {set i 1} {$i <= $last} {incr i} { + set break [expr {!(($i - 1) % 20)}] + $m add radiobutton -label $i -command "$T header span $H $C $i" \ + -variable Popup(span) -value $i -columnbreak $break + } + set Popup(span) [$T header span $H $C] + } + + tk_popup $T.mColumn $X $Y + return + } + } + set menu $T.mTree + set m $menu.mCollapse + $m delete 0 end + $m add command -label "All" -command {$Popup(T) item collapse all} + if {$id(where) eq "item"} { + set item $id(item) + $m add command -label "Item $item" -command "$T item collapse $item" + $m add command -label "Item $item (recurse)" -command "$T item collapse $item -recurse" + } + set m $menu.mExpand + $m delete 0 end + $m add command -label "All" -command {$Popup(T) item expand all} + if {$id(where) eq "item"} { + set item $id(item) + $m add command -label "Item $item" -command "$T item expand $item" + $m add command -label "Item $item (recurse)" -command "$T item expand $item -recurse" + } + foreach option {data display displaydelay enable span textlayout} { + set Popup(debug,$option) [$T debug cget -$option] + } + set Popup(bgimg) [$T cget -backgroundimage] + set Popup(bgimganchor) [$T cget -bgimageanchor] + set Popup(bgimgopaque) [$T cget -bgimageopaque] + set Popup(bgimgscrollx) [string trim [$T cget -bgimagescroll] y] + set Popup(bgimgscrolly) [string trim [$T cget -bgimagescroll] x] + set Popup(bgimgtilex) [string trim [$T cget -bgimagetile] y] + set Popup(bgimgtiley) [string trim [$T cget -bgimagetile] x] + if {$Popup(bgimg) eq ""} { set Popup(bgimg) none } + set Popup(bgmode) [$T cget -backgroundmode] + set Popup(buttontracking) [$T cget -buttontracking] + set Popup(columnresizemode) [$T cget -columnresizemode] + set Popup(doublebuffer) [$T cget -doublebuffer] + set Popup(linestyle) [$T cget -linestyle] + set Popup(orient) [$T cget -orient] + set Popup(selectmode) [$T cget -selectmode] + set Popup(xscrollsmoothing) [$T cget -xscrollsmoothing] + set Popup(yscrollsmoothing) [$T cget -yscrollsmoothing] + set Popup(showbuttons) [$T cget -showbuttons] + set Popup(showheader) [$T cget -showheader] + set Popup(showlines) [$T cget -showlines] + set Popup(showroot) [$T cget -showroot] + set Popup(showrootbutton) [$T cget -showrootbutton] + set Popup(showrootchildbuttons) [$T cget -showrootchildbuttons] + set Popup(showrootlines) [$T cget -showrootlines] + + set m $menu.mColumns + eval destroy [winfo children $m] + $m delete 0 end + foreach C [$T column list] { + set break [expr {!([$T column order $C] % 20)}] + set m1 [MakeColumnSubmenu $T $C $m] +# set m1 [menu $m.mColumn$C -postcommand [list PostColumnSubmenu $T $C $m]] + $m add cascade -menu $m1 -columnbreak $break \ + -label "Column $C \"[$T column cget $C -text]\" \[[$T column cget $C -image]\]" + + set Popup(column,expand,$C) [$T column cget $C -expand] + set Popup(column,justify,$C) [$T column cget $C -justify] + set Popup(column,itemjustify,$C) [$T column cget $C -itemjustify] + if {$Popup(column,itemjustify,$C) eq ""} { set Popup(column,itemjustify,$C) none } + set Popup(column,lock,$C) [$T column cget $C -lock] + set Popup(column,squeeze,$C) [$T column cget $C -squeeze] + set Popup(column,visible,$C) [$T column cget $C -visible] + set Popup(treecolumn,$C) no + if {[$T column id tree] ne ""} { + set Popup(treecolumn,$C) [$T column compare [$T column id tree] == $C] + } + } + + set m $menu.mHeaders + eval destroy [winfo children $m] + $m delete 0 end + foreach H [$T header id all] { + set m1 [MakeHeaderSubmenu $T $H $m] + $m add cascade -menu $m1 -label "Header $H" + set Popup(header,visible,$H) [$T header cget $H -visible] + } + + set m $menu.mItemWrap + $m delete 0 end + $m add command -label "All Off" -command {$Popup(T) item configure all -wrap off} + $m add command -label "All On" -command {$Popup(T) item configure all -wrap on} + if {$id(where) eq "item"} { + set item $id(item) + if {[$T item cget $item -wrap]} { + $m add command -label "Item $item Off" -command "$T item configure $item -wrap off" + } else { + $m add command -label "Item $item On" -command "$T item configure $item -wrap on" + } + } + + set m $menu.mSpan + $m delete 0 end + if {$id(where) eq "item" && $id(column) ne ""} { + set item $id(item) + set column $id(column) + set lock [$T column cget $column -lock] + for {set i 1} {$i <= [$T column order "last lock $lock"] - [$T column order $column] + 1} {incr i} { + set break [expr {!(($i - 1) % 20)}] + $m add radiobutton -label $i -command "$T item span $item $column $i" \ + -variable Popup(span) -value $i -columnbreak $break + } + set Popup(span) [$T item span $item $column] + } else { + $m add command -label "no item column" -state disabled + } + + set Popup(usetheme) [$T cget -usetheme] + tk_popup $menu $X $Y + return +} + +# Allow "scan" bindings +if {$::thisPlatform eq "windows"} { + bind [DemoList] { } +} + +# +# List of demos +# +proc InitDemoList {} { + global DemoCmd + global DemoFile + + set t .f1.t + $t element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $t element create e2 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + $t style create s1 + $t style elements s1 {e2 e1} + # Tk listbox has linespace + 1 height + $t style layout s1 e2 -union [list e1] -ipadx 2 -ipady {0 1} -iexpand e + + $t column configure C0 -itemstyle s1 + + # "Picture Catalog" DemoPictureCatalog + # "Picture Catalog 2" DemoPictureCatalog2 + # "Folder Contents (Vertical)" DemoExplorerFilesV + foreach {label command file} [list \ + "Random $::RandomN Items" DemoRandom random.tcl \ + "Random $::RandomN Items, Button Images" DemoRandom2 random.tcl \ + "Outlook Express (Folders)" DemoOutlookFolders outlook-folders.tcl \ + "Outlook Express (Newsgroup)" DemoOutlookNewsgroup outlook-newgroup.tcl \ + "Explorer (Details, Win98)" DemoExplorerDetails explorer.tcl \ + "Explorer (Details, Win7)" DemoExplorerDetailsWin7 explorer.tcl \ + "Explorer (List)" DemoExplorerList explorer.tcl \ + "Explorer (Large icons, Win98)" DemoExplorerLargeIcons explorer.tcl \ + "Explorer (Large icons, Win7)" DemoExplorerLargeIconsWin7 explorer.tcl \ + "Explorer (Small icons)" DemoExplorerSmallIcons explorer.tcl \ + "Internet Options" DemoInternetOptions www-options.tcl \ + "Help Contents" DemoHelpContents help.tcl \ + "Layout" DemoLayout layout.tcl \ + "MailWasher" DemoMailWasher mailwasher.tcl \ + "Bitmaps" DemoBitmaps bitmaps.tcl \ + "iMovie" DemoIMovie imovie.tcl \ + "iMovie (Wrap)" DemoIMovieWrap imovie.tcl \ + "Firefox Privacy" DemoFirefoxPrivacy firefox.tcl \ + "Textvariable" DemoTextvariable textvariable.tcl \ + "Big List" DemoBigList biglist.tcl \ + "Column Spanning" DemoSpan span.tcl \ + "My Computer" DemoMyComputer mycomputer.tcl \ + "Column Locking" DemoColumnLock column-lock.tcl \ + "Gradients" DemoGradients gradients.tcl \ + "Gradients II" DemoGradients2 gradients2.tcl \ + "Gradients III" DemoGradients3 gradients3.tcl \ + "Headers" DemoHeaders headers.tcl \ + "Table" DemoTable table.tcl \ + ] { + set item [$t item create] + $t item lastchild root $item + # $t item style set $item C0 s1 + $t item text $item C0 $label + set DemoCmd($item) $command + set DemoFile($item) $file + } + $t yview moveto 0.0 + return +} + +InitDemoList + +proc TimerStart {} { + if {[info tclversion] < 8.5} { + return [set ::gStartTime [clock clicks -milliseconds]] + } + return [set ::gStartTime [clock microseconds]] +} + +proc TimerStop {{startTime ""}} { + if {[info tclversion] < 8.5} { + set endTime [clock clicks -milliseconds] + if {$startTime eq ""} { set startTime $::gStartTime } + return [format "%.2g" [expr {($endTime - $startTime) / 1000.0}]] + } + set endTime [clock microseconds] + if {$startTime eq ""} { set startTime $::gStartTime } + return [format "%.2g" [expr {($endTime - $startTime) / 1000000.0}]] +} + +proc DemoSet {namespace file} { + DemoClear + TimerStart + uplevel #0 ${namespace}::Init [DemoList] + dbwin "set list in [TimerStop] seconds\n" + [DemoList] xview moveto 0 + [DemoList] yview moveto 0 + update + DisplayStylesInList + SourceWindow::ShowSource $file + catch { + if {[winfo ismapped .styleEditor]} { + StyleEditor::SetListOfStyles + } + } + AddBindTag [DemoList] TagIdentify + return +} + +.f1.t notify bind .f1.t { + if {%c == 1} { + set item [%T selection get 0] + DemoSet $DemoCmd($item) $DemoFile($item) + } +} + +proc DisplayStylesInList {} { + + set T [DemoList] + set t .f4.t + + # Create elements and styles the first time this is called + if {[llength [$t style names]] == 0} { + $t element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $t element create e2 text -fill [list $::SystemHighlightText {selected focus} "" {selected !focus} blue {}] + $t element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + + $t style create s1 + $t style elements s1 {e3 e1} + $t style layout s1 e3 -union [list e1] -ipadx 1 -ipady {0 1} + + $t style create s2 + $t style elements s2 {e3 e1 e2} + $t style layout s2 e1 -padx {0 4} + $t style layout s2 e3 -union [list e1 e2] -ipadx 1 -ipady {0 1} + } + + # Clear the list + $t item delete all + + # One item for each element in the demo list + foreach elem [lsort -dictionary [$T element names]] { + set item [$t item create -button yes -open no] + $t item style set $item C0 s1 + $t item text $item C0 "Element $elem ([$T element type $elem])" + + # One item for each configuration option for this element + foreach list [$T element configure $elem] { + lassign $list name x y default current + set item2 [$t item create] + if {[string equal $default $current]} { + $t item style set $item2 C0 s1 + $t item element configure $item2 C0 e1 -text [list $name $current] + } else { + $t item style set $item2 C0 s2 + $t item element configure $item2 C0 e1 -text $name + e2 -text [list $current] + } + $t item lastchild $item $item2 + } + $t item lastchild root $item + } + + # One item for each style in the demo list + foreach style [lsort -dictionary [$T style names]] { + set item [$t item create -button yes -open no] + $t item style set $item C0 s1 + $t item text $item C0 "Style $style" + + # One item for each element in the style + foreach elem [$T style elements $style] { + set item2 [$t item create -button yes -open no] + $t item style set $item2 C0 s1 + $t item text $item2 C0 "Element $elem ([$T element type $elem])" + + # One item for each layout option for this element in this style + foreach {option value} [$T style layout $style $elem] { + set item3 [$t item create] + # $t item hasbutton $item3 no + $t item style set $item3 C0 s1 + $t item text $item3 C0 [list $option $value] + $t item lastchild $item2 $item3 + } + $t item lastchild $item $item2 + } + $t item lastchild root $item + } + + $t xview moveto 0 + $t yview moveto 0 + return +} + +proc DisplayStylesInItem {item} { + + set T [DemoList] + set t .f3.t + $t column configure C0 -text "Styles in item [$T item id $item]" + + # Create elements and styles the first time this is called + if {[llength [$t style names]] == 0} { + $t element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $t element create e2 text -fill [list $::SystemHighlightText {selected focus} "" {selected !focus} blue {}] + $t element create e3 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + + $t style create s1 + $t style elements s1 {e3 e1} + $t style layout s1 e3 -union [list e1] -ipadx {1 2} -ipady {0 1} + + $t style create s2 + $t style elements s2 {e3 e1 e2} + $t style layout s2 e1 -padx {0 4} + $t style layout s2 e3 -union [list e1 e2] -ipadx 1 -ipady {0 1} + } + + # Clear the list + $t item delete all + + # One item for each item-column + foreach style [$T item style set $item] column [$T column list] { + set item2 [$t item create -open no] + $t item style set $item2 C0 s1 + if {$style ne ""} { + $t item element configure $item2 C0 e1 \ + -text "Column $column: Style $style" + } else { + $t item element configure $item2 C0 e1 \ + -text "Column $column: no style" + } + + # One item for each element in this style + if {[string length $style]} { + set button 0 + foreach elem [$T item style elements $item $column] { + set button 1 + set item3 [$t item create -button yes -open no] + $t item style set $item3 C0 s1 + $t item element configure $item3 C0 e1 \ + -text "Element $elem ([$T element type $elem])" + + # One item for each configuration option in this element + foreach list [$T item element configure $item $column $elem] { + lassign $list name x y default current + set item4 [$t item create] + set masterDefault [$T element cget $elem $name] + set sameAsMaster [string equal $masterDefault $current] + if {!$sameAsMaster && ![string length $current]} { + set sameAsMaster 1 + set current $masterDefault + } + + if {$sameAsMaster} { + $t item style set $item4 C0 s1 + $t item element configure $item4 C0 e1 -text "$name [list $current]" + } else { + $t item style set $item4 C0 s2 + $t item element configure $item4 C0 e1 -text $name + e2 -text [list $current] + } + $t item lastchild $item3 $item4 + } + $t item lastchild $item2 $item3 + } + if {$button} { + $t item configure $item2 -button yes + } + } + $t item lastchild root $item2 + } + $t xview moveto 0 + $t yview moveto 0 + + return +} + +# When one item is selected in the demo list, display the styles in that item. +# See DemoClear for why the tag "DontDelete" is used. +set DisplayStylesInItem(item) "" +set MouseIsDown 0 +bind [DemoList] { + set MouseIsDown 1 +} +bind [DemoList] { + set MouseIsDown 0 + if {$DisplayStylesInItem(item) ne ""} { + DisplayStylesInItem $DisplayStylesInItem(item) + set DisplayStylesInItem(item) "" + } +} +[DemoList] notify bind DontDelete { + if {%c == 1} { + if {$MouseIsDown} { + set DisplayStylesInItem(item) [%T selection get 0] + } else { + DisplayStylesInItem [%T selection get 0] + } + } +} + +# Move columns when ColumnDrag-receive is generated. +# See DemoClear for why the tag "DontDelete" is used. +[DemoList] notify bind DontDelete { + %T column move %C %b +} + +proc DemoClear {} { + + set T [DemoList] + + # Delete all the items (except the root item, it never gets deleted). + $T item delete all + + # Delete all the headers (except the first header, it never gets deleted). + $T header delete all + + # Clear all bindings on the demo list added by the previous demo. + # The bindings are removed from the tag $T only. For those + # bindings that should not be deleted we use the tag DontDelete. + # DontDelete is not a special name it just needs to be different + # than $T. + $T notify unbind $T + + # Clear all run-time states + eval $T header state undefine [$T header state names] + eval $T item state undefine [$T item state names] + + # Clear the styles-in-item list + .f3.t item delete all + + # Delete columns in demo list + $T column delete all + + # Delete all styles in demo list + eval $T style delete [$T style names] + + # Delete all elements in demo list + eval $T element delete [$T element names] + + # Delete -window windows + foreach child [winfo children $T] { + if {[string equal $child $T.mTree] || [string equal $child $T.mColumn]} continue + destroy $child + } + + # Restore defaults to marquee + $T marquee configure -fill {} -outline {} -outlinewidth 1 + + # Delete gradients + eval $T gradient delete [$T gradient names] + + $T item configure root -button no -wrap no + $T item expand root + + # Restore header defaults + foreach spec [$T header configure 0] { + if {[llength $spec] == 2} continue + lassign $spec name x y default current + $T header configure all $name $default + } + + # Restore some happy defaults to the demo list + foreach spec [$T configure] { + if {[llength $spec] == 2} continue + lassign $spec name x y default current + $T configure $name $default + } + $T configure -background white + $T configure -borderwidth [expr {$::tileFull ? 0 : 6}] + $T configure -font DemoFont + if {[Platform unix]} { + $T configure -headerfont DemoFont + } + $T configure -highlightthickness [expr {$::tileFull ? 0 : 3}] + $T configure -relief ridge + + switch -- [$T theme platform] { + visualstyles { + $T theme setwindowtheme "" + } + } + + # Restore defaults to the tail column + foreach spec [$T column configure tail] { + if {[llength $spec] == 2} continue + lassign $spec name x y default current + $T column configure tail $name $default + } + + # Enable drag-and-drop column reordering. This also requires the + # event be installed. + $T header dragconfigure -enable yes + $T header dragconfigure all -enable yes -draw yes + + # Re-active the column drag-and-drop binding in case the previous demo + # deactivated it. + $T notify configure DontDelete -active yes + + # Restore default bindings to the demo list + bindtags $T [list $T TreeCtrl [winfo toplevel $T] all DisplayStylesInItemBindTag] + + catch {destroy $T.entry} + catch {destroy $T.text} + + return +} + +# +# Demo: Picture catalog +# +proc DemoPictureCatalog {} { + + set T [DemoList] + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode multiple -orient horizontal -wrap window \ + -yscrollincrement 50 -showheader no + + $T column create + + $T element create elemTxt text -fill {SystemHighlightText {selected focus}} + $T element create elemSelTxt rect -fill {SystemHighlight {selected focus}} + $T element create elemSelImg rect -outline {SystemHighlight {selected focus}} \ + -outlinewidth 4 + $T element create elemImg rect -fill gray -width 80 -height 120 + + set S [$T style create STYLE -orient vertical] + $T style elements $S {elemSelImg elemImg elemSelTxt elemTxt} + $T style layout $S elemSelImg -union elemImg -ipadx 6 -ipady 6 + $T style layout $S elemSelTxt -union elemTxt + $T style layout $S elemImg -pady {0 6} + + for {set i 1} {$i <= 10} {incr i} { + set I [$T item create] + $T item style set $I 0 $S + $T item text $I 0 "Picture #$i" + $T item lastchild root $I + } + + return +} + +# +# Demo: Picture catalog +# +proc DemoPictureCatalog2 {} { + + set T [DemoList] + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode multiple -orient horizontal -wrap window \ + -yscrollincrement 50 -showheader no + + $T column create + + $T element create elemTxt text -fill {SystemHighlightText {selected focus}} \ + -justify left -wrap word -lines 3 + $T element create elemSelTxt rect -fill {SystemHighlight {selected focus}} + $T element create elemSelImg rect -outline {SystemHighlight {selected focus}} \ + -outlinewidth 4 + $T element create elemImg rect -fill gray + + set S [$T style create STYLE -orient vertical] + $T style elements $S {elemSelImg elemImg elemSelTxt elemTxt} + $T style layout $S elemSelImg -union elemImg \ + -ipadx 6 -ipady 6 + $T style layout $S elemSelTxt -union elemTxt + $T style layout $S elemImg -pady {0 6} + $T style layout $S elemImg -expand n + $T style layout $S elemTxt -expand s + + for {set i 1} {$i <= 10} {incr i} { + set I [$T item create] + $T item style set $I 0 $S + $T item text $I 0 "This is\nPicture\n#$i" + $T item element configure $I 0 elemImg -width [expr int(20 + rand() * 80)] \ + -height [expr int(20 + rand() * 120)] + $T item lastchild root $I + } + + return +} + + + + +proc CursorWindow {} { + set w .cursors + if {[winfo exists $w]} { + destroy $w + } + toplevel $w + set c [canvas $w.canvas -background white -width [expr {50 * 10}] \ + -highlightthickness 0 -borderwidth 0] + pack $c -expand yes -fill both + set cursors { + X_cursor + arrow + based_arrow_down + based_arrow_up + boat + bogosity + bottom_left_corner + bottom_right_corner + bottom_side + bottom_tee + box_spiral + center_ptr + circle + clock + coffee_mug + cross + cross_reverse + crosshair + diamond_cross + dot + dotbox + double_arrow + draft_large + draft_small + draped_box + exchange + fleur + gobbler + gumby + hand1 + hand2 + heart + icon + iron_cross + left_ptr + left_side + left_tee + leftbutton + ll_angle + lr_angle + man + middlebutton + mouse + pencil + pirate + plus + question_arrow + right_ptr + right_side + right_tee + rightbutton + rtl_logo + sailboat + sb_down_arrow + sb_h_double_arrow + sb_left_arrow + sb_right_arrow + sb_up_arrow + sb_v_double_arrow + shuttle + sizing + spider + spraycan + star + target + tcross + top_left_arrow + top_left_corner + top_right_corner + top_side + top_tee + trek + ul_angle + umbrella + ur_angle + watch + xterm + } + set col 0 + set row 0 + foreach cursor $cursors { + set x [expr {$col * 50}] + set y [expr {$row * 40}] + $c create rectangle $x $y [expr {$x + 50}] [expr {$y + 40}] \ + -fill gray90 -outline black -width 2 -tags $cursor.rect + $c create text [expr {$x + 50 / 2}] [expr {$y + 4}] -text $cursor \ + -anchor n -width 42 -tags $cursor.text + if {[incr col] == 10} { + set col 0 + incr row + } + $c bind $cursor.rect " + $c configure -cursor $cursor + $c itemconfigure $cursor.rect -fill linen + " + $c bind $cursor.rect " + $c configure -cursor {} + $c itemconfigure $cursor.rect -fill gray90 + " + $c bind $cursor.text " + $c configure -cursor $cursor + " + $c bind $cursor.text " + $c configure -cursor {} + " + } + $c configure -height [expr {($row + 1) * 40}] + return +} + +# A little screen magnifier +if {[llength [info commands loupe]]} { + + namespace eval LoupeWindow { + variable Priv + set Priv(zoom) 2 + set Priv(x) 0 + set Priv(y) 0 + set Priv(auto) 1 + set Priv(afterId) "" + set Priv(image) ::LoupeWindow::Image + set Priv(delay) 500 + } + + proc LoupeWindow::After {} { + variable Priv + set x [winfo pointerx .] + set y [winfo pointery .] + if {$Priv(auto) || ($Priv(x) != $x) || ($Priv(y) != $y)} { + set w [image width $Priv(image)] + set h [image height $Priv(image)] + loupe $Priv(image) $x $y $w $h $Priv(zoom) + set Priv(x) $x + set Priv(y) $y + } + set Priv(afterId) [after $Priv(delay) LoupeWindow::After] + return + } + + proc LoupeWindow::Init {} { + variable Priv + set w [toplevel .loupe] + wm title $w "TreeCtrl Magnifier" + wm withdraw $w + if {[Platform macintosh macosx]} { + wm geometry $w +6+30 + } else { + wm geometry $w -0+0 + } + image create photo $Priv(image) -width 280 -height 150 + pack [label $w.label -image $Priv(image) -borderwidth 1 -relief sunken] \ + -expand yes -fill both + + set f [frame $w.zoom -borderwidth 0] + radiobutton $f.r1 -text "1x" -variable ::LoupeWindow::Priv(zoom) -value 1 + radiobutton $f.r2 -text "2x" -variable ::LoupeWindow::Priv(zoom) -value 2 + radiobutton $f.r4 -text "4x" -variable ::LoupeWindow::Priv(zoom) -value 4 + radiobutton $f.r8 -text "8x" -variable ::LoupeWindow::Priv(zoom) -value 8 + pack $f.r1 $f.r2 $f.r4 $f.r8 -side left + pack $f -side bottom -anchor center + + # Resize the image with the window + bind LoupeWindow { + LoupeWindow::ResizeImage %w %h + } + bindtags $w.label [concat [bindtags .loupe] LoupeWindow] + + wm protocol $w WM_DELETE_WINDOW "LoupeWindow::ToggleWindowVisibility" + return + } + + proc LoupeWindow::ResizeImage {w h} { + variable Priv + set w [expr {$w - 2}] + set h [expr {$h - 2}] + if {$w != [$Priv(image) cget -width] || + $h != [$Priv(image) cget -height]} { + $Priv(image) configure -width $w -height $h + loupe $Priv(image) $Priv(x) $Priv(y) $w $h $Priv(zoom) + } + return + } + + proc LoupeWindow::ToggleWindowVisibility {} { + variable Priv + set w .loupe + if {![winfo exists $w]} { + LoupeWindow::Init + } + if {[winfo ismapped $w]} { + after cancel $Priv(afterId) + wm withdraw $w + } else { + After + wm deiconify $w + raise $w + } + return + } +} + +proc RandomPerfTest {} { + set ::RandomN 15000 + DemoSet DemoRandom random.tcl + [DemoList] item expand all + [DemoList] style layout styFolder elemTxtName -squeeze x + [DemoList] style layout styFile elemTxtName -squeeze x + [DemoList] elem conf elemTxtName -lines 1 + update + puts [time {[DemoList] colu conf 0 -width 160 ; update}] + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/explorer.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/explorer.tcl new file mode 100644 index 00000000..ffe2b06b --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/explorer.tcl @@ -0,0 +1,1449 @@ +# Copyright (c) 2002-2011 Tim Baker + +set Dir [file dirname [file dirname [info script]]] + +set tcshellicon 0 +set shellicon 0 + +if { $tcl_platform(platform) eq "windows" } { + lappend auto_path $treectrl_library + + set retVal [catch {package require shellicon} version] + set shellicon [expr { ! $retVal }] + if { $shellicon } { + puts "Have shellicon $version" + } else { + set retVal [catch {package require tcshellicon} version] + set tcshellicon [expr { ! $retVal }] + if { $tcshellicon } { + puts "Have tcshellicon $version" + } + } +} + +set macBitmap 0 +if {[info commands ::tk::mac::iconBitmap] ne {}} { + set macBitmap 1 +} + +namespace eval DemoExplorer {} + +proc DemoExplorer::GetIcon {fileName args} { + variable sImgCache + + set name [file nativename $fileName] + if { [llength $args] == 0 } { + set opts ",Default" + } else { + set opts "" + foreach opt $args { + append opts ",$opt" + } + } + if { [info exists sImgCache($name,$opts)] } { + # puts "Get image from cache $name" + return $sImgCache($name,$opts) + } + + set phImg [shellicon::get {*}$args $name] + set sImgCache($name,$opts) $phImg + return $phImg +} + +# DemoExplorer::SetList +# +# Gets sorted lists of directory and file names in the ::Dir directory and +# calls a script to add items to the demo list. +# +# Arguments: +# scriptDir Script to eval to add directories to the demo list. +# scriptFile Script to eval to add files to the demo list. +# scriptFollowup Script to eval after the first two. + +proc DemoExplorer::SetList {T scriptDir scriptFile {scriptFollowup ""}} { + variable Priv + global Dir + + TimerStart + set globDirs [glob -nocomplain -types d -dir $Dir *] + set secondsGlobDirs [TimerStop] + + TimerStart + set list [lsort -dictionary $globDirs] + set secondsSortDirs [TimerStop] + + if {[file dirname $Dir] ne $Dir} { + lappend globDirs ".." + set list [concat ".." $list] + } + + TimerStart + foreach file $list $scriptDir + set secondsAddDirs [TimerStop] + + $T item tag add "root children" directory + + TimerStart + set globFiles [glob -nocomplain -types f -dir $Dir *] + set secondsGlobFiles [TimerStop] + + TimerStart + set list [lsort -dictionary $globFiles] + set secondsSortFiles [TimerStop] + + TimerStart + foreach file $list $scriptFile + set secondsAddFiles [TimerStop] + + set gd $secondsGlobDirs + set sd $secondsSortDirs + set ad $secondsAddDirs + set gf $secondsGlobFiles + set sf $secondsSortFiles + set af $secondsAddFiles + puts "dirs([llength $globDirs]) glob/sort/add $gd/$sd/$ad\nfiles([llength $globFiles]) glob/sort/add $gf/$sf/$af" + + # Accessing a private variable in the filelist-bindings.tcl library script. + # Most of the code in that file should have been a part of this demo. + set ::TreeCtrl::Priv(DirCnt,$T) [llength $globDirs] + + eval $scriptFollowup + + # Double-clicking a directory displays its contents. + set Priv(scriptDir) $scriptDir + set Priv(scriptFile) $scriptFile + set Priv(scriptFollowup) $scriptFollowup + puts "Images: [llength [image names]]" + + return +} + +# DemoExplorer::SetBindings +# +# Sets some bindings on the demo list. +# +# Arguments: +# T The demo list. +# win7 Boolean, true if Windows 7 behavior is desired. + +proc DemoExplorer::SetBindings {T {win7 0}} { + + variable Priv + + # Double-clicking a directory displays its contents. + bind DemoExplorer { + DemoExplorer::DoubleButton1 %W %x %y + } + + TreeCtrl::FileListEmulateWin7 $T $win7 + + if {$win7} { + set Priv(prev) "" + $T notify bind $T { + if {[lsearch -exact %i $DemoExplorer::Priv(prev)] != -1} { + set DemoExplorer::Priv(prev) "" + } + } + bind DemoExplorerWin7 { + DemoExplorer::Motion %W %x %y + } + bind DemoExplorerWin7 { + DemoExplorer::Motion %W -1 -1 + } + } + + return +} + +# +# Demo: explorer files +# +namespace eval DemoExplorerDetails { + proc Init {T} { DemoExplorer::InitDetails $T } +} +proc DemoExplorer::InitDetails {T} { + + variable Priv + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no -itemheight $height \ + -selectmode extended -xscrollincrement 20 -xscrollsmoothing yes \ + -scrollmargin 16 -xscrolldelay "500 50" -yscrolldelay "500 50" + + InitPics small-* + + # + # Create columns + # + + $T column create -text Name -tags {C0 name} -width 200 \ + -arrow up -itembackground #F7F7F7 + $T column create -text Size -tags size -justify right -width 60 \ + -arrowside left -arrowgravity right + $T column create -text Type -tags type -width 120 + $T column create -text Modified -tags modified -width 120 + + # Demonstration of per-state column options and configure "all" + $T column configure all -background {gray90 active gray70 normal gray50 pressed} + + # + # Create elements + # + if {$::tcshellicon} { + $T element create elemImg shellicon -size small + } elseif {$::macBitmap} { + $T element create elemImg bitmap + } else { + $T element create elemImg image -image {small-folderSel {selected} small-folder {}} + } + $T element create txtName text -fill [list $::SystemHighlightText {selected focus}] \ + -lines 1 + $T element create txtType text -lines 1 + $T element create txtSize text -datatype integer -format "%dKB" -lines 1 + $T element create txtDate text -datatype time -format "%d/%m/%y %I:%M %p" -lines 1 + $T element create elemRectSel rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] -showfocus yes + + # + # Create styles using the elements + # + + # column 0: image + text + set S [$T style create styName -orient horizontal] + $T style elements $S {elemRectSel elemImg txtName} + $T style layout $S elemImg -padx {2 0} -expand ns + $T style layout $S txtName -squeeze x -expand ns + $T style layout $S elemRectSel -union [list txtName] -ipadx 2 -iexpand ns + + # column 1: text + set S [$T style create stySize] + $T style elements $S txtSize + $T style layout $S txtSize -padx 6 -squeeze x -expand ns + + # column 2: text + set S [$T style create styType] + $T style elements $S txtType + $T style layout $S txtType -padx 6 -squeeze x -expand ns + + # column 3: text + set S [$T style create styDate] + $T style elements $S txtDate + $T style layout $S txtDate -padx 6 -squeeze x -expand ns + + # List of lists: {column style element ...} specifying text elements + # the user can edit. + TreeCtrl::SetEditable $T { + {name styName txtName} + } + + # List of lists: {column style element ...} specifying elements + # the user can click on. + TreeCtrl::SetSensitive $T { + {name styName elemImg txtName} + } + + # List of lists: {column style element ...} specifying elements + # the user can select with the selection rectangle. Empty means + # use the same list passed to TreeCtrl::SetSensitive. + TreeCtrl::SetSensitiveMarquee $T {} + + # List of lists: {column style element ...} specifying elements + # added to the drag image when dragging selected items + TreeCtrl::SetDragImage $T { + {name styName elemImg txtName} + } + + # During editing, hide the text and selection-rectangle elements. + $T item state define edit + $T style layout styName txtName -draw {no edit} + $T style layout styName elemRectSel -draw {no edit} + $T notify bind $T { + %T item state set %I ~edit + } + $T notify bind $T { + %T item element configure %I %C %E -text %t + } + $T notify bind $T { + %T item state set %I ~edit + } + + # + # Create items and assign styles + # + + set scriptDir { + set item [$T item create -open no] + $T item style set $item name styName type styType modified styDate + $T item element configure $item \ + name txtName -text [file tail $file] , \ + type txtType -text "Folder" , \ + modified txtDate -data [file mtime $file] + if {$::tcshellicon} { + # The tcshellicon extension fails randomly (by putting GDB into the + # background!?) if the filename is not valid. MSDN says "relative + # paths are valid" but perhaps that is misinformation. + if {$file eq ".."} { set file [file dirname $::Dir] } + $T item element configure $item \ + name elemImg -path $file + } elseif {$::shellicon} { + $T item element configure $item \ + name elemImg -image [list [GetIcon $file]] + } elseif {$::macBitmap} { + if {$file eq ".."} { set file [file dirname $::Dir] } + ::tk::mac::iconBitmap $file 16 16 -file $file + $T item element configure $item \ + name elemImg -bitmap [list $file] + } + $T item lastchild root $item + } + + set scriptFile { + set item [$T item create -open no] + $T item style set $item name styName size stySize type styType modified styDate + switch [file extension $file] { + .dll { set img small-dll } + .exe { set img small-exe } + .txt { set img small-txt } + default { set img small-file } + } + set type [string toupper [file extension $file]] + if {$type ne ""} { + set type "[string range $type 1 end] " + } + append type "File" + if {$::tcshellicon} { + $T item element configure $item \ + name elemImg -path $file + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } elseif {$::shellicon} { + set shellImg [GetIcon $file] + set shellSel [GetIcon $file -selected] + $T item element configure $item \ + name elemImg -image [list $shellSel {selected} $shellImg {}] + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } elseif {$::macBitmap} { + if {$file eq ".."} { set file [file dirname $::Dir] } + ::tk::mac::iconBitmap $file 16 16 -file $file + $T item element configure $item \ + name elemImg -bitmap [list $file] + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } else { + $T item element configure $item \ + name elemImg -image [list ${img}Sel {selected} $img {}] + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } + $T item lastchild root $item + } + + SetList $T $scriptDir $scriptFile + SetBindings $T + + set Priv(sortColumn) name + set Priv(sortColor) #F7F7F7 + $T notify bind $T { DemoExplorer::HeaderInvoke %T %C } + + bindtags $T [list $T DemoExplorer TreeCtrlFileList TreeCtrl [winfo toplevel $T] all] + + return +} + +# DemoExplorer::HeaderInvoke +# +# This procedure is called to handle the event generated by +# the treectrl.tcl library script. Items in the demo list are sorted +# according to the column involved. +# +# Arguments: +# T The demo list. +# C The column whose header was clicked. + +proc DemoExplorer::HeaderInvoke {T C} { + variable Priv + if {[$T column compare $C == $Priv(sortColumn)]} { + if {[$T column cget $Priv(sortColumn) -arrow] eq "down"} { + set order -increasing + set arrow up + } else { + set order -decreasing + set arrow down + } + } else { + if {[$T column cget $Priv(sortColumn) -arrow] eq "down"} { + set order -decreasing + set arrow down + } else { + set order -increasing + set arrow up + } + $T column configure $Priv(sortColumn) -arrow none -itembackground {} + set Priv(sortColumn) $C + } + $T column configure $C -arrow $arrow -itembackground $Priv(sortColor) + set dirCount $::TreeCtrl::Priv(DirCnt,$T) + set fileCount [expr {[$T item count] - 1 - $dirCount}] + set lastDir [expr {$dirCount - 1}] + switch -glob [$T column cget $C -tags] { + *name* { + if {$dirCount} { + $T item sort root $order -last "root child $lastDir" -column $C -dictionary + } + if {$fileCount} { + $T item sort root $order -first "root child $dirCount" -column $C -dictionary + } + } + size { + if {$fileCount} { + $T item sort root $order -first "root child $dirCount" -column $C -integer -column name -dictionary + } + } + type { + if {$fileCount} { + $T item sort root $order -first "root child $dirCount" -column $C -dictionary -column name -dictionary + } + } + modified { + if {$dirCount} { + $T item sort root $order -last "root child $lastDir" -column $C -integer -column name -dictionary + } + if {$fileCount} { + $T item sort root $order -first "root child $dirCount" -column $C -integer -column name -dictionary + } + } + } + return +} + +namespace eval DemoExplorerLargeIcons { + proc Init {T} { DemoExplorer::InitLargeIcons $T } +} +proc DemoExplorer::InitLargeIcons {T} { + + # Item height is 32 for icon, 4 padding, 3 lines of text + set itemHeight [expr {32 + 4 + [font metrics [$T cget -font] -linespace] * 3}] + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode extended -wrap window -orient horizontal \ + -itemheight $itemHeight -itemwidth 75 -showheader no \ + -scrollmargin 16 -xscrolldelay "500 50" -yscrolldelay "500 50" + + InitPics big-* + + # + # Create columns + # + + $T column create -tags C0 + + # + # Create elements + # + + if {$::tcshellicon} { + $T element create elemImg shellicon -size large + } elseif {$::macBitmap} { + $T element create elemImg bitmap + } else { + $T element create elemImg image -image {big-folderSel {selected} big-folder {}} + } + $T element create elemTxt text -fill [list $::SystemHighlightText {selected focus}] \ + -justify center -lines 1 -width 71 -wrap word + $T element create elemSel rect -fill [list $::SystemHighlight {selected focus} gray {selected}] -showfocus yes + + # + # Create styles using the elements + # + + # image + text + set S [$T style create STYLE -orient vertical] + $T style elements $S {elemSel elemImg elemTxt} + $T style layout $S elemImg -expand we + $T style layout $S elemTxt -pady {4 0} -squeeze x -expand we + $T style layout $S elemSel -union [list elemTxt] -ipadx 2 + + # List of lists: {column style element ...} specifying text elements + # the user can edit + TreeCtrl::SetEditable $T { + {C0 STYLE elemTxt} + } + + # List of lists: {column style element ...} specifying elements + # the user can click on. + TreeCtrl::SetSensitive $T { + {C0 STYLE elemImg elemTxt} + } + + # List of lists: {column style element ...} specifying elements + # the user can select with the selection rectangle. Empty means + # use the same list passed to TreeCtrl::SetSensitive. + TreeCtrl::SetSensitiveMarquee $T {} + + # List of lists: {column style element ...} specifying elements + # added to the drag image when dragging selected items. + TreeCtrl::SetDragImage $T { + {C0 STYLE elemImg elemTxt} + } + + # During editing, hide the text and selection-rectangle elements. + $T item state define edit + $T style layout STYLE elemTxt -draw {no edit} + $T style layout STYLE elemSel -draw {no edit} + $T notify bind $T { + %T item state set %I ~edit + } + $T notify bind $T { + %T item element configure %I %C %E -text %t + } + $T notify bind $T { + %T item state set %I ~edit + } + + # + # Create items and assign styles + # + + set scriptDir { + set item [$T item create -open no] + $T item style set $item C0 STYLE + $T item text $item C0 [file tail $file] + if {$::tcshellicon} { + # The tcshellicon extension fails randomly (by putting GDB into the + # background!?) if the filename is not valid. MSDN says "relative + # paths are valid" but perhaps that is misinformation. + if {$file eq ".."} { set file [file dirname $::Dir] } + $T item element configure $item C0 \ + elemImg -path $file + } elseif {$::shellicon} { + $T item element configure $item C0 \ + elemImg -image [list [GetIcon $file -large]] + } elseif {$::macBitmap} { + if {$file eq ".."} { set file [file dirname $::Dir] } + ::tk::mac::iconBitmap $file 32 32 -file $file + $T item element configure $item C0 \ + elemImg -bitmap [list $file] + } + $T item lastchild root $item + } + + set scriptFile { + set item [$T item create -open no] + $T item style set $item C0 STYLE + switch [file extension $file] { + .dll { set img big-dll } + .exe { set img big-exe } + .txt { set img big-txt } + default { set img big-file } + } + set type [string toupper [file extension $file]] + if {$type ne ""} { + set type "[string range $type 1 end] " + } + append type "File" + if {$::tcshellicon} { + $T item element configure $item C0 \ + elemImg -path $file + \ + elemTxt -text [file tail $file] + } elseif { $::shellicon } { + set shellImg [GetIcon $file -large] + set shellSel [GetIcon $file -large -selected] + $T item element configure $item C0 \ + elemImg -image [list $shellSel {selected} $shellImg {}] + \ + elemTxt -text [file tail $file] + } elseif {$::macBitmap} { + ::tk::mac::iconBitmap $file 32 32 -file $file + $T item element configure $item C0 \ + elemImg -bitmap [list $file] + \ + elemTxt -text [file tail $file] + } else { + $T item element configure $item C0 \ + elemImg -image [list ${img}Sel {selected} $img {}] + \ + elemTxt -text [file tail $file] + } + $T item lastchild root $item + } + + SetList $T $scriptDir $scriptFile + SetBindings $T + + $T activate [$T item id "root firstchild"] + + $T notify bind $T { + if {[%T item compare %p != root]} { + %T item element configure %p C0 elemTxt -lines {} + } + if {[%T item compare %c != root]} { + %T item element configure %c C0 elemTxt -lines 3 + } + } + $T item element configure active C0 elemTxt -lines 3 + + bindtags $T [list $T DemoExplorer TreeCtrlFileList TreeCtrl [winfo toplevel $T] all] + + return +} + +# Tree is horizontal, wrapping occurs at right edge of window, each item +# is as wide as the smallest needed multiple of 110 pixels +namespace eval DemoExplorerSmallIcons { + proc Init {T} { DemoExplorer::InitSmallIcons $T } +} +proc DemoExplorer::InitSmallIcons {T} { + InitList $T + $T configure -orient horizontal \ + -itemwidthmultiple 110 -itemwidthequal no + return +} + +# Tree is vertical, wrapping occurs at bottom of window, each range has the +# same width (as wide as the longest item), xscrollincrement is by range +namespace eval DemoExplorerList { + proc Init {T} { DemoExplorer::InitList $T } +} +proc DemoExplorer::InitList {T} { + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no -itemheight $height \ + -selectmode extended -wrap window -showheader no \ + -scrollmargin 16 -xscrolldelay "500 50" -yscrolldelay "500 50" \ + -itemwidthequal yes + + InitPics small-* + + # + # Create columns + # + + $T column create -tags C0 + + # + # Create elements + # + + if {$::tcshellicon} { + $T element create elemImg shellicon -size small + } elseif {$::macBitmap} { + $T element create elemImg bitmap + } else { + $T element create elemImg image -image {small-folderSel {selected} small-folder {}} + } + $T element create elemTxt text -fill [list $::SystemHighlightText {selected focus}] \ + -lines 1 + $T element create elemSel rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] -showfocus yes + + # + # Create styles using the elements + # + + # image + text + set S [$T style create STYLE] + $T style elements $S {elemSel elemImg elemTxt} + $T style layout $S elemImg -expand ns + $T style layout $S elemTxt -squeeze x -expand ns -padx {2 0} + $T style layout $S elemSel -union [list elemTxt] -iexpand ns -ipadx 2 + + # List of lists: {column style element ...} specifying text elements + # the user can edit + TreeCtrl::SetEditable $T { + {C0 STYLE elemTxt} + } + + # List of lists: {column style element ...} specifying elements + # the user can click on. + TreeCtrl::SetSensitive $T { + {C0 STYLE elemImg elemTxt} + } + + # List of lists: {column style element ...} specifying elements + # the user can select with the selection rectangle. Empty means + # use the same list passed to TreeCtrl::SetSensitive. + TreeCtrl::SetSensitiveMarquee $T {} + + # List of lists: {column style element ...} specifying elements + # added to the drag image when dragging selected items. + TreeCtrl::SetDragImage $T { + {C0 STYLE elemImg elemTxt} + } + + # During editing, hide the text and selection-rectangle elements. + $T item state define edit + $T style layout STYLE elemTxt -draw {no edit} + $T style layout STYLE elemSel -draw {no edit} + $T notify bind $T { + %T item state set %I ~edit + } + $T notify bind $T { + %T item element configure %I %C %E -text %t + } + $T notify bind $T { + %T item state set %I ~edit + } + + # + # Create items and assign styles + # + + set scriptDir { + set item [$T item create -open no] + $T item style set $item C0 STYLE + $T item text $item C0 [file tail $file] + if {$::tcshellicon} { + # The tcshellicon extension fails randomly (by putting GDB into the + # background!?) if the filename is not valid. MSDN says "relative + # paths are valid" but perhaps that is misinformation. + if {$file eq ".."} { set file [file dirname $::Dir] } + $T item element configure $item C0 \ + elemImg -path $file + } elseif {$::shellicon} { + $T item element configure $item C0 \ + elemImg -image [list [GetIcon $file]] + } elseif {$::macBitmap} { + if {$file eq ".."} { set file [file dirname $::Dir] } + ::tk::mac::iconBitmap $file 16 16 -file $file + $T item element configure $item C0 \ + elemImg -bitmap [list $file] + } + $T item lastchild root $item + } + + set scriptFile { + set item [$T item create -open no] + $T item style set $item C0 STYLE + switch [file extension $file] { + .dll { set img small-dll } + .exe { set img small-exe } + .txt { set img small-txt } + default { set img small-file } + } + set type [string toupper [file extension $file]] + if {$type ne ""} { + set type "[string range $type 1 end] " + } + append type "File" + if {$::tcshellicon} { + $T item element configure $item C0 \ + elemImg -path $file + \ + elemTxt -text [file tail $file] + } elseif {$::shellicon} { + set shellImg [GetIcon $file] + set shellSel [GetIcon $file -selected] + $T item element configure $item C0 \ + elemImg -image [list $shellSel {selected} $shellImg {}] + \ + elemTxt -text [file tail $file] + } elseif {$::macBitmap} { + ::tk::mac::iconBitmap $file 16 16 -file $file + $T item element configure $item C0 \ + elemImg -bitmap [list $file] + \ + elemTxt -text [file tail $file] + } else { + $T item element configure $item C0 \ + elemImg -image [list ${img}Sel {selected} $img {}] + \ + elemTxt -text [file tail $file] + } + $T item lastchild root $item + } + + SetList $T $scriptDir $scriptFile + SetBindings $T + + $T activate [$T item firstchild root] + + bindtags $T [list $T DemoExplorer TreeCtrlFileList TreeCtrl [winfo toplevel $T] all] + + return +} + +# DemoExplorer::DoubleButton1 +# +# Handle the event in the demo list. If a directory +# item is double-clicked, display that directory. +# +# Arguments: +# T The demo list. +# x Widget x coordinate. +# y Widget y coordinate. + +proc DemoExplorer::DoubleButton1 {T x y} { + variable Priv + global Dir + $T identify -array id $x $y + set sensitive [TreeCtrl::IsSensitive $T $x $y] + if {[TreeCtrl::FileListEmulateWin7 $T] && [TreeCtrl::IsSensitiveMarquee $T $x $y]} { + set sensitive 1 + } + if {$sensitive} { + set item $id(item) + set column $id(column) + if {[$T item tag expr $item directory]} { + set name [$T item text $item {tag C0}] + if {$name eq ".."} { + set Dir [file dirname $Dir] + } else { + set Dir [file join $Dir $name] + } + $T item delete all + SetList $T $Priv(scriptDir) $Priv(scriptFile) $Priv(scriptFollowup) + if {![TreeCtrl::FileListEmulateWin7 $T]} { + $T activate "root firstchild" + } + $T xview moveto 0.0 + $T yview moveto 0.0 + } + } + return +} + +# DemoExplorer::DragStyleInit +# +# NOT USED. +# Experimental code to create a style that is used with drag-and-drop + +proc DemoExplorer::DragStyleInit {} { + + set T [DemoList] + + set boxW 100 + set boxH 100 + set imgW 32 + set imgH 32 + + $T element create DragStyleElemRect rect -fill #D0ffff -width $boxW -height $boxH + $T element create DragStyleElemImg image -image big-file + $T element create DragStyleElemTxt text -text DragImage! + $T element create DragStyleElemTxtBg rect -fill white -outline black -outlinewidth 1 + + $T style create DragStyle -orient vertical + $T style elements DragStyle {DragStyleElemRect DragStyleElemImg DragStyleElemTxtBg DragStyleElemTxt} + + set cursorW 16 + $T style layout DragStyle DragStyleElemRect -detach yes + + set dx [expr {($boxW - $imgW) / 2}] + set dy [expr {($boxH - $imgH) / 2}] + $T style layout DragStyle DragStyleElemImg -detach yes -padx "$dx 0" -pady "$dy 0" + + set dx [expr {$boxW / 2 + $cursorW}] + set dy $boxH + $T style layout DragStyle DragStyleElemTxt -detach yes -padx "$dx 0" -pady "$dy 0" + + $T style layout DragStyle DragStyleElemTxtBg -union DragStyleElemTxt -ipadx 3 -ipady 2 + + $T dragimage configure -style DragStyle + + set x [expr {$boxW / 2 - 0 * $cursorW / 2}] + set y [expr {$boxH - $cursorW * 2/3}] + $T dragimage stylehotspot $x $y + + return +} + +# DemoExplorer::ConfigTransparentMarquee +# +# Configure the marquee for a modern transparent selection rectangle +# where transparent gradients are supported. +# +# Arguments: +# T The demo list. + +proc DemoExplorer::ConfigTransparentMarquee {T} { + if {!$::NativeGradients} return + if {![$T gradient native]} return + if {[winfo depth $T] < 15} return + + set outline #3399ff + set stops [list [list 0.0 #3399ff 0.3] [list 1.0 #3399ff 0.3]] + + $T gradient create G_marquee -stops $stops + $T marquee configure -fill G_marquee -outline $outline + return +} + +# +# Demo: explorer files with Windows-7-like gradients +# +namespace eval DemoExplorerDetailsWin7 { + proc Init {T} { DemoExplorer::InitDetailsWin7 $T } +} +proc DemoExplorer::InitDetailsWin7 {T} { + + variable Priv + + set height [font metrics [$T cget -font] -linespace] + if {$height < 16} { + set height 16 ; # small icon height + } + incr height 5 + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no -itemheight $height \ + -selectmode extended -xscrollincrement 20 -xscrollsmoothing yes \ + -scrollmargin 16 -xscrolldelay "500 50" -yscrolldelay "500 50" + + $T configure -canvaspadx {12 0} -canvaspady {6 0} + + InitPics small-* + + # + # Create columns + # + + $T column create -text Name -tags {C0 name} -width 200 \ + -arrow up + $T column create -text Size -tags size -justify right -width 60 \ + -arrowside left -arrowgravity right + $T column create -text Type -tags type -width 120 + $T column create -text Modified -tags modified -width 120 + + # Demonstration of per-state column options and configure "all" + $T column configure all -background {gray90 active gray70 normal gray50 pressed} + + # + # Create gradients + # + + set steps [expr {($height - 5)/2}] + $T gradient create G_mouseover -steps $steps -stops {{0.0 white} {1.0 #ebf3fd}} -orient vertical + $T gradient create G_selected_active -steps $steps -stops {{0.0 #dcebfc} {1.0 #c1dbfc}} -orient vertical + $T gradient create G_selected -steps $steps -stops {{0.0 #ebf4fe} {1.0 #cfe4fe}} -orient vertical + $T gradient create G_focusout -steps $steps -stops {{0.0 #f8f8f8} {1.0 #e5e5e5}} -orient vertical + + # With gdiplus this gives similar results + # $T gradient configure G_mouseover -stops {{0.0 SystemHighlight 0.0} {1.0 SystemHighlight 0.1}} -orient vertical + + # + # Create elements + # + + if {$::tcshellicon} { + $T element create elemImg shellicon -size small -useselected never + } elseif {$::macBitmap} { + $T element create elemImg bitmap + } else { + $T element create elemImg image -image small-folder + } + $T element create txtName text -lines 1 + $T element create txtType text -lines 1 -fill #6d6d6d + $T element create txtSize text -datatype integer -format "%dKB" -lines 1 -fill #6d6d6d + $T element create txtDate text -datatype time -format "%d/%m/%y %I:%M %p" -lines 1 -fill #6d6d6d + + $T item state define mouseover + $T item state define openW + $T item state define openE + $T item state define openWE + + $T element create elemRectGradient rect \ + -fill [list G_selected_active {selected mouseover} \ + G_focusout {selected !focus} \ + G_selected_active {selected active} \ + G_selected selected \ + G_mouseover mouseover] + + $T element create elemRectOutline rect -rx 1 \ + -open [list we openWE w openW e openE] \ + -outline [list #7da2ce {selected mouseover} \ + #d9d9d9 {selected !focus} \ + #7da2ce selected \ + #7da2ce {active focus} \ + #b8d6fb mouseover] -outlinewidth 1 + + # + # Create styles using the elements + # + + # column 0: image + text + set S [$T style create styName -orient horizontal] + $T style elements $S {elemRectGradient elemRectOutline elemImg txtName} + $T style layout $S elemRectGradient -detach yes -padx {2 0} -pady {2 3} -iexpand xy + $T style layout $S elemRectOutline -detach yes -pady {0 1} -iexpand xy + $T style layout $S elemImg -padx {6 2} -pady {2 3} -expand ns + $T style layout $S txtName -pady {2 3} -squeeze x -expand ns + + # column 1: text + set S [$T style create stySize] + $T style elements $S {elemRectGradient elemRectOutline txtSize} + $T style layout $S elemRectGradient -detach yes -padx 0 -pady {2 3} -iexpand xy + $T style layout $S elemRectOutline -detach yes -pady {0 1} -iexpand xy + $T style layout $S txtSize -padx 6 -pady {2 3} -squeeze x -expand ns + + # column 2: text + set S [$T style create styType] + $T style elements $S {elemRectGradient elemRectOutline txtType} + $T style layout $S elemRectGradient -detach yes -padx 0 -pady {2 3} -iexpand xy + $T style layout $S elemRectOutline -detach yes -pady {0 1} -iexpand xy + $T style layout $S txtType -padx 6 -pady {2 3} -squeeze x -expand ns + + # column 3: text + set S [$T style create styDate] + $T style elements $S {elemRectGradient elemRectOutline txtDate} + $T style layout $S elemRectGradient -detach yes -padx {0 2} -pady {2 3} -iexpand xy + $T style layout $S elemRectOutline -detach yes -pady {0 1} -iexpand xy + $T style layout $S txtDate -padx 6 -pady {2 3} -squeeze x -expand ns + + # List of lists: {column style element ...} specifying text elements + # the user can edit. + TreeCtrl::SetEditable $T { + {name styName txtName} + } + + # List of lists: {column style element ...} specifying elements + # the user can click on. + TreeCtrl::SetSensitive $T { + {name styName elemImg txtName} + {size stySize txtSize} + {type styType txtType} + {modified styDate txtDate} + } + + # List of lists: {column style element ...} specifying elements + # the user can select with the selection rectangle. Empty means + # use the same list passed to TreeCtrl::SetSensitive. + TreeCtrl::SetSensitiveMarquee $T { + {name styName elemRectOutline elemImg txtName} + {size stySize elemRectOutline txtSize} + {type styType elemRectOutline txtType} + {modified styDate elemRectOutline txtDate} + } + + # List of lists: {column style element ...} specifying elements + # added to the drag image when dragging selected items. + TreeCtrl::SetDragImage $T { + {name styName elemImg txtName} + } + + # During editing, hide the text + $T item state define edit + $T style layout styName txtName -draw {no edit} + $T notify bind $T { + %T item state set %I ~edit + } + $T notify bind $T { + %T item element configure %I %C %E -text %t + } + $T notify bind $T { + %T item state set %I ~edit + } + + # + # Create items and assign styles + # + + set scriptDir { + set item [$T item create -open no] + $T item style set $item name styName size stySize type styType modified styDate + $T item element configure $item \ + name txtName -text [file tail $file] , \ + type txtType -text "Folder" , \ + modified txtDate -data [file mtime $file] + if {$::tcshellicon} { + # The tcshellicon extension fails randomly (by putting GDB into the + # background!?) if the filename is not valid. MSDN says "relative + # paths are valid" but perhaps that is misinformation. + if {$file eq ".."} { set file [file dirname $::Dir] } + $T item element configure $item \ + name elemImg -path $file + } elseif {$::shellicon} { + $T item element configure $item \ + name elemImg -image [list [GetIcon $file]] + } elseif {$::macBitmap} { + if {$file eq ".."} { set file [file dirname $::Dir] } + ::tk::mac::iconBitmap $file 16 16 -file $file + $T item element configure $item \ + name elemImg -bitmap [list $file] + } + $T item lastchild root $item + } + + set scriptFile { + set item [$T item create -open no] + $T item style set $item name styName size stySize type styType modified styDate + switch [file extension $file] { + .dll { set img small-dll } + .exe { set img small-exe } + .txt { set img small-txt } + default { set img small-file } + } + set type [string toupper [file extension $file]] + if {$type ne ""} { + set type "[string range $type 1 end] " + } + append type "File" + if {$::tcshellicon} { + $T item element configure $item \ + name elemImg -path $file + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } elseif { $::shellicon } { + set shellImg [GetIcon $file] + $T item element configure $item \ + name elemImg -image $shellImg + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } elseif {$::macBitmap} { + ::tk::mac::iconBitmap $file 16 16 -file $file + $T item element configure $item \ + name elemImg -bitmap [list $file] + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } else { + $T item element configure $item \ + name elemImg -image $img + txtName -text [file tail $file] , \ + size txtSize -data [expr {[file size $file] / 1024 + 1}] , \ + type txtType -text $type , \ + modified txtDate -data [file mtime $file] + } + $T item lastchild root $item + } + + set scriptFollowup { + DemoExplorer::DetailsWin7_FixItemStyles $T + } + + SetList $T $scriptDir $scriptFile $scriptFollowup + SetBindings $T true + + ConfigTransparentMarquee $T + + # Fix the display when a column is dragged + $T notify bind $T { + %T column move %C %b + DemoExplorer::DetailsWin7_FixItemStyles %T + } + + # Fix the display when a column's visibility changes + $T notify bind $T { + DemoExplorer::DetailsWin7_FixItemStyles %T + } + + set Priv(sortColumn) name + set Priv(sortColor) "" + $T notify bind $T { DemoExplorer::HeaderInvoke %T %C } + + bindtags $T [list $T DemoExplorerWin7 DemoExplorer TreeCtrlFileList TreeCtrl [winfo toplevel $T] all] + + return +} + +# DemoExplorer::DetailsWin7_FixItemStyles +# +# Configures item states and style layouts so that selection rectangles +# appear to span multiple columns. +# +# Arguments: +# T The demo list. + +proc DemoExplorer::DetailsWin7_FixItemStyles {T} { + foreach C [$T column id "visible !tail"] { + if {[$T column compare $C == "first visible"]} { + set padx {2 0} + set state openE + } elseif {[$T column compare $C == "last visible"]} { + set padx {0 2} + set state openW + } else { + set padx {0 0} + set state openWE + } + switch -glob [$T column cget $C -tags] { + *name* { + set style styName + set padelem elemImg + set padelemX {6 2} + } + size { + set style stySize + } + type { + set style styType + } + modified { + set style styDate + } + } + $T item state forcolumn all $C [list !openW !openE !openWE $state] + $T style layout $style elemRectGradient -padx $padx + } + return +} + +namespace eval DemoExplorerLargeIconsWin7 { + proc Init {T} { DemoExplorer::InitLargeIconsWin7 $T } +} +proc DemoExplorer::InitLargeIconsWin7 {T} { + + # Item height is 2 + 32 for icon + 4 pad + 3 lines of text + 3 + set fontHeight [font metrics [$T cget -font] -linespace] + set itemHeight [expr {2 + 32 + 4 + $fontHeight * 3 + 3}] + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode extended -wrap window -orient horizontal \ + -itemwidth 74 -showheader no -yscrollsmoothing yes \ + -scrollmargin 16 -yscrolldelay "500 200" + + $T configure -canvaspadx {15 0} -canvaspady {6 0} -itemgapx 1 -itemgapy 1 + + InitPics big-* + + # + # Create columns + # + + $T column create -tags C0 + + # + # Create gradients + # + + set steps 8 + $T gradient create G_mouseover -steps $steps -stops {{0.0 white} {1.0 #ebf3fd}} -orient vertical + $T gradient create G_selected_active -steps $steps -stops {{0.0 #dcebfc} {1.0 #c1dbfc}} -orient vertical + $T gradient create G_selected -steps $steps -stops {{0.0 #ebf4fe} {1.0 #cfe4fe}} -orient vertical + $T gradient create G_focusout -steps $steps -stops {{0.0 #f8f8f8} {1.0 #e5e5e5}} -orient vertical + + # + # Create elements + # + + $T item state define mouseover + $T item state define openW + $T item state define openE + $T item state define openWE + + $T element create elemRectGradient rect \ + -fill [list G_selected_active {selected mouseover} \ + G_focusout {selected !focus} \ + G_selected_active {selected active} \ + G_selected selected \ + G_mouseover mouseover] + + $T element create elemRectOutline rect -rx 3 \ + -open [list we openWE w openW e openE] \ + -outline [list #7da2ce {selected mouseover} \ + #d9d9d9 {selected !focus} \ + #7da2ce selected \ + #7da2ce {active focus} \ + #b8d6fb mouseover] -outlinewidth 1 + + if {$::tcshellicon} { + $T element create elemImg shellicon -size large -useselect never + } elseif {$::macBitmap} { + $T element create elemImg bitmap + } else { + $T element create elemImg image -image big-folder + } + $T element create elemTxt text \ + -justify center -lines 3 -width 70 -wrap word + + # + # Create styles using the elements + # + + # image + text + set S [$T style create STYLE -orient vertical] + $T style elements $S {elemRectGradient elemRectOutline elemImg elemTxt} + $T style layout $S elemRectGradient -union {elemImg elemTxt} -iexpand we + $T style layout $S elemRectOutline -union elemRectGradient -ipadx 2 -ipady 2 + $T style layout $S elemImg -expand we + $T style layout $S elemTxt -pady {4 0} -squeeze x -expand we + + # List of lists: {column style element ...} specifying text elements + # the user can edit. + TreeCtrl::SetEditable $T { + {C0 STYLE elemTxt} + } + + # List of lists: {column style element ...} specifying elements + # the user can click on. + TreeCtrl::SetSensitive $T { + {C0 STYLE elemImg elemTxt} + } + + # List of lists: {column style element ...} specifying elements + # the user can select with the selection rectangle. Empty means + # use the same list passed to TreeCtrl::SetSensitive. + TreeCtrl::SetSensitiveMarquee $T { + {C0 STYLE elemRectOutline elemImg elemTxt} + } + + # List of lists: {column style element ...} specifying elements + # added to the drag image when dragging selected items. + TreeCtrl::SetDragImage $T { + {C0 STYLE elemImg elemTxt} + } + + # During editing, hide the text and selection-rectangle elements. + $T item state define edit + $T style layout STYLE elemTxt -draw {no edit} + $T notify bind $T { + %T item state set %I ~edit + } + $T notify bind $T { + %T item element configure %I %C %E -text %t + } + $T notify bind $T { + %T item state set %I ~edit + } + + # + # Create items and assign styles + # + + set scriptDir { + set item [$T item create -open no] + $T item style set $item C0 STYLE + $T item text $item C0 [file tail $file] + if {$::tcshellicon} { + # The tcshellicon extension fails randomly (by putting GDB into the + # background!?) if the filename is not valid. MSDN says "relative + # paths are valid" but perhaps that is misinformation. + if {$file eq ".."} { set file [file dirname $::Dir] } + $T item element configure $item C0 \ + elemImg -path $file + } elseif {$::shellicon} { + $T item element configure $item C0 \ + elemImg -image [list [GetIcon $file -large]] + } elseif {$::macBitmap} { + if {$file eq ".."} { set file [file dirname $::Dir] } + ::tk::mac::iconBitmap $file 32 32 -file $file + $T item element configure $item C0 \ + elemImg -bitmap [list $file] + } + $T item lastchild root $item + } + + set scriptFile { + set item [$T item create -open no] + $T item style set $item C0 STYLE + switch [file extension $file] { + .dll { set img big-dll } + .exe { set img big-exe } + .txt { set img big-txt } + default { set img big-file } + } + set type [string toupper [file extension $file]] + if {$type ne ""} { + set type "[string range $type 1 end] " + } + append type "File" + if {$::tcshellicon} { + $T item element configure $item C0 \ + elemImg -path $file + \ + elemTxt -text [file tail $file] + } elseif { $::shellicon } { + set shellImg [GetIcon $file -large] + $T item element configure $item C0 \ + elemImg -image [list $shellImg] + \ + elemTxt -text [file tail $file] + } elseif {$::macBitmap} { + ::tk::mac::iconBitmap $file 32 32 -file $file + $T item element configure $item C0 \ + elemImg -bitmap [list $file] + \ + elemTxt -text [file tail $file] + } else { + $T item element configure $item C0 \ + elemImg -image [list $img] + \ + elemTxt -text [file tail $file] + } + $T item lastchild root $item + } + + SetList $T $scriptDir $scriptFile + SetBindings $T true + + ConfigTransparentMarquee $T + + $T activate [$T item id "root firstchild"] + + $T notify bind $T { + if {[%T item compare %p != root]} { + %T item element configure %p C0 elemTxt -lines {} + } + if {[%T item compare %c != root]} { + %T item element configure %c C0 elemTxt -lines 3 + } + } + $T item element configure active C0 elemTxt -lines 3 + + bindtags $T [list $T DemoExplorerWin7 DemoExplorer TreeCtrlFileList TreeCtrl [winfo toplevel $T] all] + + return +} + +# DemoExplorer::Motion +# +# Handle and events. In the Windows 7 demos, this highlights +# the item under the mouse pointer. +# +# Arguments: +# T The demo list. +# x Widget x coordinate. +# y Widget y coordinate. + +proc DemoExplorer::Motion {T x y} { + variable Priv + + # Check for Win7 'mouseover' state + if {[lsearch -exact [$T item state names] mouseover] == -1} return + + if {[info exists TreeCtrl::Priv(buttonMode)] && $TreeCtrl::Priv(buttonMode) ne ""} { + set x [set y -1] + } + + $T identify -array id $x $y + if {$id(where) eq ""} { + # nothing + } elseif {$id(where) eq "header"} { + # nothing + } elseif {$id(where) eq "item" && $id(element) ne ""} { + set item $id(item) + if {$item ne $Priv(prev)} { + if {$Priv(prev) ne ""} { + $T item state set $Priv(prev) !mouseover + } + $T item state set $item mouseover + set Priv(prev) $item + } + return + } + if {$Priv(prev) ne ""} { + if {[$T item id $Priv(prev)] ne ""} { + $T item state set $Priv(prev) !mouseover + } + set Priv(prev) "" + } + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/firefox.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/firefox.tcl new file mode 100644 index 00000000..ef3b12f8 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/firefox.tcl @@ -0,0 +1,479 @@ +# Copyright (c) 2005-2011 Tim Baker + +namespace eval DemoFirefoxPrivacy {} + +proc DemoFirefoxPrivacy::Init {T} { + + variable Priv + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons yes -showlines no \ + -selectmode extended -xscrollincrement 20 -showheader yes +if {$::clip} { + $T configure -xscrollincrement 4 -yscrollincrement 4 +} else { + # Hide the borders because child windows appear on top of them + $T configure -borderwidth 0 -highlightthickness 0 +} + # + # Create columns + # + + # Create 2 new images for the button sort arrow + if {[lsearch -exact [image names] arrow-up] == -1} { + + set color #ACA899 ; # WinXP arrow color + + set img arrow-down + image create photo $img + $img put [list [string repeat "$color " 9]] -to 0 0 + $img put [list [string repeat "$color " 7]] -to 1 1 + $img put [list [string repeat "$color " 5]] -to 2 2 + $img put [list [string repeat "$color " 3]] -to 3 3 + $img put [list [string repeat "$color " 1]] -to 4 4 + + set img arrow-up + image create photo $img + $img put [list [string repeat "$color " 1]] -to 4 0 + $img put [list [string repeat "$color " 3]] -to 3 1 + $img put [list [string repeat "$color " 5]] -to 2 2 + $img put [list [string repeat "$color " 7]] -to 1 3 + $img put [list [string repeat "$color " 9]] -to 0 4 + } + + $T column create -expand yes -arrowimage {arrow-down !up arrow-up {}} \ + -arrow up -arrowpadx {10 2} -textlines 0 -tags C0 \ + -text "This is a multi-line column title\nwith an image for the arrow" + + $T configure -treecolumn C0 + + # This binding toggles the sort arrow + $T notify bind $T { + if {[%T column cget %C -arrow] eq "up"} { + %T column configure %C -arrow down + } else { + %T column configure %C -arrow up + } + } + + # + # Create elements + # + + $T element create eWindow window +if {$::clip} { $T element configure eWindow -clip yes } + $T element create eText1 text -font [list DemoFontBold] + $T element create eRectTop rect -outline black -fill #FFFFCC \ + -outlinewidth 1 -open s + $T element create eRectBottom rect -outline black -fill #FFFFCC \ + -outlinewidth 1 -open n + + # Destroy the window when the element is deleted. Could also bind to the + # event. + $T element configure eWindow -destroy yes + + # + # Create styles using the elements + # + + set S [$T style create styCategory -orient horizontal] + $T style elements $S {eRectTop eText1 eWindow} + $T style layout $S eRectTop -detach yes -indent no -iexpand xy -draw {yes open no {}} + # note: using -iexpand x so clicking in the text works better + $T style layout $S eText1 -expand ns -iexpand x -sticky w + $T style layout $S eWindow -expand ns -padx 10 -pady 6 + + set S [$T style create styFrame -orient horizontal] + $T style elements $S {eRectBottom eWindow} + $T style layout $S eRectBottom -detach yes -indent no -iexpand xy + $T style layout $S eWindow -iexpand x -squeeze x -padx {0 2} -pady {0 8} + + # + # Create items and assign styles + # + + foreach category { + "History" + "Saved Form Information" + "Saved Passwords" + "Download Manager History" + "Cookies" + "Cache"} { + set I [$T item create -button yes] + $T item style set $I C0 styCategory + $T item element configure $I C0 eText1 -text $category +if {$::clip} { + set wClip [frame $T.clip$I -background red] + set b [$::buttonCmd $wClip.b$I -text "Clear" -command "" -width 11] + $T item element configure $I C0 eWindow -window $wClip +} else { + set b [$::buttonCmd $T.b$I -text "Clear" -command "" -width 11] + $T item element configure $I C0 eWindow -window $b +} + $T item lastchild root $I + } + + set bg #FFFFCC + set textBg $bg + + if {$::tile} { + ttk::style configure DemoCheckbutton -background $bg + ttk::style layout DemoCheckbutton [ttk::style layout TCheckbutton] + } + + # History + set I [$T item create] + $T item style set $I C0 styFrame +if {$::clip} { + set wClip [frame $T.clip$I -background red] + set f [frame $wClip.f$I -borderwidth 0 -background $bg] +} else { + set f [frame $T.f$I -borderwidth 0 -background $bg] +} + label $f.l1 -background $bg -text "Remember visited pages for the last" + $::entryCmd $f.e1 -width 6 + $f.e1 insert end 20 + label $f.l2 -background $bg -text "days" -background $bg + pack $f.l1 -side left + pack $f.e1 -side left -padx 8 + pack $f.l2 -side left +if {$::clip} { + $T item element configure $I C0 eWindow -window $wClip +} else { + $T item element configure $I C0 eWindow -window $f +} + $T item lastchild "root child 0" $I + + # Saved Form Information + set I [$T item create] + $T item style set $I C0 styFrame +if {$::clip} { + set wClip [frame $T.clip$I -background red] + set f [frame $wClip.f$I -borderwidth 0 -background $bg] +} else { + set f [frame $T.f$I -borderwidth 0 -background $bg] +} + text $f.t1 -background $textBg -borderwidth 0 -highlightthickness 0 \ + -width 10 -height 1 -wrap word -cursor "" + $f.t1 insert end "Information entered in web page forms and the Search\ + Bar is saved to make filling out forms and searching faster." + bindtags $f.t1 TextWrapBindTag + if {$::tile} { + $::checkbuttonCmd $f.cb1 -text "Save information I enter in web page forms and the Search Bar" \ + -variable ::DemoFirefoxPrivacy::Priv(cbvar,$f.cb1) -style DemoCheckbutton + } else { + checkbutton $f.cb1 -background $bg -highlightthickness 0 -text "Save\ + information I enter in web page forms and the Search Bar" \ + -variable ::DemoFirefoxPrivacy::Priv(cbvar,$f.cb1) + } + set Priv(cbvar,$f.cb1) 1 + pack $f.t1 -side top -anchor w -fill x -padx {0 8} -pady {0 4} + pack $f.cb1 -side top -anchor w +if {$::clip} { + $T item element configure $I C0 eWindow -window $wClip +} else { + $T item element configure $I C0 eWindow -window $f +} + $T item lastchild "root child 1" $I + + # Saved Passwords + set I [$T item create] + $T item style set $I C0 styFrame +if {$::clip} { + set wClip [frame $T.clip$I -background red] + set f [frame $wClip.f$I -borderwidth 0 -background $bg] +} else { + set f [frame $T.f$I -borderwidth 0 -background $bg] +} + + set fLeft [frame $f.fLeft -borderwidth 0 -background $bg] + text $fLeft.t1 -background $textBg -borderwidth 0 -highlightthickness 0 \ + -width 10 -height 1 -wrap word -cursor "" + $fLeft.t1 insert end "Login information for web pages can be kept in the\ + Password Manager so that you do not need to re-enter your login\ + details every time you visit." + bindtags $fLeft.t1 TextWrapBindTag + if {$::tile} { + $::checkbuttonCmd $fLeft.cb1 -text "Remember Passwords" \ + -variable ::DemoFirefoxPrivacy::Priv(cbvar,$fLeft.cb1) -style DemoCheckbutton + } else { + checkbutton $fLeft.cb1 -background $bg -highlightthickness 0 \ + -text "Remember Passwords" -variable ::DemoFirefoxPrivacy::Priv(cbvar,$fLeft.cb1) + } + set Priv(cbvar,$fLeft.cb1) 1 + pack $fLeft.t1 -side top -expand yes -fill x -pady {0 6} + pack $fLeft.cb1 -side top -anchor w + + set fRight [frame $f.fRight -borderwidth 0 -background $bg] + $::buttonCmd $fRight.b1 -text "View Saved Passwords" + $::buttonCmd $fRight.b2 -text "Change Master Password..." + pack $fRight.b1 -side top -expand yes -fill x + pack $fRight.b2 -side top -expand yes -fill x -pady {8 0} + pack $fLeft -side left -expand yes -fill x + pack $fRight -side right -padx 12 -anchor n +if {$::clip} { + $T item element configure $I C0 eWindow -window $wClip +} else { + $T item element configure $I C0 eWindow -window $f +} + $T item lastchild "root child 2" $I + + # Download Manager History + set I [$T item create] + $T item style set $I C0 styFrame +if {$::clip} { + set wClip [frame $T.clip$I -background red] + set f [frame $wClip.f$I -borderwidth 0 -background $bg] +} else { + set f [frame $T.f$I -borderwidth 0 -background $bg] +} + text $f.t1 -background $textBg -borderwidth 0 -highlightthickness 0 \ + -width 10 -height 1 -wrap word -cursor "" + $f.t1 insert end "The Download Manager keeps track of recently downloaded files." + bindtags $f.t1 TextWrapBindTag + + set f1 [frame $f.f1 -borderwidth 0 -background $bg] + label $f1.l1 -background $bg -text "Remove files from the Download Manager:" + if {$::tile} { + ttk::combobox $f1.mb1 -values { + "Upon successful download" + "When firefox exits" + Manually + } -state readonly -width [string length "Upon successful download"] + $f1.mb1 current 2 + } else { + menubutton $f1.mb1 -indicatoron yes -menu $f1.mb1.m -text Manually \ + -width [string length "Upon successful download"] -justify left + set m [menu $f1.mb1.m -tearoff no] + foreach label { + "Upon successful download" + "When firefox exits" + Manually} { + $m add command -label $label -command [list $f1.mb1 configure\ + -text $label] + } + } + pack $f1.l1 -side left + pack $f1.mb1 -side left -padx {8 10} + pack $f.t1 -side top -expand yes -fill x -padx {0 10} + pack $f1 -side top -anchor w +if {$::clip} { + $T item element configure $I C0 eWindow -window $wClip +} else { + $T item element configure $I C0 eWindow -window $f +} + $T item lastchild "root child 3" $I + + # Cookies + set I [$T item create] + $T item style set $I C0 styFrame +if {$::clip} { + set wClip [frame $T.clip$I -background red] + set f [frame $wClip.f$I -borderwidth 0 -background $bg] +} else { + set f [frame $T.f$I -borderwidth 0 -background $bg] +} + text $f.t1 -background $textBg -borderwidth 0 -highlightthickness 0 \ + -width 10 -height 1 -wrap word -cursor "" + $f.t1 insert end "Cookies are pieces of information stored by web pages\ + on your computer. They are used to remember login information and\ + other data." + bindtags $f.t1 TextWrapBindTag + + set fLeft [frame $f.fLeft -borderwidth 0 -background $bg] + if {$::tile} { + $::checkbuttonCmd $fLeft.cb1 -style DemoCheckbutton \ + -text "Allow sites to set cookies" -variable ::DemoFirefoxPrivacy::Priv(cbvar,$fLeft.cb1) + } else { + checkbutton $fLeft.cb1 -background $bg -highlightthickness 0 \ + -text "Allow sites to set cookies" -variable ::DemoFirefoxPrivacy::Priv(cbvar,$fLeft.cb1) + } + set Priv(cbvar,$fLeft.cb1) 1 + if {$::tile} { + $::checkbuttonCmd $fLeft.cb2 -style DemoCheckbutton \ + -text "for the originating web site only" \ + -variable ::DemoFirefoxPrivacy::Priv(cbvar,$fLeft.cb2) + } else { + checkbutton $fLeft.cb2 -background $bg -highlightthickness 0 \ + -text "for the originating web site only" \ + -variable ::DemoFirefoxPrivacy::Priv(cbvar,$fLeft.cb2) + } + set Priv(cbvar,$fLeft.cb2) 0 + pack $fLeft.cb1 -side top -anchor w + pack $fLeft.cb2 -side top -anchor w -padx {20 0} + + set fRight [frame $f.fRight -borderwidth 0 -background $bg] + $::buttonCmd $fRight.b1 -text "Exceptions" + $::buttonCmd $fRight.b2 -text "View Cookies" + pack $fRight.b1 -side left -padx {0 10} + pack $fRight.b2 -side left + + set f1 [frame $fLeft.f1 -borderwidth 0 -background $bg] + label $f1.l1 -background $bg -text "Keep Cookies:" + if {$::tile} { + ttk::combobox $f1.mb1 -values { + "until they expire" + "until I close Firefox" + "ask me every time" + } -state readonly -width [string length "until I close Firefox"] + $f1.mb1 current 0 + } else { + menubutton $f1.mb1 -indicatoron yes -menu $f1.mb1.m \ + -text "until they expire" \ + -width [string length "until I close Firefox"] -justify left + set m [menu $f1.mb1.m -tearoff no] + foreach label { + "until they expire" + "until I close Firefox" + "ask me every time" + } { + $m add command -label $label -command [list $f1.mb1 configure -text $label] + } + } + pack $f1.l1 -side left + pack $f1.mb1 -side left -padx {8 0} + pack $f1 -side top -anchor w + + pack $f.t1 -side top -expand yes -fill x -padx {0 10} -pady {0 8} + pack $fLeft -side left -expand yes -fill x + pack $fRight -side right -padx 14 -anchor n +if {$::clip} { + $T item element configure $I C0 eWindow -window $wClip +} else { + $T item element configure $I C0 eWindow -window $f +} + $T item lastchild "root child 4" $I + + # Cache + set I [$T item create] + $T item style set $I C0 styFrame +if {$::clip} { + set wClip [frame $T.clip$I -background red] + set f [frame $wClip.f$I -borderwidth 0 -background $bg] +} else { + set f [frame $T.f$I -borderwidth 0 -background $bg] +} + text $f.t1 -background $textBg -borderwidth 0 -highlightthickness 0 \ + -width 10 -height 1 -wrap word -cursor "" + $f.t1 insert end "Pages you view are stored in the cache for quicker\ + viewing later on." + bindtags $f.t1 TextWrapBindTag + set f1 [frame $f.f1 -borderwidth 0 -background $bg] + label $f1.l1 -background $bg -text "Use up to:" + $::entryCmd $f1.e1 -width 10 + $f1.e1 insert end 50000 + label $f1.l2 -background $bg -text "KB of disk space for the cache." \ + -background $bg + pack $f1.l1 -side left + pack $f1.e1 -side left -padx 8 + pack $f1.l2 -side left + pack $f.t1 -side top -expand yes -fill x -padx {0 10} + pack $f1 -side top -anchor w +if {$::clip} { + $T item element configure $I C0 eWindow -window $wClip +} else { + $T item element configure $I C0 eWindow -window $f +} + $T item lastchild "root child 5" $I + + # This binding configures the -height option of a Text widget to the + # number of lines it is displaying + bind TextWrapBindTag { + scan [textlayout [%W cget -font] [%W get 1.0 "end - 1 chars"] \ + -width %w] "%%d %%d" width height + set height [expr {$height / [font metrics [%W cget -font] -linespace]}] + if {$height != [%W cget -height]} { + %W configure -height $height + } + } + + # This binding collapses all items before expanding a new one + $T notify bind $T { + %T item collapse all + } + $T item collapse all + + + bind DemoFirefoxPrivacy { + if {[lindex [%W identify %x %y] 0] eq "header"} { + TreeCtrl::DoubleButton1 %W %x %y + } else { + DemoFirefoxPrivacy::Button1 %W %x %y + } + break + } + bind DemoFirefoxPrivacy { + DemoFirefoxPrivacy::Button1 %W %x %y + break + } + bind DemoFirefoxPrivacy { + # noop + } + bind DemoFirefoxPrivacy { + # noop + } + bind DemoFirefoxPrivacy { + DemoFirefoxPrivacy::Motion %W %x %y + } + bind DemoFirefoxPrivacy { + DemoFirefoxPrivacy::Motion %W %x %y + } + + if {$::tile} { + bind DemoFirefoxPrivacy <> { + ttk::style configure DemoCheckbutton -background #FFFFCC + ttk::style layout DemoCheckbutton [ttk::style layout TCheckbutton] + } + } + + set Priv(prev) "" + bindtags $T [list $T DemoFirefoxPrivacy TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoFirefoxPrivacy::Button1 {w x y} { + variable ::TreeCtrl::Priv + focus $w + $w identify -array id $x $y + set Priv(buttonMode) "" + if {$id(where) eq "header"} { + TreeCtrl::ButtonPress1 $w $x $y + } elseif {$id(where) eq "item"} { + set item $id(item) + # click a button + if {$id(element) eq ""} { + TreeCtrl::ButtonPress1 $w $x $y + return + } + if {$id(element) eq "eText1"} { + $w item toggle $item + DisplayStylesInItem $item + } + } + return +} + +proc DemoFirefoxPrivacy::Motion {w x y} { + variable Priv + $w identify -array id $x $y + if {$id(where) eq "item"} { + set item $id(item) + if {$id(element) eq "eText1"} { + if {$item ne $Priv(prev)} { + $w configure -cursor hand2 + set Priv(prev) $item + } + return + } + } + if {$Priv(prev) ne ""} { + $w configure -cursor "" + set Priv(prev) "" + } + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients.tcl new file mode 100644 index 00000000..d8833dbc --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients.tcl @@ -0,0 +1,352 @@ +# Copyright (c) 2010-2011 Tim Baker + +namespace eval DemoGradients {} +proc DemoGradients::Init {T} { + + if {[lsearch -exact [font names] DemoGradientFont] == -1} { + array set fontInfo [font actual [$T cget -font]] + set fontInfo(-weight) bold + eval font create DemoGradientFont [array get fontInfo] + } + + # + # Configure the treectrl widget + # + + $T configure \ + -showbuttons no -showlines no -showroot no \ + -xscrollincrement 20 -yscrollincrement 20 \ + -xscrollsmoothing yes -yscrollsmoothing yes \ + -canvaspadx 20 + + # + # Create columns + # + + for {set i 0} {$i < 6} {incr i} { + $T column create -text "Column $i" -width 100 -tags C$i + } + + # + # Define new states + # + + $T item state define openW + $T item state define openN + + # + # Create elements + # + + $T element create elemTextIntro text -font DemoGradientFont + $T element create elemText text + + $T element create elemBox rect -height 30 \ + -outline black -outlinewidth 2 -open {wn {openW openN} w openW n openN} + + # + # Create styles using the elements + # + + set S [$T style create styleIntro] + $T style elements $S elemTextIntro + $T style layout $S elemTextIntro -padx 4 -pady {3 0} -squeeze x + + set S [$T style create styleText] + $T style elements $S elemText + $T style layout $S elemText -padx 4 -pady {15 6} -squeeze x + + set S [$T style create styleBox] + $T style elements $S elemBox + $T style layout $S elemBox -iexpand x + + # + # Create items and assign styles + # + + set stops {{0.0 blue} {0.5 green} {1.0 red}} + set steps 10 + + set I [$T item create -parent root] + $T item style set $I C0 styleIntro + $T item span $I C0 6 + $T item text $I C0 "In all the examples below, each item has the same\ + style in every column painted with a gradient. Every gradient has\ + exactly the same colors. The items appear different only because of\ + the different coordinates specified for each gradient." + + # Example 1: no gradient coords specified + $T gradient create G1 -stops $stops -steps $steps + $T gradient configure G1 -left {} -right {} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 1: A single item with a single horizontal\ + gradient. The coordinates are unspecified, so the gradient brush has the\ + same bounds as each rectangle being painted\n\ + G1 -left { } -right { } -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G1 + + + # Example 2: -left {0.0 item} -right {0.5 item} + $T gradient create G2 -stops $stops -steps $steps + $T gradient configure G2 -left {0.0 item} -right {0.5 item} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 2: A single item with a single horizontal\ + gradient. The right side of the gradient is set to 1/2 the width\ + of the item, which results in the gradient pattern being tiled when\ + painting the other half of the item.\n\ + G2 -left {0.0 item} -right {0.5 item} -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G2 + + + # Example 3: -left {0.0 item} -right {1.0 item} + $T gradient create G3 -stops $stops -steps $steps + $T gradient configure G3 -left {0.0 item} -right {1.0 item} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 3: A single item with a single horizontal \ + gradient. The gradient extends from the left side to the right side\ + of the item.\n\ + G3 -left {0.0 item} -right {1.0 item} -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G3 + + + # Example 4: 3 items, vertical gradient, no gradient coords specified + $T gradient create G4 -stops $stops -steps $steps -orient vertical + $T gradient configure G4 -left {} -right {} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 4: 3 items with a single vertical gradient. \ + The coordinates are unspecified, so the gradient brush has the\ + same bounds as each rectangle being painted\n\ + G4 -left { } -right { } -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G4 + + set I [$T item create -parent root] + $T item state set $I openN + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G4 + + set I [$T item create -parent root] + $T item state set $I openN + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G4 + + + # Example 5: 3 items, 3 vertical gradients + $T gradient create G5.1 -stops $stops -steps $steps -orient vertical + $T gradient configure G5.1 -left {} -right {} -top {} -bottom {3.0 item} + + $T gradient create G5.2 -stops $stops -steps $steps -orient vertical + $T gradient configure G5.2 -left {} -right {} -top {-1.0 item} -bottom {2.0 item} + + $T gradient create G5.3 -stops $stops -steps $steps -orient vertical + $T gradient configure G5.3 -left {} -right {} -top {-2.0 item} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 5: 3 items with 3 vertical gradients. Each\ + gradient uses item-relative coordinates to give the appearance of\ + a single seamless gradient.\n\ + G5.1 -left { } -right { } -top { } -bottom {3.0 item}\n\ + G5.2 -left { } -right { } -top {-1.0 item} -bottom {2.0 item}\n\ + G5.3 -left { } -right { } -top {-2.0 item} -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G5.1 + + set I [$T item create -parent root] + $T item state set $I openN + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G5.2 + + set I [$T item create -parent root] + $T item state set $I openN + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G5.3 + + + # Example 6: 3 items, 1 vertical gradient + $T gradient create G6 -stops $stops -steps $steps -orient vertical + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 6: 3 items with a single vertical gradient. \ + The -top and -bottom coordinates specify the first and third items\ + respectively. The appearance is exactly the same as the previous\ + example, but uses only 1 gradient instead of 3. The words \"I6.1\"\ + and \"I6.3\" are item -tags.\n\ + G6 -top {0.0 item I6.1} -bottom {1.0 item I6.3}" + + set I1 [$T item create -parent root -tags I6.1] + $T item state forcolumn $I1 {range 1 end} openW + $T item style set $I1 all styleBox + $T item element configure $I1 all elemBox -fill G6 + + set I2 [$T item create -parent root -tags I6.2] + $T item state set $I2 openN + $T item state forcolumn $I2 {range 1 end} openW + $T item style set $I2 all styleBox + $T item element configure $I2 all elemBox -fill G6 + + set I3 [$T item create -parent root -tags I6.3] + $T item state set $I3 openN + $T item state forcolumn $I3 {range 1 end} openW + $T item style set $I3 all styleBox + $T item element configure $I3 all elemBox -fill G6 + + $T gradient configure G6 -top {0.0 item I6.1} -bottom {1.0 item I6.3} + + + # Example 7: column-relative + $T gradient create G7 -stops $stops -steps $steps + $T gradient configure G7 -left {0.0 column} -right {1.0 column} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 7: A single item with a single horizontal\ + gradient. The gradient brush starts at the left edge of each column\ + and extends to the right edge of the same column.\n\ + G7 -left {0.0 column} -right {1.0 column} -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G7 + + + # Example 8: column-relative + $T gradient create G8 -stops $stops -steps $steps + $T gradient configure G8 -left {0.0 column} -right {1.5 column} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 8: A single item with a single horizontal\ + gradient. The gradient brush starts at the left edge of each column\ + and extends to the half-way point of the next visible column. Notice\ + that the right-most column shows all of the gradient since there\ + is no visible column to the right of it.\n\ + G8 -left {0.0 column} -right {1.5 column} -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G8 + + + # Example 9: column-relative + $T gradient create G9 -stops $stops -steps $steps + $T gradient configure G9 -left {-0.5 column} -right {1.0 column} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 9: A single item with a single horizontal\ + gradient. The gradient brush starts at the half-way point of the\ + previous visible column and extends to the right edge of each column. \ + Notice that the left-most column shows all of the gradient since there\ + is no visible column to the left of it.\n\ + G9 -left {-0.5 column} -right {1.0 column} -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G9 + + + # Example 10: column-relative + $T gradient create G10 -stops $stops -steps $steps + $T gradient configure G10 -left {0.0 column C0} -right {1.0 column C2} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 10: A single item with a single horizontal\ + gradient. The gradient brush starts at the left edge of column 0\ + and extends to the right edge of column 2. The gradient pattern is\ + tiled when painting the other half of the item. The words \"C0\" and\ + \"C2\" are column -tags.\n\ + G10 -left {0.0 column C0} -right {1.0 column C2} -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G10 + + + # Example 11: content-relative + $T gradient create G11 -stops $stops -steps $steps + $T gradient configure G11 -left {0.0 area content} -right {1.0 area content} -top {} -bottom {} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 11: A single item with a single horizontal\ + gradient. The gradient brush starts inside the left window border and\ + extends to the inside edge of the right window border (the 'content'\ + area). The gradient brush changes width as the demo window is resized.\n\ + G11 -left {0.0 area content} -right {1.0 area content} -top { } -bottom { }" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G11 + + + # Example 12: content-relative + $T gradient create G12 -stops $stops -steps $steps -orient vertical + $T gradient configure G12 -left {} -right {} -top {0.0 area content} -bottom {1.0 area content} + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 6 + $T item text $I C0 "Example 12: A single item with a single vertical\ + gradient. The gradient brush starts inside the top window border and\ + extends to the inside edge of the bottom window border (the 'content'\ + area). The gradient brush changes height as the demo window is resized,\ + and scrolling the list vertically changes which part of the gradient is\ + painted in the item.\n\ + G12 -left { } -right { } -top {0.0 area content} -bottom {1.0 area content}" + + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + $T item element configure $I all elemBox -fill G12 + + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients2.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients2.tcl new file mode 100644 index 00000000..047338b3 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients2.tcl @@ -0,0 +1,116 @@ +# Copyright (c) 2010-2011 Tim Baker + +namespace eval DemoGradients2 {} +proc DemoGradients2::Init {T} { + + # + # Configure the treectrl widget + # + + $T configure \ + -showbuttons no -showlines no -showroot no \ + -xscrollincrement 20 -yscrollincrement 20 \ + -xscrollsmoothing yes -yscrollsmoothing yes \ + + # + # Create columns + # + + for {set i 0} {$i < 6} {incr i} { + $T column create -text "Column $i" -width 100 -tags C$i + } + + set steps 25 + set stops {{0.0 "light green"} {1.0 white}} + + $T gradient create G_C0 -stops $stops -steps $steps -orient vertical + $T column configure C0 -itembackground G_C0 + + $T gradient create G_C1 -stops $stops -steps $steps -orient vertical + $T gradient configure G_C1 -top {0.0 area content} -bottom {1.0 area content} + $T column configure C1 -itembackground G_C1 + + $T gradient create G_C2 -stops $stops -steps $steps -orient vertical + $T gradient configure G_C2 -top {0.0 canvas} -bottom {1.0 canvas} + $T column configure C2 -itembackground G_C2 + + $T gradient create G_C3 -stops $stops -steps $steps -orient horizontal + $T gradient configure G_C3 -left {} -right {} + $T column configure C3 -itembackground G_C3 + + $T gradient create G_C4 -stops $stops -steps $steps -orient horizontal + $T gradient configure G_C4 -left {0.0 area content} -right {1.0 area content} + $T column configure C4 -itembackground G_C4 + + $T gradient create G_C5 -stops $stops -steps $steps -orient horizontal + $T gradient configure G_C5 -left {0.0 canvas} -right {1.0 canvas} + $T column configure C5 -itembackground G_C5 + + # + # Define new states + # + + $T item state define openW + $T item state define openN + + # + # Create elements + # + + $T element create elemTextIntro text + + $T element create elemBox rect -height 50 \ + -outline gray -outlinewidth 1 -open {wn {openW openN} w openW n openN} + + # + # Create styles using the elements + # + + $T style create styleIntro + $T style elements styleIntro elemTextIntro + $T style layout styleIntro elemTextIntro -padx 4 -pady {3 0} -squeeze x + + $T style create styleBox + $T style elements styleBox elemBox + $T style layout styleBox elemBox -iexpand x + + # + # Create items and assign styles + # + + set I [$T item create -parent root] + $T item style set $I C0 styleIntro + $T item span $I C0 6 + $T item text $I C0 "This demonstrates column -itembackground colors with gradients.\n +Column 0 has a vertical gradient with unspecified bounds, so the gradient\ + is as tall as each item.\n \ + G_C0 -top { } -bottom { }\n +Column 1 has a vertical gradient as tall as the content area. The colors\ + remain 'locked in place' as the list is scrolled up and down.\n \ + G_C1 -top {0.0 area content} -bottom {1.0 area content}\n +Column 2 has a vertical gradient as tall as the canvas. The first stop color\ + begins at the top of the first item and the last stop color ends at the\ + bottom of the last item.\n \ + G_C2 -top {0.0 canvas} -bottom {1.0 canvas}\n +Column 3 has a horizontal gradient with unspecified bounds, so the gradient\ + is as wide as the column.\n \ + G_C3 -left {} -right {}\n +Column 4 has a horizontal gradient as wide as the content area. The colors\ + remain 'locked in place' as the list is scrolled left and right, and\ + resizing the window changes the part of the gradient in that column.\n \ + G_C4 -left {0.0 area content} -right {1.0 area content}\n +Column 5 has a horizontal gradient as wide as the canvas. The first stop color\ + begins at the left edge of the first column and the last stop color ends at the\ + right edge of the last column. If the window is wider than the items then\ + the gradient ends at the window border.\n \ + G_C5 -left {0.0 canvas} -right {1.0 canvas}" + + + for {set i 0} {$i < 25} {incr i} { + set I [$T item create -parent root] + $T item state forcolumn $I {range 1 end} openW + $T item style set $I all styleBox + } + + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients3.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients3.tcl new file mode 100644 index 00000000..b53cc9f1 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/gradients3.tcl @@ -0,0 +1,286 @@ +# Copyright (c) 2010-2011 Tim Baker + +namespace eval DemoGradients3 {} +proc DemoGradients3::Init {T} { + + variable Priv + + # + # Configure the treectrl widget + # + + $T configure \ + -showbuttons no -showlines no -showroot no \ + -xscrollincrement 20 -yscrollincrement 20 \ + -xscrollsmoothing yes -yscrollsmoothing yes \ + -canvaspady 5 -itemgapy 8 + + # + # Create columns + # + + $T column create -text "Column 0" -width 110 -tags C0 + $T column create -text "Column 1" -width 110 -tags C1 + $T column create -text "Column 2" -width 110 -tags C2 + + # + # Create elements + # + + $T element create elemBox rect -height 30 -fill gray95 + $T element create elemText text + + # + # Create styles using the elements + # + + $T style create styleText + $T style elements styleText elemText + $T style layout styleText elemText -padx 4 -pady 6 -squeeze x + + $T style create styleBox + $T style elements styleBox elemBox + $T style layout styleBox elemBox -padx 5 -iexpand x + + $T column configure {all !tail} -itemstyle styleBox + + # + # Create items and assign styles + # + + $T gradient create G1 -stops {{0.0 blue} {1.0 green}} -steps 15 + $T gradient create G2 -stops {{0.0 green} {1.0 red}} -steps 15 + $T gradient create G3 -stops {{0.0 red} {1.0 blue}} -steps 15 + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 3 + $T item text $I C0 "Outlined rectangles\nThis also demonstrates the -open\ + option of rect elements." + + foreach open {"" w nw n ne e se s sw we ns} { + set I [$T item create -parent root] + $T item element configure $I C0 elemBox -outline G1 -outlinewidth 1 -open $open + $T item element configure $I C1 elemBox -outline G2 -outlinewidth 2 -open $open + $T item element configure $I C2 elemBox -outline G3 -outlinewidth 3 -open $open + } + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 3 + $T item text $I C0 "Outlined rounded rectangles\nNote that rounded rectangles\ + will not be filled or outlined with gradients unless the platform supports gradients\ + natively." + + foreach open {"" w nw n ne e se s sw we ns} { + set I [$T item create -parent root] + $T item element configure $I C0 elemBox -outline G1 -outlinewidth 1 -open $open -rx 5 + $T item element configure $I C1 elemBox -outline G2 -outlinewidth 2 -open $open -rx 5 + $T item element configure $I C2 elemBox -outline G3 -outlinewidth 3 -open $open -rx 5 + } + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 3 + $T item text $I C0 "Filled rectangles" + + set I [$T item create -parent root] + $T item element configure $I C0 elemBox -fill G1 -open $open + $T item element configure $I C1 elemBox -fill G2 -open $open + $T item element configure $I C2 elemBox -fill G3 -open $open + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 3 + $T item text $I C0 "Filled rounded rectangles" + + foreach open {"" w nw n ne e se s sw we ns} { + set I [$T item create -parent root] + $T item element configure $I C0 elemBox -fill G1 -open $open -rx 7 + $T item element configure $I C1 elemBox -fill G2 -open $open -rx 7 + $T item element configure $I C2 elemBox -fill G3 -open $open -rx 7 + } + + set I [$T item create -parent root] + $T item style set $I C0 styleText + $T item span $I C0 3 + $T item text $I C0 "Eyecandy" + + ##### + + set height 30 + set steps [expr {($height - 5)/2}] + $T gradient create G_mouseover -steps $steps -stops {{0.0 white} {1.0 #ebf3fd}} -orient vertical + $T gradient create G_selected_active -steps $steps -stops {{0.0 #dcebfc} {1.0 #c1dbfc}} -orient vertical + $T gradient create G_selected -steps $steps -stops {{0.0 #ebf4fe} {1.0 #cfe4fe}} -orient vertical + $T gradient create G_focusout -steps $steps -stops {{0.0 #f8f8f8} {1.0 #e5e5e5}} -orient vertical + + $T item state define mouseover + + $T element create elemRectGradient rect \ + -fill [list G_selected_active {mouseover} \ + G_focusout {!focus} \ + G_selected {}] + + $T element create elemRectOutline rect -rx 1 \ + -outline [list #7da2ce {mouseover} \ + #d9d9d9 {!focus} \ + #7da2ce {}] -outlinewidth 1 + + set S [$T style create styleExplorer] + $T style elements $S {elemRectGradient elemRectOutline} + $T style layout $S elemRectGradient -padx 0 -pady {2 3} -iexpand xy + $T style layout $S elemRectOutline -union elemRectGradient -ipadx 2 -ipady 2 -padx 5 + + set I [$T item create -parent root -height $height] + $T item style set $I C0 styleExplorer + $T item style set $I C1 styleExplorer + $T item style set $I C2 styleExplorer + + ##### + + $T gradient create G_green -orient vertical -steps 4 \ + -stops {{0 #00680a} {0.05 #00680a} {0.1 #197622} {0.45 #197622} {0.5 #00680a} {0.6 #00680a} {1 #00c82c}} + set I [$T item create -parent root] + $T item span $I C0 3 + $T item element configure $I C0 elemBox -fill G_green + + ##### + + $T gradient create G_orange1 -orient vertical -steps 4 \ + -stops {{0 #fde8d1} {0.3 #fde8d1} {0.3 #ffce69} {0.6 #ffce69} {1 #fff3c3}} + $T gradient create G_orange2 -orient vertical -steps 4 \ + -stops {{0 #fffef6} {0.3 #fffef6} {0.3 #ffef9a} {0.6 #ffef9a} {1 #fffce8}} + + set height 40 + + $T element create elemOrangeOutline rect -outline #ffb700 -outlinewidth 1 -rx 1 + $T element create elemOrangeBox rect -fill {G_orange1 mouseover G_orange2 {}} \ + -height [expr {$height - 2 * 2}] + + set S [$T style create styleOrange] + $T style elements $S {elemOrangeOutline elemOrangeBox} + $T style layout $S elemOrangeBox -iexpand x + $T style layout $S elemOrangeOutline -union elemOrangeBox -ipadx 2 -ipady 2 -padx 5 + + set I [$T item create -parent root] + $T item span $I C0 3 + $T item style set $I C0 $S + + ##### + + $T gradient create G_progressFG -orient vertical -steps 2 \ + -stops {{0 #cdffcd} {0.2 #cdffcd} {0.25 #a2efaf} {0.45 #a2efaf} {0.5 #00d428} {1.0 #1ce233}} + $T gradient create G_progressBG -orient vertical -steps 2 \ + -stops {{0 white} {0.45 #dbdbdb} {0.5 #cacaca} {1.0 #cacaca}} + + $T element create elemProgressOutline rect -rx 1 -outline gray -outlinewidth 1 + $T element create elemProgressBG rect -fill G_progressBG -height 12 \ + -outline #eaeaea -outlinewidth 1 + $T element create elemProgressFG rect -fill G_progressFG -height 12 + + set S [$T style create styleProgress] + $T style elements $S {elemProgressOutline elemProgressBG elemProgressFG} + $T style layout $S elemProgressBG -iexpand x + $T style layout $S elemProgressOutline -union elemProgressBG -padx 5 -ipadx 1 -ipady 1 + $T style layout $S elemProgressFG -detach yes -padx 6 -pady 1 + + set I [$T item create -parent root -tags progress] + $T item span $I C0 3 + $T item style set $I C0 $S C1 "" C2 "" + + set Priv(progressItem) $I + set Priv(percent) 0.0 + set Priv(afterId) "" + + # Pause/resume animating when the progress bar's visibility changes + $T notify bind $T { + DemoGradients3::ItemVisibility %T %v %h + } + + # Stop animating when the item is deleted + $T notify bind $T { + after cancel $DemoGradients3::Priv(afterId) + dbwin "progressbar deleted" + } + + ##### + + set Priv(prev) "" + bind DemoGradients3 { + DemoGradients3::Motion %W %x %y + } + bind DemoGradients3 { + DemoGradients3::Motion %W -1 -1 + } + + bindtags $T [concat DemoGradients3 [bindtags $T]] + + return +} + +proc DemoGradients3::Motion {T x y} { + variable Priv + if {[lsearch -exact [$T item state names] mouseover] == -1} return + set id [$T identify $x $y] + if {$id eq ""} { + } elseif {[lindex $id 0] eq "header"} { + } elseif {[lindex $id 0] eq "item" && [llength $id] > 4} { + set item [lindex $id 1] + set column [lindex $id 3] + set curr [list $item $column] + if {$curr ne $Priv(prev)} { + if {$Priv(prev) ne ""} { + eval $T item state forcolumn $Priv(prev) !mouseover + } + $T item state forcolumn $item $column mouseover + set Priv(prev) $curr + } + return + } + if {$Priv(prev) ne ""} { + eval $T item state forcolumn $Priv(prev) !mouseover + set Priv(prev) "" + } + return +} + +proc DemoGradients3::Progress {T} { + variable Priv + set percent $Priv(percent) + if {$percent > 1.0} { + set percent 1.0 + set Priv(percent) 0.0 + } else { + set Priv(percent) [expr {$percent + 0.025}] + } + scan [$T item bbox $Priv(progressItem)] "%d %d %d %d" x1 y1 x2 y2 + set width [expr {($x2 - $x1) - 2 * 1 - 10}] + $T element configure elemProgressFG -width [expr {$width * $percent}] + set Priv(afterId) [after 100 [list DemoGradients3::Progress $T]] + return +} + +proc DemoGradients3::ItemVisibility {T visible hidden} { + variable Priv + foreach I $visible { + if {[$T item tag expr $I progress]} { + set Priv(afterId) [after 100 [list DemoGradients3::Progress $T]] + dbwin "progress resumed" + return + } + } + foreach I $hidden { + if {[$T item tag expr $I progress]} { + after cancel $Priv(afterId) + set Priv(afterId) "" + dbwin "progress paused" + return + } + } + return +} + +proc rgb {r g b} { + format #%.2x%.2x%.2x $r $g $b +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/headers.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/headers.tcl new file mode 100644 index 00000000..78a55389 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/headers.tcl @@ -0,0 +1,578 @@ +# Copyright (c) 2011 Tim Baker + +namespace eval DemoHeaders {} + +proc DemoHeaders::Init {T} { + + $T configure \ + -showroot no -xscrollsmoothing yes -yscrollsmoothing yes \ + -selectmode multiple -xscrollincrement 20 -canvaspadx 0 + + # + # Create one locked column on each side plus 8 non-locked columns + # + + set itembg {linen {} #e0e8f0 {}} + + $T column create -text "Left" -tags Cleft -width 80 -justify center \ + -gridrightcolor gray90 -itembackground $itembg \ + -lock left -arrow none -arrowside left \ + -visible no + + for {set i 1} {$i <= 8} {incr i} { + $T column create -text "C$i" -tags C$i -width 80 -justify center \ + -gridrightcolor gray90 -itembackground $itembg + } + + $T column create -text "Right" -tags Cright -width 80 -justify center \ + -gridrightcolor gray90 -itembackground $itembg \ + -lock right -visible no + + # + # Create an image element to use as the sort arrow for some header + # styles. + # + + InitSortImages blue 5 + $T element create header.sort image -statedomain header \ + -image {::DemoHeaders::arrow-down down ::DemoHeaders::arrow-up up} + + # + # Create a style for our custom headers, + # a raised border with centered text. + # + + $T element create header.border border -statedomain header \ + -background $::SystemButtonFace \ + -relief {sunken pressed raised {}} -thickness 2 -filled yes + $T element create header.text text -statedomain header \ + -lines 1 -fill black + + set S [$T style create header1 -orient horizontal -statedomain header] + $T style elements $S {header.border header.text header.sort} + $T style layout $S header.border -detach yes -indent no -iexpand xy + $T style layout $S header.text -center xy -padx 6 -pady 2 -squeeze x + $T style layout $S header.sort -expand nws -padx {0 6} \ + -visible {no {!down !up}} + + # + # Create a style for our custom headers, + # a light-blue rounded rectangle with centered text. + # + + set radius 9 + if {[Platform unix]} { + set radius 7 + } + $T element create header.rrect rect -statedomain header \ + -rx $radius -fill { + #cee8f0 active + #87c6da pressed + #87c6da up + #87c6da down + {light blue} {} + } + + set S [$T style create header2 -orient horizontal -statedomain header] + $T style elements $S {header.rrect header.text header.sort} + $T style layout $S header.rrect -detach yes -iexpand xy -padx {1 0} -pady 1 + $T style layout $S header.text -center xy -padx 6 -pady 4 -squeeze x + $T style layout $S header.sort -expand nws -padx {0 6} \ + -visible {no {!down !up}} + + # + # Create a style for our custom headers, + # Window 7 Explorer type headers. + # + + $T gradient create G.header3.fill.active -orient vertical \ + -stops {{0.0 #f3f8fd} {1.0 #eff3f9}} -steps 8 + $T gradient create G.header3.fill.pressed -orient vertical \ + -stops {{0.0 #c1ccda} {0.2 white} {1.0 white}} -steps 8 + $T gradient create G.header3.outline.normal -orient vertical \ + -stops {{0.0 #e3e8ee} {1.0 white}} -steps 8 + + $T element create header.outline3 rect -statedomain header \ + -outline {#e3e8ee active #c0cbd9 pressed G.header3.outline.normal normal} \ + -outlinewidth 1 -open {w normal} + $T element create header.rect3 rect -statedomain header \ + -fill G.header3.fill.active + $T element create header.rect3.pressed rect -statedomain header \ + -fill G.header3.fill.pressed + + set S [$T style create header3 -orient horizontal -statedomain header] + $T style elements $S {header.rect3.pressed header.outline3 header.rect3 header.text header.sort} + $T style layout $S header.outline3 -detach yes -iexpand xy + $T style layout $S header.rect3 -detach yes -iexpand xy \ + -padx 2 -pady 2 -visible {no !active} + $T style layout $S header.rect3.pressed -detach yes -iexpand xy \ + -visible {no !pressed} + $T style layout $S header.text -center xy -padx 6 -pady {6 3} -squeeze x + $T style layout $S header.sort -detach yes -expand we -pady 2 + + # + # Create a style for our custom headers, + # a header element with a checkbox image and centered text. + # + + InitPics *checked + + $T header state define CHECK + $T element create header.header header -statedomain header + $T element create header.check image -statedomain header \ + -image {checked CHECK unchecked {}} + set S [$T style create header4 -statedomain header] + $T style elements $S {header.header header.check header.text} + $T style layout $S header.header -union {header.check header.text} -iexpand news + $T style layout $S header.check -expand nes -padx {6 0} + $T style layout $S header.text -center xy -padx 6 -squeeze x + + # + # Create a style for our custom headers, + # Mac OS X type headers. + # + + $T gradient create Gnormal -orient vertical -stops {{0.0 white} {0.5 gray87} {1.0 white}} -steps 6 + $T gradient create Gactive -orient vertical -stops {{0.0 white} {0.5 gray90} {1.0 white}} -steps 6 + $T gradient create Gpressed -orient vertical -stops {{0.0 white} {0.5 gray82} {1.0 white}} -steps 6 + $T gradient create Gsorted -orient vertical -stops {{0.0 white} {0.5 {sky blue}} {1.0 white}} -steps 6 + $T gradient create Gactive_sorted -orient vertical -stops {{0.0 white} {0.5 {light blue}} {1.0 white}} -steps 6 + $T gradient create Gpressed_sorted -orient vertical -stops {{0.0 white} {0.5 {sky blue}} {1.0 white}} -steps 6 + $T element create header.rect5 rect -statedomain header \ + -fill { + Gactive_sorted {active up} + Gpressed_sorted {pressed up} + Gactive_sorted {active down} + Gpressed_sorted {pressed down} + Gsorted up + Gsorted down + Gactive active + Gpressed pressed + Gnormal {} + } -outline { + {sky blue} up + {sky blue} down + gray {} + } -outlinewidth 1 -open { + nw !pressed + } + + set S [$T style create header5 -orient horizontal -statedomain header] + $T style elements $S {header.rect5 header.text header.sort} + $T style layout $S header.rect5 -detach yes -iexpand xy + $T style layout $S header.text -center xy -padx 6 -pady 2 -squeeze x + $T style layout $S header.sort -expand nws -padx {0 6} \ + -visible {no {!down !up}} + + # + # Create a style for our custom headers, + # a gradient-filled rectangle with centered text. + # + + $T gradient create G_orange1 -orient vertical -steps 4 \ + -stops {{0 #fde8d1} {0.3 #fde8d1} {0.3 #ffce69} {0.6 #ffce69} {1 #fff3c3}} + $T gradient create G_orange2 -orient vertical -steps 4 \ + -stops {{0 #fffef6} {0.3 #fffef6} {0.3 #ffef9a} {0.6 #ffef9a} {1 #fffce8}} + + $T element create orange.outline rect -statedomain header \ + -outline #ffb700 -outlinewidth 1 \ + -rx 1 -open { + nw !pressed + } + $T element create orange.box rect -statedomain header \ + -fill { + G_orange1 active + G_orange1 up + G_orange1 down + G_orange2 {} + } + + set S [$T style create header6 -orient horizontal -statedomain header] + $T style elements $S {orange.outline orange.box header.text header.sort} + $T style layout $S orange.outline -union orange.box -ipadx 2 -ipady 2 + $T style layout $S orange.box -detach yes -iexpand xy + $T style layout $S header.text -center xy -padx 6 -pady 4 -squeeze x + $T style layout $S header.sort -expand nws -padx {0 6} \ + -visible {no {!down !up}} + + # + # Configure 3 rows of column headers + # + + set S header2 + + $T header configure first -tags header1 + set H header1 + $T header configure $H all -arrowgravity right -justify center + $T header style set $H all $S + $T header span $H all 4 + foreach {C text} [list Cleft Left C1 A C5 H Cright Right] { + $T header configure $H $C -text $text + $T header text $H $C $text + } + + set H [$T header create -tags header2] + $T header configure $H all -arrowgravity right -justify center + $T header style set $H all $S + $T header span $H all 2 + foreach {C text} [list Cleft Left C1 B C3 C C5 I C7 J Cright Right] { + $T header configure $H $C -text $text + $T header text $H $C $text + } + + set H [$T header create -tags header3] + $T header configure $H all -arrowgravity right -justify center + $T header style set $H all $S + foreach {C text} [list Cleft Left C1 D C2 E C3 F C4 G C5 K C6 L C7 M C8 N Cright Right] { + $T header configure $H $C -text $text + $T header text $H $C $text + } + + # + # Create a 4th row of column headers to test embedded windows. + # + + $T element create header.window window -statedomain header -clip yes + $T element create header.divider rect -statedomain header -fill gray -height 2 + + set S [$T style create headerWin -orient horizontal -statedomain header] + $T style elements $S {header.divider header.window} + $T style layout $S header.divider -detach yes -expand n -iexpand x + $T style layout $S header.window -iexpand x -squeeze x -padx 1 -pady {0 2} + + set H [$T header create -tags header4] + $T header dragconfigure $H -enable no + $T header style set $H all $S + foreach C [$T column list] { + set f [frame $T.frame${H}_$C -borderwidth 0] + set w [entry $f.entry -highlightthickness 1] + $w insert end $C + $T header element configure $H $C header.window -window $f + } + + # + # + # + + $T item state define current + + $T element create theme.rect rect \ + -fill {{light blue} current white {}} \ + -outline gray50 -outlinewidth 2 -open s + $T element create theme.text text \ + -lines 0 + $T element create theme.button window -clip yes + set S [$T style create theme -orient vertical] + $T style elements $S {theme.rect theme.text theme.button} + $T style layout $S theme.rect -detach yes -iexpand xy + $T style layout $S theme.text -padx 6 -pady 3 -squeeze x + $T style layout $S theme.button -expand we -pady {3 6} + + NewButtonItem "" \ + "Use no style, just the built-in header background, sort arrow and text." + NewButtonItem header1 \ + "Use the 'header1' style, consisting of a border element for the background and an image for the sort arrow." \ + black black + NewButtonItem header2 \ + "Use the 'header2' style, consisting of a rounded rectangle element for the background and an image for the sort arrow." \ + black blue + NewButtonItem header3 \ + "Use the 'header3' style, consisting of a gradient-filled rectangle element for the background and an image for the sort arrow." \ + #6d6d6d win7 + NewButtonItem header4 \ + "Use the 'header4' style, consisting of a header element to display the background and sort arrow, and an image element serving as a checkbutton." + NewButtonItem header5 \ + "Use the 'header5' style, consisting of a gradient-filled rectangle element for the background and an image for the sort arrow." \ + black #0080FF + NewButtonItem header6 \ + "Use the 'header6' style, consisting of a gradient-filled rectangle element for the background and an image for the sort arrow." \ + red orange + + $T item state set styleheader2 current + + # + # Create 100 regular non-locked items + # + + $T element create item.sel rect \ + -fill {gray {selected !focus} blue selected} + $T element create item.text text \ + -text "Item" -fill {white selected} + + set S [$T style create item] + $T style elements $S {item.sel item.text} + $T style layout $S item.sel -detach yes -iexpand xy + $T style layout $S item.text -expand news -padx 2 -pady 2 + + $T column configure !tail -itemstyle $S + $T item create -count 100 -parent root + + # Remember which column header is displaying the sort arrow, and + # initialize the sort order in each column. + variable Sort + set Sort(header) "" + set Sort(column) "" + foreach C [$T column list] { + set Sort(direction,$C) down + } + + # The event is generated in response to Motion and + # Button events in headers. + $T notify install + $T notify bind $T { + DemoHeaders::HeaderState %H %C %s + } + + # The event is generated when the left mouse button is + # pressed and released over a column header. + $T notify bind $T { + DemoHeaders::HeaderInvoke %H %C + } + + $T notify bind $T { + DemoHeaders::ColumnDragBegin %H %C + } + + # Disable the demo.tcl binding on and install our + # own to deal with multiple rows of column headers. + $T notify configure DontDelete -active no + $T notify bind $T { + DemoHeaders::ColumnDragReceive %H %C %b + } + + bindtags $T [list $T DemoHeaders TreeCtrl [winfo toplevel $T] all] + bind DemoHeaders { + DemoHeaders::ButtonPress1 %x %y + } + + return +} + +# This procedure creates a new item with descriptive text and a pushbutton +# to change the style used in the column headers. +proc DemoHeaders::NewButtonItem {S text args} { + set T [DemoList] + set I [$T item create -parent root -tags [list style$S config]] + $T item style set $I C1 theme + $T item span $I all [$T column count {lock none}] + $T item text $I C1 $text + frame $T.frame$I -borderwidth 0 + $::buttonCmd $T.frame$I.button -text "Configure headers" \ + -command [eval list [list DemoHeaders::ChangeHeaderStyle $S] $args] + $T item element configure $I C1 theme.button -window $T.frame$I + return +} + +proc DemoHeaders::InitSortImages {color height} { + set img ::DemoHeaders::arrow-down + image create photo $img + if {$color eq "win7"} { + $img put {{#3c5e72 #629ab9 #70a9c6 #72abca #83bad9 #95c6e0 #9ac7e0}} -to 0 0 + $img put {{ #528bab #73b2d8 #99d0ee #b3dbf1 #c4e3f4 }} -to 1 1 + $img put {{ #67acd3 #a6d8f3 #c4e3f4 }} -to 2 2 + $img put {{ #9acbe6 }} -to 3 3 + } else { + for {set i 0} {$i < $height} {incr i} { + set width [expr {2 * $height - ($i * 2 + 1)}] + $img put [list [string repeat "$color " $width]] -to $i $i + } + } + + set img ::DemoHeaders::arrow-up + image create photo $img + if {$color eq "win7"} { + $img put {{ #406274 }} -to 3 0 + $img put {{ #3c5e72 #569bc0 #5e88a1 }} -to 2 1 + $img put {{ #3c596c #6196b6 #86c8eb #91cbec #9ab6c5 }} -to 1 2 + $img put {{#435f6f #87b1c5 #bae2f4 #b5ddf2 #c4e3f4 #cae6f5 #c3e4f5}} -to 0 3 + } else { + for {set i 0} {$i < $height} {incr i} { + set width [expr {($i * 2 + 1)}] + $img put [list [string repeat "$color " $width]] -to [expr {$height - $i - 1}] $i + } + } + + return +} + +proc DemoHeaders::ChangeHeaderStyle {style {textColor ""} {sortColor ""} {imgHeight 5}} { + variable HeaderStyle + variable Sort + set T [DemoList] + # To override the system theme color on Gtk+, set the header element color + # and not the widget's -headerforeground color. + $T element configure header.text -fill $textColor + if {$sortColor ne ""} { + InitSortImages $sortColor $imgHeight + } + set HeaderStyle $style + set S $HeaderStyle + foreach H [$T header id !header4] { + $T header style set $H all $S + if {$S ne ""} { + $T header configure all all -textpadx 6 + foreach C [$T column list] { + $T header text $H $C [$T header cget $H $C -text] + } + } + } + if {$Sort(header) ne ""} { + ShowSortArrow $Sort(header) $Sort(column) + } + $T item state set {state current} !current + $T item state set style$style current + return +} + +# This procedure is called to handle the event generated by +# the treectrl.tcl library script. +proc DemoHeaders::HeaderState {H C state} { + return +} + +# This procedure is called to handle the event generated by +# the treectrl.tcl library script. +# If the given column header is already displaying a sort arrow, the sort +# arrow direction is toggled. Otherwise the sort arrow is removed from all +# other column headers and displayed in the given column header. +proc DemoHeaders::HeaderInvoke {H C} { + variable Sort + set T [DemoList] +# if {![$T item tag expr $I header3]} return + if {$Sort(header) eq ""} { + ShowSortArrow $H $C + } else { + if {[$T header compare $H == $Sort(header)] && + [$T column compare $C == $Sort(column)]} { + ToggleSortArrow $H $C + } else { + HideSortArrow $Sort(header) $Sort(column) + ShowSortArrow $H $C + } + } + set Sort(header) $H + set Sort(column) $C + return +} + +# Sets the -arrow option of a column header to 'up' or 'down'. +proc DemoHeaders::ShowSortArrow {H C} { + variable Sort + set T [DemoList] + $T header configure $H $C -arrow $Sort(direction,$C) + return +} + +# Sets the -arrow option of a column header to 'none'. +proc DemoHeaders::HideSortArrow {H C} { + set T [DemoList] + $T header configure $H $C -arrow none + return +} + +# Toggles a sort arrow between up and down +proc DemoHeaders::ToggleSortArrow {H C} { + variable Sort + if {$Sort(direction,$C) eq "up"} { + set Sort(direction,$C) down + } else { + set Sort(direction,$C) up + } + ShowSortArrow $H $C + return +} + +# This procedure is called to handle the event generated +# by the treectrl.tcl library script. +# When dragging in the top row, all header-rows provide feedback. +# When dragging in the second row, the 2nd, 3rd and 4th rows provide feedback. +# When dragging in the third row, only the 3rd and 4rd row provides feedback. +proc DemoHeaders::ColumnDragBegin {H C} { + set T [DemoList] + $T header dragconfigure all -draw yes + if {[$T header compare $H > header1]} { + $T header dragconfigure header1 -draw no + } + if {[$T header compare $H > header2]} { + $T header dragconfigure header2 -draw no + } + return +} + +# This procedure is called to handle the event generated +# by the treectrl.tcl library script. +proc DemoHeaders::ColumnDragReceive {H C b} { + set T [DemoList] + + # Get the range of columns in the span of the dragged header. + set span [$T header span $H $C] + set last [$T column id "$C span $span"] + set columns [$T column id "range $C $last"] + + set span1 [$T header span header1] + set span2 [$T header span header2] + set text1 [$T header text header1] + set text2 [$T header text header2] + + set columnLeft [$T column id "first lock none"] + + foreach C $columns { + $T column move $C $b + } + + # Restore the appearance of the top row if dragging happened below + if {[$T header compare $H > header1]} { + foreach span $span1 text $text1 C [$T column list] { + $T header span header1 $C $span + $T header text header1 $C $text + $T header configure header1 $C -text $text + } + } + + # Restore the appearance of the second row if dragging happened below + if {[$T header compare $H > header2]} { + foreach span $span2 text $text2 C [$T column list] { + $T header span header2 $C $span + $T header text header2 $C $text + $T header configure header2 $C -text $text + } + } + + # For each of the items displaying a button widget to change the header + # style, transfer the style from the old left-most column to the new + # left-most column. + if {[$T column compare $columnLeft != "first lock none"]} { + foreach I [$T item id "tag config"] { + TransferItemStyle $T $I $columnLeft "first lock none" + } + } + + return +} + +# Copy the style and element configuration from one column of an item to +# another. +proc DemoHeaders::TransferItemStyle {T I Cfrom Cto} { + set S [$T item style set $I $Cfrom] + $T item style set $I $Cto $S + foreach E [$T item style elements $I $Cfrom] { + foreach info [$T item element configure $I $Cfrom $E] { + lassign $info option x y z value + $T item element configure $I $Cto $E $option $value + } + } + $T item style set $I $Cfrom "" + return +} + +# This procedure is called to handle the event. +# If the click was in the checkbutton image element, toggle the CHECK state. +proc DemoHeaders::ButtonPress1 {x y} { + set T [DemoList] + $T identify -array id $x $y + if {$id(where) eq "header" && $id(element) eq "header.check"} { + $T header state forcolumn $id(header) $id(column) ~CHECK + return -code break + } + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/help.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/help.tcl new file mode 100644 index 00000000..9c6366bf --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/help.tcl @@ -0,0 +1,363 @@ +# Copyright (c) 2002-2011 Tim Baker + +# +# Demo: Help contents +# +namespace eval DemoHelpContents {} +proc DemoHelpContents::Init {T} { + + variable Priv + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no -itemheight $height \ + -selectmode browse + + $T configure -canvaspadx {4 0} -canvaspady {2 0} + + InitPics help-* + + # + # Create columns + # + + $T column create -text "Help Contents" -tags C0 + + $T configure -treecolumn C0 + + # + # Create elements + # + + # Define a new item state + $T item state define mouseover + + $T element create elemImgPage image -image help-page + $T element create elemImgBook image -image {help-book-open {open} help-book-closed {}} + $T element create elemTxt text -fill [list $::SystemHighlightText {selected focus} blue {mouseover}] \ + -font [list DemoFontUnderline {mouseover}] -lines 1 + $T element create elemRectSel rect -fill [list $::SystemHighlight {selected focus}] -showfocus yes + + # + # Create styles using the elements + # + + # book + set S [$T style create styBook] + $T style elements $S {elemRectSel elemImgBook elemTxt} + $T style layout $S elemImgBook -padx {0 4} -expand ns + $T style layout $S elemTxt -expand ns -squeeze x + $T style layout $S elemRectSel -union [list elemTxt] -iexpand ns -ipadx 2 + + # page + set S [$T style create styPage] + $T style elements $S {elemRectSel elemImgPage elemTxt} + $T style layout $S elemImgPage -padx {0 4} -expand ns + $T style layout $S elemTxt -expand ns -squeeze x + $T style layout $S elemRectSel -union [list elemTxt] -iexpand ns -ipadx 2 + + # + # Create items and assign styles + # + + set parentList [list root {} {} {} {} {} {}] + set parent root + foreach {depth style text} { + 0 styPage "Welcome to Help" + 0 styBook "Introducing Windows 98" + 1 styBook "How to Use Help" + 2 styPage "Find a topic" + 2 styPage "Get more out of help" + 1 styBook "Register Your Software" + 2 styPage "Registering Windows 98 online" + 1 styBook "What's New in Windows 98" + 2 styPage "Innovative, easy-to-use features" + 2 styPage "Improved reliability" + 2 styPage "A faster operating system" + 2 styPage "True Web integration" + 2 styPage "More entertaining and fun" + 1 styBook "If You're New to Windows 98" + 2 styBook "Tips for Macintosh Users" + 3 styPage "Why does the mouse have two buttons?" + } { + set item [$T item create -open no] + $T item style set $item C0 $style + $T item element configure $item C0 elemTxt -text $text + $T item lastchild [lindex $parentList $depth] $item + incr depth + set parentList [lreplace $parentList $depth $depth $item] + } + + bind DemoHelpContents { + if {[lindex [%W identify %x %y] 0] eq "header"} { + TreeCtrl::DoubleButton1 %W %x %y + } else { + DemoHelpContents::Button1 %W %x %y + } + break + } + bind DemoHelpContents { + DemoHelpContents::Button1 %W %x %y + break + } + bind DemoHelpContents { + # noop + } + bind DemoHelpContents { + # noop + } + bind DemoHelpContents { + DemoHelpContents::Motion %W %x %y + } + bind DemoHelpContents { + DemoHelpContents::Motion %W %x %y + } + bind DemoHelpContents { + if {[%W selection count] == 1} { + %W item toggle [%W selection get 0] + } + break + } + + set Priv(prev) "" + bindtags $T [list $T DemoHelpContents TreeCtrl [winfo toplevel $T] all] + + return +} + +# This is an alternate implementation that does not define a new item state +# to change the appearance of the item under the cursor. +proc DemoHelpContents::Init_2 {T} { + + variable Priv + + set T [DemoList] + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no -itemheight $height \ + -selectmode browse + + InitPics help-* + + # + # Create columns + # + + $T column create -text "Help Contents" + + # + # Create elements + # + + $T element create elemImgPage image -image help-page + $T element create elemImgBook image -image {help-book-open {open} help-book-closed {}} + $T element create elemTxt text -fill [list $::SystemHighlightText {selected focus}] + $T element create elemRectSel rect -fill [list $::SystemHighlight {selected focus}] -showfocus yes + $T element create elemTxtOver text -fill [list $::SystemHighlightText {selected focus} blue {}] \ + -font "[$T cget -font] underline" + + # + # Create styles using the elements + # + + # book + set S [$T style create styBook] + $T style elements $S {elemRectSel elemImgBook elemTxt} + $T style layout $S elemImgBook -padx {0 4} -expand ns + $T style layout $S elemTxt -expand ns + $T style layout $S elemRectSel -union [list elemTxt] -iexpand ns -ipadx 2 + + # page + set S [$T style create styPage] + $T style elements $S {elemRectSel elemImgPage elemTxt} + $T style layout $S elemImgPage -padx {0 4} -expand ns + $T style layout $S elemTxt -expand ns + $T style layout $S elemRectSel -union [list elemTxt] -iexpand ns -ipadx 2 + + # book (focus) + set S [$T style create styBook.f] + $T style elements $S {elemRectSel elemImgBook elemTxtOver} + $T style layout $S elemImgBook -padx {0 4} -expand ns + $T style layout $S elemTxtOver -expand ns + $T style layout $S elemRectSel -union [list elemTxtOver] -iexpand ns -ipadx {1 2} + + # page (focus) + set S [$T style create styPage.f] + $T style elements $S {elemRectSel elemImgPage elemTxtOver} + $T style layout $S elemImgPage -padx {0 4} -expand ns + $T style layout $S elemTxtOver -expand ns + $T style layout $S elemRectSel -union [list elemTxtOver] -iexpand ns -ipadx {1 2} + + # + # Create items and assign styles + # + + set parentList [list root {} {} {} {} {} {}] + set parent root + foreach {depth style text} { + 0 styPage "Welcome to Help" + 0 styBook "Introducing Windows 98" + 1 styBook "How to Use Help" + 2 styPage "Find a topic" + 2 styPage "Get more out of help" + 1 styBook "Register Your Software" + 2 styPage "Registering Windows 98 online" + 1 styBook "What's New in Windows 98" + 2 styPage "Innovative, easy-to-use features" + 2 styPage "Improved reliability" + 2 styPage "A faster operating system" + 2 styPage "True Web integration" + 2 styPage "More entertaining and fun" + 1 styBook "If You're New to Windows 98" + 2 styBook "Tips for Macintosh Users" + 3 styPage "Why does the mouse have two buttons?" + } { + set item [$T item create -open no] + $T item style set $item 0 $style + $T item element configure $item 0 elemTxt -text $text + $T item lastchild [lindex $parentList $depth] $item + incr depth + set parentList [lreplace $parentList $depth $depth $item] + } + + bind DemoHelpContents { + if {[lindex [%W identify %x %y] 0] eq "header"} { + TreeCtrl::DoubleButton1 %W %x %y + } else { + DemoHelpContents::Button1 %W %x %y + } + break + } + bind DemoHelpContents { + DemoHelpContents::Button1 %W %x %y + break + } + bind DemoHelpContents { + # noop + } + bind DemoHelpContents { + # noop + } + bind DemoHelpContents { + DemoHelpContents::Motion_2 %W %x %y + } + bind DemoHelpContents { + DemoHelpContents::Motion_2 %W %x %y + } + bind DemoHelpContents { + if {[%W selection count] == 1} { + %W item toggle [%W selection get 0] + } + break + } + + set Priv(prev) "" + bindtags $T [list $T DemoHelpContents TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoHelpContents::Button1 {w x y} { + variable ::TreeCtrl::Priv + focus $w + set id [$w identify $x $y] + set Priv(buttonMode) "" + if {[lindex $id 0] eq "header"} { + TreeCtrl::ButtonPress1 $w $x $y + } elseif {[lindex $id 0] eq "item"} { + set item [lindex $id 1] + # didn't click an element + if {[llength $id] != 6} return + if {[$w selection includes $item]} { + $w item toggle $item + return + } + if {[$w selection count]} { + set item2 [$w selection get 0] + $w item collapse $item2 + foreach item2 [$w item ancestors $item2] { + if {[$w item compare $item != $item2]} { + $w item collapse $item2 + } + } + } + $w activate $item + $w item expand [list $item ancestors] + $w item toggle $item + $w selection modify $item all + } + return +} + +proc DemoHelpContents::Motion {w x y} { + variable Priv + set id [$w identify $x $y] + if {$id eq ""} { + } elseif {[lindex $id 0] eq "header"} { + } elseif {[lindex $id 0] eq "item"} { + set item [lindex $id 1] + if {[llength $id] == 6} { + if {$item ne $Priv(prev)} { + if {$Priv(prev) ne ""} { + $w item state set $Priv(prev) !mouseover + } + $w item state set $item mouseover + $w configure -cursor hand2 + set Priv(prev) $item + } + return + } + } + if {$Priv(prev) ne ""} { + $w item state set $Priv(prev) !mouseover + $w configure -cursor "" + set Priv(prev) "" + } + return +} + +# Alternate implementation that does not rely on run-time states +proc DemoHelpContents::Motion_2 {w x y} { + variable Priv + set id [$w identify $x $y] + if {[lindex $id 0] eq "header"} { + } elseif {$id ne ""} { + set item [lindex $id 1] + if {[llength $id] == 6} { + if {$item ne $Priv(prev)} { + if {$Priv(prev) ne ""} { + set style [$w item style set $Priv(prev) 0] + set style [string trim $style .f] + $w item style map $Priv(prev) 0 $style {elemTxtOver elemTxt} + } + set style [$w item style set $item 0] + $w item style map $item 0 $style.f {elemTxt elemTxtOver} + set Priv(prev) $item + } + return + } + } + if {$Priv(prev) ne ""} { + set style [$w item style set $Priv(prev) 0] + set style [string trim $style .f] + $w item style map $Priv(prev) 0 $style {elemTxtOver elemTxt} + set Priv(prev) "" + } + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/imovie.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/imovie.tcl new file mode 100644 index 00000000..d12179c3 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/imovie.tcl @@ -0,0 +1,171 @@ +# Copyright (c) 2002-2011 Tim Baker + +# +# Demo: iMovie +# +namespace eval DemoIMovie {} +proc DemoIMovie::Init {T} { + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode browse -orient horizontal -wrap window \ + -showheader no -background #dcdcdc -yscrollsmoothing yes + + $T configure -canvaspadx 8 -canvaspady 8 \ + -itemgapx 8 -itemgapy 8 + + # + # Create columns + # + + $T column create -tags C0 + + InitPics imovie-* + + switch -- $::thisPlatform { + macintosh - + macosx { + set font1 {Geneva 10} + set font2 {Geneva 11} + } + unix { + set font1 {Helvetica 12} + set font2 {Helvetica 14} + } + default { + set font1 {Helvetica 8} + set font2 {Helvetica 10} + } + } + + # + # Create elements + # + + $T element create elemTime text -font [list $font1] + $T element create elemName text -font [list $font2] -lines 1 -width 80 + $T element create elemRect rect -fill {#ffdc5a {selected} white {}} \ + -outline #827878 -outlinewidth 1 + $T element create elemImg image + $T element create elemShadow rect -outline gray -outlinewidth 1 -open wn + + # + # Create styles using the elements + # + + set S [$T style create STYLE -orient vertical] + $T style elements $S {elemShadow elemRect elemTime elemImg elemName} + $T style layout $S elemShadow -detach yes -padx {1 0} -pady {1 0} -iexpand xy + $T style layout $S elemTime -padx {2 0} + $T style layout $S elemImg -pady {0 1} + $T style layout $S elemName -expand we -ipady {0 2} -padx {0 3} -squeeze x + $T style layout $S elemRect -union {elemTime elemImg elemName} \ + -ipadx 6 -padx {0 1} -pady {0 1} + + # Set default item style + $T column configure C0 -itemstyle $S + + # + # Create items and assign styles + # + + for {set i 0} {$i < 5} {incr i} { + foreach {time name image} { + 15:20 "Clip 1" imovie-01 + 19:18 "Clip 2" imovie-02 + 07:20 "Clip 3" imovie-03 + 07:20 "Clip 4" imovie-04 + 07:20 "Clip 5" imovie-05 + 07:20 "Clip 6" imovie-06 + 07:20 "Clip 7" imovie-07 + } { + set I [$T item create] +# $T item style set $I C0 $S + $T item element configure $I C0 \ + elemTime -text $time + \ + elemImg -image $image + \ + elemName -text $name + $T item lastchild root $I + } + } + + $T notify bind $T { + %T item element configure %I %C %E -text %t + } + + bind DemoIMovie { + DemoIMovie::Button1 %W %x %y + } + + bindtags $T [list $T DemoIMovie TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoIMovie::Button1 {T x y} { + focus $T + set id [$T identify $x $y] + + # Click outside any item + if {$id eq ""} { + + # Click in header + } elseif {[lindex $id 0] eq "header"} { + ::TreeCtrl::ButtonPress1 $T $x $y + + # Click in item + } elseif {[lindex $id 0] eq "item"} { + ::TreeCtrl::ButtonPress1 $T $x $y + update + lassign $id where item arg1 arg2 arg3 arg4 + switch $arg1 { + column { + set I [lindex $id 1] + if {[llength $id] == 6} { + set E [lindex $id end] + if {$E eq "elemName"} { + set exists [winfo exists $T.entry] + ::TreeCtrl::EntryOpen $T $I C0 $E + if {!$exists} { + $T.entry configure -borderwidth 0 -justify center \ + -background #ffdc5a + scan [$T item bbox $I C0 $E] "%d %d %d %d" x1 y1 x2 y2 + place $T.entry -y [expr {$y1 - 1}] + } + $T.entry selection clear + scan [$T item bbox $I C0 elemImg] "%d %d %d %d" x1 y1 x2 y2 + set left $x1 + set right $x2 + place $T.entry -x $left -width [expr {$right - $left}] + $T.entry icursor [$T.entry index @[expr {$x - ($x1 + 1)}]] + # Disable mouse tracking + unset ::TreeCtrl::Priv(buttonMode) + } + } + } + } + } + return -code break +} + +# +# Demo: iMovie (Wrap) +# +namespace eval DemoIMovieWrap {} +proc DemoIMovieWrap::Init {T} { + + DemoIMovie::Init $T + + $T configure -wrap "" -xscrollsmoothing yes + $T item configure "root child 4" -wrap yes + $T item configure "root child 5" -wrap yes + $T item configure "root child 8" -wrap yes + $T item configure "root child 10" -wrap yes + $T item configure "root child 15" -wrap yes +# $T item configure "root child 15" -wrap yes + $T item configure "root child 25" -wrap yes + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/inspector.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/inspector.tcl new file mode 100644 index 00000000..e257c544 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/inspector.tcl @@ -0,0 +1,286 @@ +namespace eval Inspector { +} + +proc Inspector::InitWindow {} { + variable Priv + + InitPics *checked + + set w .inspector + catch {destroy $w} + toplevel $w + wm title $w "TkTreeCtrl Inspector" + + # + # Component + # + + panedwindow $w.splitterH -orient horizontal + TreePlusScrollbarsInAFrame $w.splitterH.f1 1 1 + $w.splitterH add $w.splitterH.f1 + + set T $w.splitterH.f1.t + $T configure -showroot no + $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e2 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + $T style create s1 + $T style elements s1 {e2 e1} + # Tk listbox has linespace + 1 height + $T style layout s1 e2 -union [list e1] -ipadx 2 -ipady {0 1} -iexpand nes + $T column create -text "Component" -button no -itemstyle s1 -tags C0 + foreach label {Column Header Item Widget} { + set I [$T item create -parent root] + $T item text $I C0 $label + } + + $T notify bind $T { + Inspector::SelectComponent + } + + # + # Instance + # + + panedwindow $w.splitterV -orient vertical + TreePlusScrollbarsInAFrame $w.splitterV.f1 1 1 +set f $w.splitterV.f1 +grid rowconfigure $f 0 -weight 0 +grid rowconfigure $f 1 -weight 1 +grid configure $f.sh -row 2 +grid configure $f.t -row 1 +grid configure $f.sv -row 1 +grid [label $f.label -text "Headers" -bg {light blue}] -row 0 -column 0 -columnspan 2 -sticky we + $w.splitterV add $w.splitterV.f1 + + set T $w.splitterV.f1.t + $T configure -showroot no + $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e2 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + $T style create s1 + $T style elements s1 {e2 e1} + # Tk listbox has linespace + 1 height + $T style layout s1 e2 -union [list e1] -ipadx 2 -ipady {0 1} -iexpand nes + + $T item state define CHECK + $T element create imgCheck image -image {checked CHECK unchecked {}} + set S [$T style create styCheck] + $T style elements $S [list imgCheck] + $T style layout $S imgCheck -expand news + + $w.splitterH add $w.splitterV + + # + # Sub-Instance + # + + TreePlusScrollbarsInAFrame $w.splitterV.f2 1 1 +set f $w.splitterV.f2 +grid rowconfigure $f 0 -weight 0 +grid rowconfigure $f 1 -weight 1 +grid configure $f.sh -row 2 +grid configure $f.t -row 1 +grid configure $f.sv -row 1 +grid [label $f.label -text "Header columns" -bg {light blue}] -row 0 -column 0 -columnspan 2 -sticky we + $w.splitterV add $w.splitterV.f2 + + set T $w.splitterV.f2.t + $T configure -showroot no + $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e2 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + $T style create s1 + $T style elements s1 {e2 e1} + # Tk listbox has linespace + 1 height + $T style layout s1 e2 -union [list e1] -ipadx 2 -ipady {0 1} -iexpand nes + + $T item state define CHECK + $T element create imgCheck image -image {checked CHECK unchecked {}} + set S [$T style create styCheck] + $T style elements $S [list imgCheck] + $T style layout $S imgCheck -expand news + + ### + + pack $w.splitterH -expand yes -fill both + + set Priv(win) $w + set Priv(tree1) $w.splitterH.f1.t + set Priv(tree2) $w.splitterV.f1.t + set Priv(tree3) $w.splitterV.f2.t + set Priv(label2) $w.splitterV.f1.label + set Priv(label3) $w.splitterV.f2.label + + return +} + +proc Inspector::InspectColumns {inspectMe} { + variable Priv + $Priv(label2) configure -text Columns + set T $Priv(tree2) + $T item delete all + $T column delete all + foreach title {ID -lock -width -expand -resize -squeeze -visible} { + $T column create -text $title -tags C$title -itembackground {gray90 ""} + } + foreach C [$inspectMe column list] { + set I [$T item create -parent root] + $T item style set $I CID s1 + $T item text $I CID $C + foreach title {-lock -width} { + $T item style set $I C$title s1 + $T item text $I C$title [$inspectMe column cget $C $title] + } + foreach title {-expand -resize -squeeze -visible} { + $T item style set $I C$title styCheck + if {[$inspectMe column cget $C $title]} { + $T item state forcolumn $I C$title CHECK + } + } + } + + $T notify bind $T {} + + set T $Priv(tree3) + $T item delete all + $T column delete all + $Priv(label3) configure -text + + return +} + +proc Inspector::InspectHeaders {inspectMe} { + variable Priv + $Priv(label2) configure -text Headers + set T $Priv(tree2) + $T item delete all + $T column delete all + foreach title {ID -height -tags -visible} { + $T column create -text $title -tags C$title -itembackground {gray90 ""} + } + foreach H [$inspectMe header id all] { + set I [$T item create -parent root] + $T item style set $I CID s1 + $T item text $I CID $H + foreach title {-height -tags} { + $T item style set $I C$title s1 + $T item text $I C$title [$inspectMe header cget $H $title] + } + foreach title {-visible} { + $T item style set $I C$title styCheck + if {[$inspectMe header cget $H $title]} { + $T item state forcolumn $I C$title CHECK + } + } + set Priv(item2header,$I) $H + } + + $T notify bind $T { + if {%c > 0} { + Inspector::SelectHeader + } + } + + set T $Priv(tree3) + $T item delete all + $T column delete all + $Priv(label3) configure -text + + return +} + +proc Inspector::InspectHeaderColumns {inspectMe H} { + variable Priv + $Priv(label3) configure -text "Columns in Header #$H" + set T $Priv(tree3) + $T item delete all + $T column delete all + foreach title {ID -text -image -arrow -arrowside -arrowgravity -button -justify span} { + $T column create -text $title -tags C$title -itembackground {gray90 ""} + } + foreach C [$inspectMe column list] { + set I [$T item create -parent root] + $T item style set $I CID s1 + $T item text $I CID $C + foreach title {-text -image -arrow -arrowside -arrowgravity -justify} { + $T item style set $I C$title s1 + $T item text $I C$title [$inspectMe header cget $H $C $title] + } + foreach title {-button} { + $T item style set $I C$title styCheck + if {[$inspectMe header cget $H $C $title]} { + $T item state forcolumn $I C$title CHECK + } + } + + $T item style set $I Cspan s1 + $T item text $I Cspan [$inspectMe header span $H $C] + } + return +} + +proc Inspector::InspectItems {inspectMe} { + variable Priv + $Priv(label2) configure -text "Items in the demo list" + set T $Priv(tree2) + $T item delete all + $T column delete all + foreach title {ID -button -height -tags -visible -wrap} { + $T column create -text $title -tags C$title -itembackground {gray90 ""} + } + foreach iI [$inspectMe item range first last] { + set I [$T item create -parent root] + $T item style set $I CID s1 + $T item text $I CID $iI + foreach title {-button -height -tags} { + $T item style set $I C$title s1 + $T item text $I C$title [$inspectMe item cget $iI $title] + } + foreach title {-visible -wrap} { + $T item style set $I C$title styCheck + if {[$inspectMe item cget $iI $title]} { + $T item state forcolumn $I C$title CHECK + } + } + } + + $T notify bind $T {} + + set T $Priv(tree3) + $T item delete all + $T column delete all + $Priv(label3) configure -text + + return +} + +proc Inspector::SelectComponent {} { + variable Priv + set T $Priv(tree1) + set I [$T selection get 0] + if {[$T item text $I C0] eq "Column"} { + InspectColumns [DemoList] + } + if {[$T item text $I C0] eq "Header"} { + InspectHeaders [DemoList] + } + if {[$T item text $I C0] eq "Item"} { + InspectItems [DemoList] + } + return +} + +proc Inspector::SelectHeader {} { + variable Priv + set T $Priv(tree2) + set I [$T selection get 0] + InspectHeaderColumns [DemoList] $Priv(item2header,$I) + return +} + +Inspector::InitWindow +Inspector::InspectHeaders [DemoList] +Inspector::InspectHeaderColumns [DemoList] 0 + + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/layout.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/layout.tcl new file mode 100644 index 00000000..c1cef562 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/layout.tcl @@ -0,0 +1,166 @@ +# Copyright (c) 2002-2011 Tim Baker + +# +# Demo: Layout +# +namespace eval DemoLayout {} +proc DemoLayout::Init {T} { + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showrootbutton yes -showbuttons yes \ + -showlines [ShouldShowLines $T] -itemheight 0 -selectmode browse + + # + # Create columns + # + + $T column create -text Layout -itemjustify left -justify center -tags C0 + $T configure -treecolumn C0 + + # + # Create elements + # + + $T element create e1 rect -width 30 -height 30 -fill gray20 + $T element create e2 rect -width 30 -height 30 -fill gray40 \ + -outline blue -outlinewidth 3 + $T element create e3 rect -fill gray60 + $T element create e4 rect -fill [list $::SystemHighlight {selected focus} gray80 {}] \ + -showfocus yes + $T element create e5 rect -fill {"sky blue"} -width 20 -height 20 + $T element create e6 rect -fill {"sea green"} -width 30 -height 16 + $T element create e7 rect -fill {"sky blue"} -width 30 -height 16 + $T element create e8 rect -fill gray70 -height 1 + + # + # Create styles using the elements + # + + set S [$T style create s1] + $T style elements $S {e4 e3 e1 e2 e5 e6 e7} + $T style layout $S e1 -padx {28 4} -pady 4 + $T style layout $S e2 -expand es -padx {0 38} + $T style layout $S e3 -union [list e1 e2] -ipadx 4 -ipady 4 -pady 2 + $T style layout $S e4 -detach yes -iexpand xy + $T style layout $S e5 -detach yes -padx {2 0} -pady 2 -iexpand y + $T style layout $S e6 -detach yes -expand ws -padx {0 2} -pady {2 0} + $T style layout $S e7 -detach yes -expand wn -padx {0 2} -pady {0 2} + + # + # Create items and assign styles + # + + set I [$T item create -button yes] + $T item style set $I C0 $S + $T item lastchild root $I + set parent $I + + set I [$T item create] + $T item style set $I C0 $S + $T item lastchild $parent $I + + ### + + set S [$T style create s2] + $T style elements $S {e4 e3 e1} + $T style layout $S e1 -padx 8 -pady 8 -iexpand x + $T style layout $S e3 -union e1 -ipadx {20 4} -ipady {4 12} + $T style layout $S e4 -detach yes -iexpand xy + + set I [$T item create -button yes] + $T item style set $I C0 $S + $T item lastchild root $I + + set I2 [$T item create] + $T item style set $I2 C0 $S + $T item lastchild $I $I2 + + ### + + set S [$T style create s3] + $T style elements $S {e4 e3 e1 e5 e6} + $T style layout $S e4 -union {e1 e6} -ipadx 8 -ipady {8 0} + $T style layout $S e3 -union {e1 e5} -ipadx 4 -ipady 4 + $T style layout $S e5 -height 40 + + set I [$T item create -button yes] + $T item style set $I C0 $S + $T item lastchild root $I + + set I2 [$T item create] + $T item style set $I2 C0 $S + $T item lastchild $I $I2 + + ### + + $T element create eb border -background $::SystemButtonFace \ + -relief {sunken {selected} raised {}} -thickness 2 -filled yes + $T element create et text -lmargin2 20 + + set text "Here is a text element surrounded by a border element.\nResize the column to watch me wrap." + + set S [$T style create s4] + $T style elements $S {eb et} + $T style layout $S eb -union et -ipadx 2 -ipady 2 + $T style layout $S et -squeeze x + + set I [$T item create -button yes] + $T item style set $I C0 $S + $T item text $I C0 $text + $T item lastchild root $I + set parent $I + + set I [$T item create] + $T item style set $I C0 $S + $T item text $I C0 $text + $T item lastchild $parent $I + + ### + + set S [$T style create s5] + $T style elements $S {e1 e2 e3 e4 e5 e6 e7 e8} + $T style layout $S e1 -union e2 -ipadx 4 -ipady 4 + $T style layout $S e2 -union e3 -ipadx 4 -ipady 4 -visible {no selected} + $T style layout $S e3 -union e4 -ipadx 4 -ipady 4 + $T style layout $S e4 -width 30 -height 30 + $T style layout $S e5 -union e6 -ipadx 4 -ipady 4 + $T style layout $S e6 -union e7 -ipadx 4 -ipady 4 -visible {no selected} + $T style layout $S e7 -union e8 -ipadx 4 -ipady 4 + $T style layout $S e8 -width 30 -height 30 -padx {24 0} + + set I [$T item create -button yes] + $T item style set $I C0 $S + $T item lastchild root $I + + set I2 [$T item create] + $T item style set $I2 C0 $S + $T item lastchild $I $I2 + + ### + + set styleNum 6 + foreach {orient expandList} {horizontal {s ns n} vertical {e we w}} { + foreach expand $expandList { + + set S [$T style create s$styleNum -orient $orient] + $T style elements $S {e4 e8 e3 e2 e5 e6} + $T style layout $S e4 -detach yes -iexpand xy + $T style layout $S e8 -detach yes -expand n -iexpand x + $T style layout $S e3 -union {e2 e5 e6} -ipadx 5 -ipady 5 + $T style layout $S e2 -expand $expand + $T style layout $S e5 -expand $expand -visible {no !selected} + $T style layout $S e6 -expand $expand + incr styleNum + + set I [$T item create] + $T item style set $I C0 $S + $T item lastchild root $I + } + } + + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/mailwasher.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/mailwasher.tcl new file mode 100644 index 00000000..6e4ee69a --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/mailwasher.tcl @@ -0,0 +1,205 @@ +# Copyright (c) 2002-2011 Tim Baker + +# +# Demo: MailWasher +# +namespace eval DemoMailWasher {} +proc DemoMailWasher::Init {T} { + + InitPics *checked + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showrootbutton no -showbuttons no \ + -showlines no -itemheight $height -selectmode browse \ + -xscrollincrement 20 -xscrollsmoothing yes + + # + # Create columns + # + + set pad 4 + $T column create -text Delete -textpadx $pad -justify center -tags delete + $T column create -text Bounce -textpadx $pad -justify center -tags bounce + $T column create -text Status -width 80 -textpadx $pad -tags status + $T column create -text Size -width 40 -textpadx $pad -justify right -tags size + $T column create -text From -width 140 -textpadx $pad -tags from + $T column create -text Subject -width 240 -textpadx $pad -tags subject + $T column create -text Received -textpadx $pad -arrow up -tags received + $T column create -text Attachments -textpadx $pad -tags attachments + + $T item state define CHECK + + # + # Create elements + # + + $T element create border rect -open nw -outline gray -outlinewidth 1 \ + -fill [list $::SystemHighlight {selected}] + $T element create imgCheck image -image {checked CHECK unchecked {}} + $T element create txtAny text \ + -fill [list $::SystemHighlightText {selected}] -lines 1 + $T element create txtNone text -text "none" \ + -fill [list $::SystemHighlightText {selected}] -lines 1 + $T element create txtYes text -text "yes" \ + -fill [list $::SystemHighlightText {selected}] -lines 1 + $T element create txtNormal text -text "Normal" \ + -fill [list $::SystemHighlightText {selected} #006800 {}] -lines 1 + $T element create txtPossSpam text -text "Possible Spam" \ + -fill [list $::SystemHighlightText {selected} #787800 {}] -lines 1 + $T element create txtProbSpam text -text "Probably Spam" \ + -fill [list $::SystemHighlightText {selected} #FF9000 {}] -lines 1 + $T element create txtBlacklist text -text "Blacklisted" \ + -fill [list $::SystemHighlightText {selected} #FF5800 {}] -lines 1 + + # + # Create styles using the elements + # + + set S [$T style create styCheck] + $T style elements $S [list border imgCheck] + $T style layout $S border -detach yes -iexpand xy + $T style layout $S imgCheck -expand news + + set pad 4 + + foreach name {Any None Yes Normal PossSpam ProbSpam Blacklist} { + set S [$T style create sty$name] + $T style elements $S [list border txt$name] + $T style layout $S border -detach yes -iexpand xy + $T style layout $S txt$name -padx $pad -squeeze x -expand ns + } + + # + # Create items and assign styles + # + + for {set i 0} {$i < 1} {incr i} { + foreach {from subject} { + baldy@spammer.com "Your hair is thinning" + flat@spammer.com "Your breasts are too small" + tiny@spammer.com "Your penis is too small" + dumbass@spammer.com "You are not very smart" + bankrobber@spammer.com "You need more money" + loser@spammer.com "You need better friends" + gossip@spammer.com "Find out what your coworkers think about you" + whoami@spammer.com "Find out what you think about yourself" + downsized@spammer.com "You need a better job" + poorhouse@spammer.com "Your mortgage is a joke" + spam4ever@spammer.com "You need more spam" + } { + set item [$T item create] + set status [lindex [list styNormal styPossSpam styProbSpam styBlacklist] [expr int(rand() * 4)]] + set delete [expr int(rand() * 2)] + set bounce [expr int(rand() * 2)] + set attachments [lindex [list styNone styYes] [expr int(rand() * 2)]] + $T item style set $item delete styCheck bounce styCheck \ + status $status size styAny \ + from styAny subject styAny received styAny \ + attachments $attachments + if {$delete} { + $T item state forcolumn $item delete CHECK + } + if {$bounce} { + $T item state forcolumn $item bounce CHECK + } + set bytes [expr {512 + int(rand() * 1024 * 12)}] + set size [expr {$bytes / 1024 + 1}]KB + set seconds [expr {[clock seconds] - int(rand() * 100000)}] + set received [clock format $seconds -format "%d/%m/%y %I:%M %p"] + $T item text $item size $size from $from subject $subject received $received + $T item lastchild root $item + } + } + if 0 { + $T notify bind MailWasher { + %T item style set %I %C styOff + } + $T notify bind MailWasher { + %T item style set %I %C styOn + } + } + + set ::SortColumn received + $T notify bind $T { + if {[%T column compare %C == $SortColumn]} { + if {[%T column cget $SortColumn -arrow] eq "down"} { + set order -increasing + set arrow up + } else { + set order -decreasing + set arrow down + } + } else { + if {[%T column cget $SortColumn -arrow] eq "down"} { + set order -decreasing + set arrow down + } else { + set order -increasing + set arrow up + } + %T column configure $SortColumn -arrow none + set SortColumn %C + } + %T column configure %C -arrow $arrow + switch [%T column cget %C -tags] { + bounce - + delete { + %T item sort root $order -column %C -command [list DemoMailWasher::CompareOnOff %T %C] -column subject -dictionary + } + status { + %T item sort root $order -column %C -dictionary + } + from { + %T item sort root $order -column %C -dictionary -column subject -dictionary + } + subject { + %T item sort root $order -column %C -dictionary + } + size { + %T item sort root $order -column %C -dictionary -column subject -dictionary + } + received { + %T item sort root $order -column %C -dictionary -column subject -dictionary + } + attachments { + %T item sort root $order -column %C -dictionary -column subject -dictionary + } + } + } + + bind DemoMailWasher { + set id [%W identify %x %y] + if {$id eq ""} { + } elseif {[lindex $id 0] eq "header"} { + } else { + lassign $id what item where arg1 arg2 arg3 + if {$where eq "column"} { + if {[%W column tag expr $arg1 {delete || bounce}]} { + %W item state forcolumn $item $arg1 ~CHECK +# return -code break + } + } + } + } + + bindtags $T [list $T DemoMailWasher TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoMailWasher::CompareOnOff {T C item1 item2} { + set s1 [$T item state forcolumn $item1 $C] + set s2 [$T item state forcolumn $item2 $C] + if {$s1 eq $s2} { return 0 } + if {[lsearch -exact $s1 CHECK] == -1} { return -1 } + return 1 +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/mycomputer.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/mycomputer.tcl new file mode 100644 index 00000000..d0b94b1c --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/mycomputer.tcl @@ -0,0 +1,127 @@ +# Copyright (c) 2006-2011 Tim Baker + +namespace eval DemoMyComputer {} +proc DemoMyComputer::Init {T} { + + set font [.menubar cget -font] + if {[lsearch -exact [font names] DemoMyComputerHeaderFont] == -1} { + array set fontInfo [font actual $font] + set fontInfo(-weight) bold + eval font create DemoMyComputerHeaderFont [array get fontInfo] + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode browse -xscrollincrement 20 -xscrollsmoothing yes \ + -font $font + + # + # Create columns + # + + $T column create -text Name -tags name -width 200 + $T column create -text Type -tags type -width 120 + $T column create -text "Total Size" -tags size -justify right -width 100 \ + -arrowside left -arrowgravity right + $T column create -text "Free Space" -tags free -justify right -width 100 + $T column create -text Comments -tags comment -width 120 + + # + # Create elements + # + + $T element create txtHeader text -font [list DemoMyComputerHeaderFont] + $T element create txtName text -fill [list $::SystemHighlightText {selected focus}] \ + -lines 1 + $T element create txtOther text -lines 1 + $T element create elemRectSel rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] -showfocus yes + + $T gradient create G_divider -stops {{0.0 blue} {0.8 blue} {1.0 white}} \ + -steps 12 + $T element create rectDivider rect -fill G_divider -height 1 -width 250 + + # + # Create styles using the elements + # + + # header + set S [$T style create styHeader -orient vertical] + $T style elements $S {txtHeader rectDivider} + $T style layout $S txtHeader -padx 10 -pady {10 0} -expand ns + $T style layout $S rectDivider -pady {2 8} + + # name + set S [$T style create styName -orient horizontal] + $T style elements $S {elemRectSel txtName} + $T style layout $S txtName -padx {16 0} -squeeze x -expand ns + $T style layout $S elemRectSel -union [list txtName] -ipadx 2 -pady 1 -iexpand ns + + # other text + set S [$T style create styOther] + $T style elements $S txtOther + $T style layout $S txtOther -padx 6 -squeeze x -expand ns + + # + # Create items and assign styles + # + + foreach {name type size free comment} { + "Files Stored on This Computer" "" "" "" "" + "Shared Documents" "File Folder" "" "" "" + "Tim's Documents" "File Folder" "" "" "" + "Hard Disk Drives" "" "" "" "" + "Local Disk (C:)" "Local Disk" "55.8 GB" "1.84 GB" "" + "Devices with Removable Storage" "" "" "" "" + "3.5 Floppy (A:)" "3.5-Inch Floppy Disk" "" "" "" + "DVD Drive (D:)" "CD Drive" "" "" "" + "CD-RW Drive (E:)" "CD Drive" "" "" "" + "Other" "" "" "" "" + "My Logitech Pictures" "System Folder" "" "" "" + "Scanners and Cameras" "" "" "" "" + "Logitech QuickCam Messenger" "Digital camera" "" "" "" + } { + set I [$T item create] + if {$type eq ""} { + $T item style set $I first styHeader + $T item span $I first [$T column count] + # The headers are disabled so they can't be selected and + # keyboard navigation skips over them. + $T item enabled $I false + $T item text $I name $name + } else { + $T item style set $I name styName type styOther + $T item text $I name $name type $type + if {$size ne ""} { + $T item style set $I size styOther free styOther + $T item text $I size $size free $free + } + } + $T item lastchild root $I + } + +if 0 { + # List of lists: {column style element ...} specifying text elements + # the user can edit + TreeCtrl::SetEditable $T { + } + + # List of lists: {column style element ...} specifying elements + # the user can click on or select with the selection rectangle + TreeCtrl::SetSensitive $T { + {name styName txtName} + } + + # List of lists: {column style element ...} specifying elements + # added to the drag image when dragging selected items + TreeCtrl::SetDragImage $T { + {name styName txtName} + } + + bindtags $T [list $T TreeCtrlFileList TreeCtrl [winfo toplevel $T] all] +} + + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/outlook-folders.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/outlook-folders.tcl new file mode 100644 index 00000000..9dccb4ba --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/outlook-folders.tcl @@ -0,0 +1,248 @@ +# Copyright (c) 2002-2011 Tim Baker + +# +# Demo: Outlook Express folder list +# +namespace eval DemoOutlookFolders {} +proc DemoOutlookFolders::Init {T} { + + InitPics outlook-* + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -itemheight $height -selectmode browse \ + -showroot yes -showrootbutton no -showbuttons yes \ + -showlines [ShouldShowLines $T] + + $T configure -canvaspadx {4 0} -canvaspady {2 0} + + # + # Create columns + # + + $T column create -text Folders -tags C0 + $T configure -treecolumn C0 + + # + # Create custom item states. + # When an item has the custom "unread" state, the elemTxtName element + # uses a bold font and the elemTxtCount element is visible. + # + + $T item state define unread + + # + # Create elements + # + + $T element create elemImg image + $T element create elemTxtName text -fill [list $::SystemHighlightText {selected focus}] \ + -font [list DemoFontBold unread] -lines 1 + $T element create elemTxtCount text -fill blue + $T element create elemRectSel rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + + # + # Create styles using the elements + # + + # image + text + text + set S [$T style create styFolder] + $T style elements $S {elemRectSel elemImg elemTxtName elemTxtCount} + $T style layout $S elemImg -expand ns + $T style layout $S elemTxtName -padx 4 -expand ns -squeeze x + $T style layout $S elemTxtCount -expand ns -visible {yes unread no {}} + $T style layout $S elemRectSel -union [list elemTxtName] -iexpand ns -ipadx 2 + + # + # Create items and assign styles + # + + $T item style set root C0 $S + $T item element configure root C0 \ + elemImg -image outlook-main + \ + elemTxtName -text "Outlook Express" + + set parentList [list root {} {} {} {} {} {}] + set parent root + foreach {depth img text button unread} { + 0 local "Local Folders" yes 0 + 1 inbox Inbox no 5 + 1 outbox Outbox no 0 + 1 sent "Sent Items" no 0 + 1 deleted "Deleted Items" no 50 + 1 draft Drafts no 0 + 1 folder "Messages to Dad" no 0 + 1 folder "Messages to Sis" no 0 + 1 folder "Messages to Me" yes 5 + 2 folder "2001" no 0 + 2 folder "2000" no 0 + 2 folder "1999" no 0 + 0 server "news.gmane.org" yes 0 + 1 group "gmane.comp.lang.lua.general" no 498 + } { + set item [$T item create -button $button] + $T item style set $item C0 $S + $T item element configure $item C0 \ + elemImg -image outlook-$img + \ + elemTxtName -text $text + + if {$unread} { + $T item element configure $item C0 \ + elemTxtCount -text "($unread)" + $T item state set $item unread + } + + $T item lastchild [lindex $parentList $depth] $item + incr depth + set parentList [lreplace $parentList $depth $depth $item] + } + + return +} + +# +# Here is the original implementation which doesn't use custom states. +# It has 4 different item styles and 6 different elements. +# +proc DemoOutlookFolders::Init.orig {T} { + + InitPics outlook-* + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -itemheight $height -selectmode browse \ + -showroot yes -showrootbutton no -showbuttons yes \ + -showlines [ShouldShowLines $T] + + $T configure -canvaspadx {4 0} -canvaspady {2 0} + + # + # Create columns + # + + $T column create -text Folders -tags C0 + $T configure -treecolumn C0 + + # + # Create elements + # + + $T element create elemImgAny image + $T element create elemTxtRead text -fill [list $::SystemHighlightText {selected focus}] \ + -lines 1 + $T element create elemTxtUnread text -fill [list $::SystemHighlightText {selected focus}] \ + -font [list DemoFontBold] -lines 1 + $T element create elemTxtCount text -fill blue + $T element create elemImgFolder image -image outlook-folder + $T element create elemRectSel rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + + # + # Create styles using the elements + # + + # image + text + set S [$T style create styAnyRead] + $T style elements $S {elemRectSel elemImgAny elemTxtRead} + $T style layout $S elemImgAny -expand ns + $T style layout $S elemTxtRead -padx {4 0} -expand ns -squeeze x + $T style layout $S elemRectSel -union [list elemTxtRead] -iexpand ns -ipadx 2 + + # image + text + text + set S [$T style create styAnyUnread] + $T style elements $S {elemRectSel elemImgAny elemTxtUnread elemTxtCount} + $T style layout $S elemImgAny -expand ns + $T style layout $S elemTxtUnread -padx 4 -expand ns -squeeze x + $T style layout $S elemTxtCount -expand ns + $T style layout $S elemRectSel -union [list elemTxtUnread] -iexpand ns -ipadx 2 + + # folder + text + set S [$T style create styFolderRead] + $T style elements $S {elemRectSel elemImgFolder elemTxtRead} + $T style layout $S elemImgFolder -expand ns + $T style layout $S elemTxtRead -padx {4 0} -expand ns -squeeze x + $T style layout $S elemRectSel -union [list elemTxtRead] -iexpand ns -ipadx 2 + + # folder + text + text + set S [$T style create styFolderUnread] + $T style elements $S {elemRectSel elemImgFolder elemTxtUnread elemTxtCount} + $T style layout $S elemImgFolder -expand ns + $T style layout $S elemTxtUnread -padx 4 -expand ns -squeeze x + $T style layout $S elemTxtCount -expand ns + $T style layout $S elemRectSel -union [list elemTxtUnread] -iexpand ns -ipadx 2 + + # + # Create items and assign styles + # + + $T item style set root C0 styAnyRead + $T item element configure root C0 \ + elemImgAny -image outlook-main + \ + elemTxtRead -text "Outlook Express" + + set parentList [list root {} {} {} {} {} {}] + set parent root + foreach {depth img text button unread} { + 0 local "Local Folders" yes 0 + 1 inbox Inbox no 5 + 1 outbox Outbox no 0 + 1 sent "Sent Items" no 0 + 1 deleted "Deleted Items" no 50 + 1 draft Drafts no 0 + 1 folder "Messages to Dad" no 0 + 1 folder "Messages to Sis" no 0 + 1 folder "Messages to Me" yes 5 + 2 folder "2001" no 0 + 2 folder "2000" no 0 + 2 folder "1999" no 0 + 0 server "news.gmane.org" yes 0 + 1 group "gmane.comp.lang.lua.general" no 498 + } { + set item [$T item create -button $button] + if {[string equal $img folder]} { + if {$unread} { + $T item style set $item C0 styFolderUnread + $T item element configure $item C0 \ + elemTxtUnread -text $text + \ + elemTxtCount -text "($unread)" + } else { + $T item style set $item C0 styFolderRead + $T item element configure $item C0 elemTxtRead -text $text + } + } else { + if {$unread} { + $T item style set $item C0 styAnyUnread + $T item element configure $item C0 \ + elemImgAny -image outlook-$img + \ + elemTxtUnread -text $text + \ + elemTxtCount -text "($unread)" + } else { + $T item style set $item C0 styAnyRead + $T item element configure $item C0 \ + elemImgAny -image outlook-$img + \ + elemTxtRead -text $text + } + } + $T item lastchild [lindex $parentList $depth] $item + incr depth + set parentList [lreplace $parentList $depth $depth $item] + } + + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/outlook-newgroup.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/outlook-newgroup.tcl new file mode 100644 index 00000000..b115f6dd --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/outlook-newgroup.tcl @@ -0,0 +1,494 @@ +# Copyright (c) 2002-2011 Tim Baker + +# +# Demo: Outlook Express newsgroup messages +# +namespace eval DemoOutlookNewsgroup {} +proc DemoOutlookNewsgroup::Init {T} { + + variable Priv + + InitPics outlook-* + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -itemheight $height -selectmode browse \ + -showroot no -showrootbutton no -showbuttons yes -showlines no \ + -xscrollincrement 20 -xscrollsmoothing yes + + switch -- [$T theme platform] { + visualstyles { + $T theme setwindowtheme "Explorer" + } + } + + # + # Create columns + # + + $T column create -image outlook-clip -tags clip + $T column create -image outlook-arrow -tags arrow + $T column create -image outlook-watch -tags watch + $T column create -text Subject -width 250 -tags subject + $T column create -text From -width 150 -tags from + $T column create -text Sent -width 150 -tags sent + $T column create -text Size -width 60 -justify right -tags size + +# $T column configure all -gridrightcolor #ebf4fe + + # Would be nice if I could specify a column -tag too + # *blink* The amazing code Genie makes it so!!! + $T configure -treecolumn subject + + # State for a read message + $T item state define read + + # State for a message with unread descendants + $T item state define unread + + # States for "open" rectangles. This is an ugly hack to get the + # active outline to span multiple columns. + $T item state define openWE + $T item state define openE + $T item state define openW + + # + # Create elements + # + + $T element create elemImg image -image { + outlook-read-2Sel {selected read unread !open} + outlook-read-2 {read unread !open} + outlook-readSel {selected read} + outlook-read {read} + outlook-unreadSel {selected} + outlook-unread {} + } + + $T element create elemTxt text -fill [list $::SystemHighlightText {selected focus}] \ + -font [list DemoFontBold {read unread !open} DemoFontBold {!read}] -lines 1 + + $T element create sel rect \ + -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -open {we openWE e openE w openW} -showfocus yes + + # + # Create styles using the elements + # + + # Image + text + set S [$T style create s1] + $T style elements $S {sel elemImg elemTxt} + $T style layout $S elemImg -expand ns + $T style layout $S elemTxt -padx {2 6} -squeeze x -expand ns + $T style layout $S sel -union [list elemTxt] -iexpand nes -ipadx {2 0} + + # Text + set S [$T style create s2] + $T style elements $S {sel elemTxt} + $T style layout $S elemTxt -padx 6 -squeeze x -expand ns + $T style layout $S sel -detach yes -iexpand xy + + # Set default item styles + $T column configure subject -itemstyle s1 + $T column configure from -itemstyle s2 + $T column configure sent -itemstyle s2 + $T column configure size -itemstyle s2 + + # + # Create items and assign styles + # + + set msgCnt 100 + + set thread 0 + set Priv(count,0) 0 + set items [$T item id root] + for {set i 1} {$i < $msgCnt} {incr i} { + set itemi [$T item create] + while 1 { + set j [expr {int(rand() * $i)}] + set itemj [lindex $items $j] + if {$j == 0} break + if {[$T depth $itemj] == 5} continue + if {$Priv(count,$Priv(thread,$itemj)) == 15} continue + break + } + $T item lastchild $itemj $itemi + + set Priv(read,$itemi) [expr rand() * 2 > 1] + if {$j == 0} { + set Priv(thread,$itemi) [incr thread] + set Priv(seconds,$itemi) [expr {[clock seconds] - int(rand() * 500000)}] + set Priv(seconds2,$itemi) $Priv(seconds,$itemi) + set Priv(count,$thread) 1 + } else { + set Priv(thread,$itemi) $Priv(thread,$itemj) + set Priv(seconds,$itemi) [expr {$Priv(seconds2,$itemj) + int(rand() * 10000)}] + set Priv(seconds2,$itemi) $Priv(seconds,$itemi) + set Priv(seconds2,$itemj) $Priv(seconds,$itemi) + incr Priv(count,$Priv(thread,$itemj)) + } + lappend items $itemi + } + + for {set i 1} {$i < $msgCnt} {incr i} { + set itemi [lindex $items $i] + set subject "This is thread number $Priv(thread,$itemi)" + set from somebody@somewhere.net + set sent [clock format $Priv(seconds,$itemi) -format "%d/%m/%y %I:%M %p"] + set size [expr {1 + int(rand() * 10)}]KB + + # This message has been read + if {$Priv(read,$itemi)} { + $T item state set $itemi read + } + + # This message has unread descendants + if {[AnyUnreadDescendants $T $itemi]} { + $T item state set $itemi unread + } + + if {[$T item numchildren $itemi]} { + $T item configure $itemi -button yes + + # Collapse some messages + if {rand() * 2 > 1} { + $T item collapse $itemi + } + } + +# $T item style set $i 3 s1 4 s2.we 5 s2.we 6 s2.w + $T item text $itemi subject $subject from $from sent $sent size $size + + $T item state forcolumn $itemi subject openE + $T item state forcolumn $itemi from openWE + $T item state forcolumn $itemi sent openWE + $T item state forcolumn $itemi size openW + } + + # Do something when the selection changes + $T notify bind $T { + DemoOutlookNewsgroup::Selection %T + } + + # Fix the display when a column is dragged + $T notify bind $T { + %T column move %C %b + DemoOutlookNewsgroup::FixItemStyles %T + } + + # Fix the display when a column's visibility changes + $T notify bind $T { + DemoOutlookNewsgroup::FixItemStyles %T + } + + return +} + +proc DemoOutlookNewsgroup::Selection {T} { + variable Priv + # One item is selected + if {[$T selection count] == 1} { + if {[info exists Priv(afterId)]} { + after cancel $Priv(afterId) + } + set Priv(afterId,item) [$T selection get 0] + set Priv(afterId) [after 500 DemoOutlookNewsgroup::MessageReadDelayed] + } + return +} + +proc DemoOutlookNewsgroup::MessageReadDelayed {} { + + variable Priv + + set T [DemoList] + + unset Priv(afterId) + set I $Priv(afterId,item) + if {![$T selection includes $I]} return + + # This message is not read + if {!$Priv(read,$I)} { + + # Read the message + $T item state set $I read + set Priv(read,$I) 1 + + # Check ancestors (except root) + foreach I2 [lrange [$T item ancestors $I] 0 end-1] { + + # This ancestor has no more unread descendants + if {![AnyUnreadDescendants $T $I2]} { + $T item state set $I2 !unread + } + } + } + return +} + +# Alternate implementation that does not rely on run-time states +proc DemoOutlookNewsgroup::Init_2 {T} { + + global Message + + InitPics outlook-* + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -itemheight $height -selectmode browse \ + -showroot no -showrootbutton no -showbuttons yes -showlines no + + # + # Create columns + # + + $T column create -image outlook-clip -tags clip + $T column create -image outlook-arrow -tags arrow + $T column create -image outlook-watch -tags watch + $T column create -text Subject -width 250 -tags subject + $T column create -text From -width 150 -tags from + $T column create -text Sent -width 150 -tags sent + $T column create -text Size -width 60 -justify right -tags size + + $T configure -treecolumn 3 + + # + # Create elements + # + + $T element create image.unread image -image outlook-unread + $T element create image.read image -image outlook-read + $T element create image.read2 image -image outlook-read-2 + $T element create text.read text -fill [list $::SystemHighlightText {selected focus}] \ + -lines 1 + $T element create text.unread text -fill [list $::SystemHighlightText {selected focus}] \ + -font [list DemoFontBold] -lines 1 + $T element create sel.e rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] -open e -showfocus yes + $T element create sel.w rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] -open w -showfocus yes + $T element create sel.we rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] -open we -showfocus yes + + # + # Create styles using the elements + # + + # Image + text + set S [$T style create unread] + $T style elements $S {sel.e image.unread text.unread} + $T style layout $S image.unread -expand ns + $T style layout $S text.unread -padx {2 6} -squeeze x -expand ns + $T style layout $S sel.e -union [list text.unread] -iexpand nes -ipadx {2 0} + + # Image + text + set S [$T style create read] + $T style elements $S {sel.e image.read text.read} + $T style layout $S image.read -expand ns + $T style layout $S text.read -padx {2 6} -squeeze x -expand ns + $T style layout $S sel.e -union [list text.read] -iexpand nes -ipadx {2 0} + + # Image + text + set S [$T style create read2] + $T style elements $S {sel.e image.read2 text.unread} + $T style layout $S image.read2 -expand ns + $T style layout $S text.unread -padx {2 6} -squeeze x -expand ns + $T style layout $S sel.e -union [list text.unread] -iexpand nes -ipadx {2 0} + + # Text + set S [$T style create unread.we] + $T style elements $S {sel.we text.unread} + $T style layout $S text.unread -padx 6 -squeeze x -expand ns + $T style layout $S sel.we -detach yes -iexpand xy + + # Text + set S [$T style create read.we] + $T style elements $S {sel.we text.read} + $T style layout $S text.read -padx 6 -squeeze x -expand ns + $T style layout $S sel.we -detach yes -iexpand xy + + # Text + set S [$T style create unread.w] + $T style elements $S {sel.w text.unread} + $T style layout $S text.unread -padx 6 -squeeze x -expand ns + $T style layout $S sel.w -detach yes -iexpand xy + + # Text + set S [$T style create read.w] + $T style elements $S {sel.w text.read} + $T style layout $S text.read -padx 6 -squeeze x -expand ns + $T style layout $S sel.w -detach yes -iexpand xy + + # + # Create items and assign styles + # + + set msgCnt 100 + + set thread 0 + set Priv(count,0) 0 + for {set i 1} {$i < $msgCnt} {incr i} { + $T item create + while 1 { + set j [expr {int(rand() * $i)}] + if {$j == 0} break + if {[$T depth $j] == 5} continue + if {$Priv(count,$Priv(thread,$j)) == 15} continue + break + } + $T item lastchild $j $i + + set Priv(read,$i) [expr rand() * 2 > 1] + if {$j == 0} { + set Priv(thread,$i) [incr thread] + set Priv(seconds,$i) [expr {[clock seconds] - int(rand() * 500000)}] + set Priv(seconds2,$i) $Priv(seconds,$i) + set Priv(count,$thread) 1 + } else { + set Priv(thread,$i) $Priv(thread,$j) + set Priv(seconds,$i) [expr {$Priv(seconds2,$j) + int(rand() * 10000)}] + set Priv(seconds2,$i) $Priv(seconds,$i) + set Priv(seconds2,$j) $Priv(seconds,$i) + incr Priv(count,$Priv(thread,$j)) + } + } + + for {set i 1} {$i < $msgCnt} {incr i} { + set subject "This is thread number $Priv(thread,$i)" + set from somebody@somewhere.net + set sent [clock format $Priv(seconds,$i) -format "%d/%m/%y %I:%M %p"] + set size [expr {1 + int(rand() * 10)}]KB + if {$Priv(read,$i)} { + set style read + set style2 read + } else { + set style unread + set style2 unread + } + $T item style set $i 3 $style 4 $style2.we 5 $style2.we 6 $style2.w + $T item text $i 3 $subject 4 $from 5 $sent 6 $size + if {[$T item numchildren $i]} { + $T item configure $i -button yes + } + } + + $T notify bind $T { + if {[%T selection count] == 1} { + set I [%T selection get 0] + if {!$Priv(read,$I)} { + if {[%T item isopen $I] || ![AnyUnreadDescendants %T $I]} { + # unread ->read + %T item style map $I subject read {text.unread text.read} + %T item style map $I from read.we {text.unread text.read} + %T item style map $I sent read.we {text.unread text.read} + %T item style map $I size read.w {text.unread text.read} + } else { + # unread -> read2 + %T item style map $I subject read2 {text.unread text.unread} + } + set Priv(read,$I) 1 + DisplayStylesInItem $I + } + } + } + + $T notify bind $T { + if {$Priv(read,%I) && [AnyUnreadDescendants %T %I]} { + # read2 -> read + %T item style map %I subject read {text.unread text.read} + # unread -> read + %T item style map %I from read.we {text.unread text.read} + %T item style map %I sent read.we {text.unread text.read} + %T item style map %I size read.w {text.unread text.read} + } + } + + $T notify bind $T { + if {$Priv(read,%I) && [AnyUnreadDescendants %T %I]} { + # read -> read2 + %T item style map %I subject read2 {text.read text.unread} + # read -> unread + %T item style map %I from unread.we {text.read text.unread} + %T item style map %I sent unread.we {text.read text.unread} + %T item style map %I size unread.w {text.read text.unread} + } + } + + for {set i 1} {$i < $msgCnt} {incr i} { + if {rand() * 2 > 1} { + if {[$T item numchildren $i]} { + $T item collapse $i + } + } + } + + return +} + +proc DemoOutlookNewsgroup::AnyUnreadDescendants {T I} { + + variable Priv + + foreach item [$T item descendants $I] { + if {!$Priv(read,$item)} { + return 1 + } + } + return 0 +} + +proc DemoOutlookNewsgroup::FixItemStyles {T} { + + set columns1 [$T column id "visible tag clip||arrow||watch !tail"] + set columns2 [$T column id "visible tag !(clip||arrow||watch) !tail"] + + foreach C [$T column id "visible !tail"] { + + # The clip/arrow/watch columns only get a style when they are + # between the first and last text-containing columns. + if {[lsearch -exact $columns1 $C] != -1} { + if {[$T column compare $C > [lindex $columns2 0]] && + [$T column compare $C < [lindex $columns2 end]]} { + $T item style set all $C s2 + $T item state forcolumn all $C {!openW !openE openWE} + } else { + $T item style set all $C "" + } + continue + } + + # The text-containing columns need their styles set such that the + # active outline of the selected item extends from left to right. + # Also, the left-most text-containing column is the tree column + # and displays the icon. + if {$C eq [lindex $columns2 0]} { + $T configure -treecolumn $C + set S s1 + set state openE + } elseif {$C eq [lindex $columns2 end]} { + set S s2 + set state openW + } else { + set S s2 + set state openWE + } + $T item state forcolumn all $C [list !openWE !openE !openW $state] + + # Change the style, but keep the text so we don't have to reset it. + $T item style map all $C $S {elemTxt elemTxt} + } + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-dll.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-dll.gif new file mode 100644 index 00000000..09170c0e Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-dll.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-exe.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-exe.gif new file mode 100644 index 00000000..e19aac1a Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-exe.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-file.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-file.gif new file mode 100644 index 00000000..6c752312 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-file.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-folder.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-folder.gif new file mode 100644 index 00000000..186c9749 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-folder.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-txt.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-txt.gif new file mode 100644 index 00000000..a9349258 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/big-txt.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/checked.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/checked.gif new file mode 100644 index 00000000..3b9b176a Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/checked.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/feather.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/feather.gif new file mode 100644 index 00000000..74592a2a Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/feather.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/file.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/file.gif new file mode 100644 index 00000000..a64c2a06 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/file.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/folder-closed.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/folder-closed.gif new file mode 100644 index 00000000..0a064376 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/folder-closed.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/folder-open.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/folder-open.gif new file mode 100644 index 00000000..3fac27ff Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/folder-open.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-book-closed.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-book-closed.gif new file mode 100644 index 00000000..0a0497bf Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-book-closed.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-book-open.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-book-open.gif new file mode 100644 index 00000000..40656c51 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-book-open.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-page.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-page.gif new file mode 100644 index 00000000..e1ce1d72 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/help-page.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-01.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-01.gif new file mode 100644 index 00000000..5fd92155 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-01.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-02.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-02.gif new file mode 100644 index 00000000..3d2d1c17 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-02.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-03.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-03.gif new file mode 100644 index 00000000..9fccf12b Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-03.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-04.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-04.gif new file mode 100644 index 00000000..eff851c9 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-04.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-05.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-05.gif new file mode 100644 index 00000000..ad00c827 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-05.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-06.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-06.gif new file mode 100644 index 00000000..238bf162 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-06.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-07.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-07.gif new file mode 100644 index 00000000..a9287e1b Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/imovie-07.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-check-off.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-check-off.gif new file mode 100644 index 00000000..e64866a3 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-check-off.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-check-on.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-check-on.gif new file mode 100644 index 00000000..cf652bef Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-check-on.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-print.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-print.gif new file mode 100644 index 00000000..7ac25b10 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-print.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-radio-off.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-radio-off.gif new file mode 100644 index 00000000..90ef6297 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-radio-off.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-radio-on.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-radio-on.gif new file mode 100644 index 00000000..9de742c1 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-radio-on.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-search.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-search.gif new file mode 100644 index 00000000..1f9a0477 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-search.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-security.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-security.gif new file mode 100644 index 00000000..86d39437 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/internet-security.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/mac-collapse.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/mac-collapse.gif new file mode 100644 index 00000000..81302c80 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/mac-collapse.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/mac-expand.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/mac-expand.gif new file mode 100644 index 00000000..0a2cd800 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/mac-expand.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-arrow.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-arrow.gif new file mode 100644 index 00000000..c378373e Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-arrow.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-clip.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-clip.gif new file mode 100644 index 00000000..62bbf9ca Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-clip.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-deleted.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-deleted.gif new file mode 100644 index 00000000..7cc8369b Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-deleted.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-draft.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-draft.gif new file mode 100644 index 00000000..f1958505 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-draft.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-folder.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-folder.gif new file mode 100644 index 00000000..b3f73356 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-folder.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-group.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-group.gif new file mode 100644 index 00000000..29ad9b46 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-group.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-inbox.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-inbox.gif new file mode 100644 index 00000000..f41d8044 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-inbox.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-local.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-local.gif new file mode 100644 index 00000000..0c74970d Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-local.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-main.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-main.gif new file mode 100644 index 00000000..92325fa8 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-main.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-outbox.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-outbox.gif new file mode 100644 index 00000000..c7e80527 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-outbox.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-read-2.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-read-2.gif new file mode 100644 index 00000000..2f15a3af Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-read-2.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-read.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-read.gif new file mode 100644 index 00000000..a6f95620 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-read.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-sent.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-sent.gif new file mode 100644 index 00000000..963b56c4 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-sent.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-server.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-server.gif new file mode 100644 index 00000000..c950845d Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-server.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-unread.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-unread.gif new file mode 100644 index 00000000..3df4b994 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-unread.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-watch.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-watch.gif new file mode 100644 index 00000000..1077ce96 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/outlook-watch.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/sky.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/sky.gif new file mode 100644 index 00000000..b7fbf14a Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/sky.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-dll.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-dll.gif new file mode 100644 index 00000000..d8875ec2 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-dll.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-exe.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-exe.gif new file mode 100644 index 00000000..69d30bea Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-exe.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-file.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-file.gif new file mode 100644 index 00000000..f3406628 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-file.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-folder.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-folder.gif new file mode 100644 index 00000000..ad1b24da Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-folder.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-txt.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-txt.gif new file mode 100644 index 00000000..cdc7cbfe Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/small-txt.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/unchecked.gif b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/unchecked.gif new file mode 100644 index 00000000..833e4826 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/pics/unchecked.gif differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/random.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/random.tcl new file mode 100644 index 00000000..bc8d0518 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/random.tcl @@ -0,0 +1,410 @@ +# Copyright (c) 2002-2011 Tim Baker + +set RandomN 500 +set RandomDepth 5 + +# +# Demo: random N items +# +namespace eval DemoRandom {} +proc DemoRandom::Init {T} { + + InitPics folder-* small-* + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -itemheight $height -selectmode extended \ + -showroot yes -showrootbutton yes -showbuttons yes \ + -showlines [ShouldShowLines $T] \ + -scrollmargin 16 -xscrolldelay "500 50" -yscrolldelay "500 50" + + # + # Create columns + # + + $T column create -expand yes -weight 4 -text Item -itembackground {#e0e8f0 {}} \ + -tags colItem + $T column create -text Parent -justify center -itembackground {gray90 {}} \ + -uniform a -expand yes -tags colParent + $T column create -text Depth -justify center -itembackground {linen {}} \ + -uniform a -expand yes -tags colDepth + + $T configure -treecolumn colItem + + # + # Create elements + # + + $T element create elemImgFolder image -image {folder-open {open} folder-closed {}} + $T element create elemImgFile image -image small-file + $T element create elemTxtName text -wrap none \ + -fill [list $::SystemHighlightText {selected focus}] + $T element create elemTxtCount text -fill blue + $T element create elemTxtAny text + $T element create elemRectSel rect -showfocus yes \ + -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] + + # + # Create styles using the elements + # + + set S [$T style create styFolder] + $T style elements $S {elemRectSel elemImgFolder elemTxtName elemTxtCount} + $T style layout $S elemImgFolder -padx {0 4} -expand ns + $T style layout $S elemTxtName -minwidth 12 -padx {0 4} -expand ns -squeeze x + $T style layout $S elemTxtCount -padx {0 6} -expand ns + $T style layout $S elemRectSel -union [list elemTxtName] -iexpand ns -ipadx 2 + + set S [$T style create styFile] + $T style elements $S {elemRectSel elemImgFile elemTxtName} + $T style layout $S elemImgFile -padx {0 4} -expand ns + $T style layout $S elemTxtName -minwidth 12 -padx {0 4} -expand ns -squeeze x + $T style layout $S elemRectSel -union [list elemTxtName] -iexpand ns -ipadx 2 + + set S [$T style create styAny] + $T style elements $S {elemTxtAny} + $T style layout $S elemTxtAny -padx 6 -expand ns + + TreeCtrl::SetSensitive $T { + {colItem styFolder elemRectSel elemImgFolder elemTxtName} + {colItem styFile elemRectSel elemImgFile elemTxtName} + } + TreeCtrl::SetDragImage $T { + {colItem styFolder elemImgFolder elemTxtName} + {colItem styFile elemImgFile elemTxtName} + } + + # + # Create items and assign styles + # + + TimerStart + $T item configure root -button auto + set items [$T item create -count [expr {$::RandomN - 1}] -button auto] + set added root + foreach itemi $items { + set j [expr {int(rand() * [llength $added])}] + set itemj [lindex $added $j] + if {[$T depth $itemj] < $::RandomDepth - 1} { + lappend added $itemi + } + if {rand() * 2 > 1} { + $T item collapse $itemi + } + if {rand() * 2 > 1} { + $T item lastchild $itemj $itemi + } else { + $T item firstchild $itemj $itemi + } + } + puts "created $::RandomN-1 items in [TimerStop] seconds" + + TimerStart + lappend items [$T item id root] + foreach item $items { + set numChildren [$T item numchildren $item] + if {$numChildren} { + $T item style set $item colItem styFolder colParent styAny colDepth styAny + $T item element configure $item \ + colItem elemTxtName -text "Item $item" + elemTxtCount -text "($numChildren)" , \ + colParent elemTxtAny -text "[$T item parent $item]" , \ + colDepth elemTxtAny -text "[$T depth $item]" + } else { + $T item style set $item colItem styFile colParent styAny colDepth styAny + $T item element configure $item \ + colItem elemTxtName -text "Item $item" , \ + colParent elemTxtAny -text "[$T item parent $item]" , \ + colDepth elemTxtAny -text "[$T depth $item]" + } + } + puts "configured $::RandomN items in [TimerStop] seconds" + + bind DemoRandom { + TreeCtrl::DoubleButton1 %W %x %y + break + } + bind DemoRandom { + set TreeCtrl::Priv(selectMode) toggle + DemoRandom::Button1 %W %x %y + break + } + bind DemoRandom { + set TreeCtrl::Priv(selectMode) add + DemoRandom::Button1 %W %x %y + break + } + bind DemoRandom { + set TreeCtrl::Priv(selectMode) set + DemoRandom::Button1 %W %x %y + break + } + bind DemoRandom { + DemoRandom::Motion1 %W %x %y + break + } + bind DemoRandom { + DemoRandom::Release1 %W %x %y + break + } + + bindtags $T [list $T DemoRandom TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoRandom::Button1 {T x y} { + variable ::TreeCtrl::Priv + focus $T + set id [$T identify $x $y] + set Priv(buttonMode) "" + + # Click outside any item + if {$id eq ""} { + $T selection clear + + # Click in header + } elseif {[lindex $id 0] eq "header"} { + TreeCtrl::ButtonPress1 $T $x $y + + # Click in item + } else { + lassign $id where item arg1 arg2 arg3 arg4 + switch $arg1 { + button { + TreeCtrl::ButtonPress1 $T $x $y + } + line { + TreeCtrl::ButtonPress1 $T $x $y + } + column { + if {![TreeCtrl::IsSensitive $T $x $y]} { + $T selection clear + return + } + + set Priv(drag,motion) 0 + set Priv(drag,click,x) $x + set Priv(drag,click,y) $y + set Priv(drag,x) [$T canvasx $x] + set Priv(drag,y) [$T canvasy $y] + set Priv(drop) "" + + if {$Priv(selectMode) eq "add"} { + TreeCtrl::BeginExtend $T $item + } elseif {$Priv(selectMode) eq "toggle"} { + TreeCtrl::BeginToggle $T $item + } elseif {![$T selection includes $item]} { + TreeCtrl::BeginSelect $T $item + } + $T activate $item + + if {[$T selection includes $item]} { + set Priv(buttonMode) drag + } + } + } + } + return +} + +proc DemoRandom::Motion1 {T x y} { + variable ::TreeCtrl::Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + "drag" { + set Priv(autoscan,command,$T) {DemoRandom::Motion %T %x %y} + TreeCtrl::AutoScanCheck $T $x $y + Motion $T $x $y + } + default { + TreeCtrl::Motion1 $T $x $y + } + } + return +} + +proc DemoRandom::Motion {T x y} { + variable ::TreeCtrl::Priv + switch $Priv(buttonMode) { + "drag" { + if {!$Priv(drag,motion)} { + # Detect initial mouse movement + if {(abs($x - $Priv(drag,click,x)) <= 4) && + (abs($y - $Priv(drag,click,y)) <= 4)} return + + set Priv(selection) [$T selection get] + set Priv(drop) "" + $T dragimage clear + # For each selected item, add 2nd and 3rd elements of + # column "item" to the dragimage + foreach I $Priv(selection) { + foreach list $Priv(dragimage,$T) { + set C [lindex $list 0] + set S [lindex $list 1] + if {[$T item style set $I $C] eq $S} { + eval $T dragimage add $I $C [lrange $list 2 end] + } + } + } + set Priv(drag,motion) 1 + } + + # Find the item under the cursor + set cursor X_cursor + set drop "" + set id [$T identify $x $y] + if {[TreeCtrl::IsSensitive $T $x $y]} { + set item [lindex $id 1] + # If the item is not in the pre-drag selection + # (i.e. not being dragged) see if we can drop on it + if {[lsearch -exact $Priv(selection) $item] == -1} { + set drop $item + # We can drop if dragged item isn't an ancestor + foreach item2 $Priv(selection) { + if {[$T item isancestor $item2 $item]} { + set drop "" + break + } + } + if {$drop ne ""} { + scan [$T item bbox $drop] "%d %d %d %d" x1 y1 x2 y2 + if {$y < $y1 + 3} { + set cursor top_side + set Priv(drop,pos) prevsibling + } elseif {$y >= $y2 - 3} { + set cursor bottom_side + set Priv(drop,pos) nextsibling + } else { + set cursor "" + set Priv(drop,pos) lastchild + } + } + } + } + + if {[$T cget -cursor] ne $cursor} { + $T configure -cursor $cursor + } + + # Select the item under the cursor (if any) and deselect + # the previous drop-item (if any) + $T selection modify $drop $Priv(drop) + set Priv(drop) $drop + + # Show the dragimage in its new position + set x [expr {[$T canvasx $x] - $Priv(drag,x)}] + set y [expr {[$T canvasy $y] - $Priv(drag,y)}] + $T dragimage offset $x $y + $T dragimage configure -visible yes + } + default { + TreeCtrl::Motion1 $T $x $y + } + } + return +} + +proc DemoRandom::Release1 {T x y} { + variable ::TreeCtrl::Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + "drag" { + TreeCtrl::AutoScanCancel $T + $T dragimage configure -visible no + $T selection modify {} $Priv(drop) + $T configure -cursor "" + if {$Priv(drop) ne ""} { + Drop $T $Priv(drop) $Priv(selection) $Priv(drop,pos) + } + unset Priv(buttonMode) + } + default { + TreeCtrl::Release1 $T $x $y + } + } + return +} + +proc DemoRandom::Drop {T target source pos} { + set parentList {} + switch -- $pos { + lastchild { set parent $target } + prevsibling { set parent [$T item parent $target] } + nextsibling { set parent [$T item parent $target] } + } + foreach item $source { + + # Ignore any item whose ancestor is also selected + set ignore 0 + foreach ancestor [$T item ancestors $item] { + if {[lsearch -exact $source $ancestor] != -1} { + set ignore 1 + break + } + } + if {$ignore} continue + + # Update the old parent of this moved item later + if {[lsearch -exact $parentList $item] == -1} { + lappend parentList [$T item parent $item] + } + + # Add to target + $T item $pos $target $item + + # Update text: parent + $T item element configure $item colParent elemTxtAny -text $parent + + # Update text: depth + $T item element configure $item colDepth elemTxtAny -text [$T depth $item] + + # Recursively update text: depth + foreach item [$T item descendants $item] { + $T item element configure $item colDepth elemTxtAny -text [$T depth $item] + } + } + + # Update items that lost some children + foreach item $parentList { + set numChildren [$T item numchildren $item] + if {$numChildren == 0} { + $T item style map $item colItem styFile {elemTxtName elemTxtName} + } else { + $T item element configure $item colItem elemTxtCount -text "($numChildren)" + } + } + + # Update the target that gained some children + if {[$T item style set $parent colItem] ne "styFolder"} { + $T item style map $parent colItem styFolder {elemTxtName elemTxtName} + } + set numChildren [$T item numchildren $parent] + $T item element configure $parent colItem elemTxtCount -text "($numChildren)" + return +} + +# +# Demo: random N items, button images +# +namespace eval DemoRandom2 { + proc Init {T} { DemoRandom::Init2 $T } +} +proc DemoRandom::Init2 {T} { + + Init $T + + InitPics mac-* + + $T configure -buttonimage {mac-collapse open mac-expand {}} \ + -showlines no + + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/span.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/span.tcl new file mode 100644 index 00000000..0fe9de8e --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/span.tcl @@ -0,0 +1,128 @@ +# Copyright (c) 2006-2011 Tim Baker + +# +# Demo: Column span +# +namespace eval DemoSpan {} +proc DemoSpan::Init {T} { + + variable Priv + + set width [font measure DemoFont "Span 1"] + incr width 4 + + # + # Configure the treectrl widget + # + + $T configure \ + -showbuttons no \ + -showlines no \ + -showroot no \ + -xscrollincrement $width + + # + # Create columns + # + + for {set i 0} {$i < 100} {incr i} { + $T column create -itemjustify left -justify center -text "$i" \ + -tags C$i + } + + # + # Create elements + # + + $T item state define mouseover + + for {set i 1} {$i <= 20} {incr i} { + set color gray[expr {50 + $i * 2}] + $T element create e$i rect -width [expr {$i * $width}] -height 20 \ + -fill [list white mouseover $color {}] -outlinewidth 1 \ + -outline gray70 + if {[winfo depth .] >= 16} { + lassign [winfo rgb . $color] r g b + # Can't use min() on 8.4 + set r [expr {int($r * 1.3)}] + if {$r > 65535} { set r 65535 } + set g [expr {int($g * 1.3)}] + if {$g > 65535} { set g 65535 } + set b [expr {int($b * 1.3)}] + if {$b > 65535} { set b 65535 } + + #set r [expr {int(min(65535,$r * 1.3))}] + #set g [expr {int(min(65535,$g * 1.3))}] + #set b [expr {int(min(65535,$b * 1.3))}] + + set color2 [format "#%04x%04x%04x" $r $g $b] + $T gradient create g$i -steps 16 \ + -stops [list [list 0.0 $color] [list 0.5 $color] [list 1.0 $color2]] +# -stops [list [list 0.0 $color] [list 1.0 $color2]] + $T element configure e$i -fill {white mouseover} \ + -fill [list white mouseover g$i {}] + } + $T element create t$i text -text "Span $i" -lines 1 + } + + # + # Create styles using the elements + # + + for {set i 1} {$i <= 20} {incr i} { + set S [$T style create s$i] + $T style elements $S [list e$i t$i] + $T style layout $S e$i -detach yes -iexpand x -squeeze x + $T style layout $S t$i -expand ns -padx 2 -squeeze x + } + + # + # Create items and assign styles + # + + foreach I [$T item create -count 100 -parent root] { + for {set i 0} {$i < [$T column count]} {} { + set span [expr {int(rand() * 20) + 1}] + if {$span > [$T column count] - $i} { + set span [expr {[$T column count] - $i}] + } + $T item style set $I C$i s$span + $T item span $I C$i $span + incr i $span + } + } + + bind DemoSpan { + DemoSpan::Motion %W %x %y + } + set Priv(prev) "" + bindtags $T [list $T DemoSpan TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoSpan::Motion {w x y} { + variable Priv + set id [$w identify $x $y] + if {$id eq ""} { + } elseif {[lindex $id 0] eq "header"} { + } elseif {[lindex $id 0] eq "item"} { + set item [lindex $id 1] + set column [lindex $id 3] + set curr [list $item $column] + if {$curr ne $Priv(prev)} { + if {$Priv(prev) ne ""} { + eval $w item state forcolumn $Priv(prev) !mouseover + } + $w item state forcolumn $item $column mouseover + set Priv(prev) $curr + } + return + } + if {$Priv(prev) ne ""} { + eval $w item state forcolumn $Priv(prev) !mouseover + set Priv(prev) "" + } + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/style-editor.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/style-editor.tcl new file mode 100644 index 00000000..f13501c1 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/style-editor.tcl @@ -0,0 +1,976 @@ +# Copyright (c) 2005-2011 Tim Baker + +namespace eval StyleEditor { + variable Info + array unset Info +} + +proc StyleEditor::Info {info args} { + + variable Info + + if {[llength $args]} { + set Info($info) [lindex $args 0] + } + return $Info($info) +} + +proc StyleEditor::Init {Tdemo} { + + set w .styleEditor + toplevel $w + wm title $w "TkTreeCtrl Style Editor" + + Info Tdemo $Tdemo + + panedwindow $w.pwH -orient horizontal -borderwidth 0 -sashwidth 6 + + panedwindow $w.pwH.pwV -orient vertical -borderwidth 0 -sashwidth 6 + + TreePlusScrollbarsInAFrame $w.pwH.pwV.styleList 1 1 + set T $w.pwH.pwV.styleList.t + $T configure -showbuttons no -showlines no -showroot no -width 150 -height 200 + $T column create -text "Styles" -expand yes -button no -tags C0 + $T configure -treecolumn C0 + + $T notify bind $T { + StyleEditor::SelectStyle + } + + Info styleList $T + + TreePlusScrollbarsInAFrame $w.pwH.pwV.elementList 1 1 + set T $w.pwH.pwV.elementList.t + $T configure -showbuttons no -showlines no -showroot no -width 150 -height 200 + $T column create -text "Elements" -expand yes -button no -tags C0 + $T configure -treecolumn C0 + + $T notify bind $T { + StyleEditor::SelectElement + } + + Info elementList $T + + $w.pwH.pwV add $w.pwH.pwV.styleList $w.pwH.pwV.elementList + + set fRight [panedwindow $w.pwH.pwV2 -orient vertical -sashwidth 6] + if {[Platform macosx]} { + $fRight configure -width 500 + } + + # + # Property editor + # + + TreePlusScrollbarsInAFrame $fRight.propertyList 1 1 + set T $fRight.propertyList.t + $T configure -showbuttons no -showlines no -showroot no + if {[Platform macosx]} { + $T configure -height 300 + } + $T column create -text "Property" -expand yes -button no -tags {C0 property} + $T column create -text "Value" -expand yes -button no -tags {C1 value} + $T configure -treecolumn property + + $T notify bind $T { + StyleEditor::SelectProperty %S %D + } + + Info propertyList $T + + # + # Style canvas + # + + set fCanvas [frame $fRight.fCanvas -borderwidth 1 -relief sunken] + set canvas [canvas $fCanvas.canvas -background white -height 300 \ + -scrollregion {0 0 0 0} -borderwidth 0 -highlightthickness 0 \ + -xscrollcommand [list sbset $fCanvas.xscroll] \ + -yscrollcommand [list sbset $fCanvas.yscroll]] + scrollbar $fCanvas.xscroll -orient horizontal \ + -command [list $canvas xview] + scrollbar $fCanvas.yscroll -orient vertical \ + -command [list $canvas yview] + + # Copy element config info from the selected item in the demo list + $Tdemo notify bind StyleEditor { + if {[winfo ismapped .styleEditor]} { + StyleEditor::StyleToCanvas + } + } + + Info canvas $canvas + + Info selectedStyle "" + Info selectedElement "" + + # + # Create some scale controls to test expansion and squeezing + # + + $::scaleCmd $canvas.scaleX \ + -orient horizontal -length 300 -from 5 -to 150 \ + -command StyleEditor::ScaleX + if {!$::tile} {$canvas.scaleX configure -showvalue no} + place $canvas.scaleX -rely 1.0 -anchor sw + $::scaleCmd $canvas.scaleY \ + -orient vertical -length 300 -from 5 -to 150 \ + -command StyleEditor::ScaleY + if {!$::tile} {$canvas.scaleY configure -showvalue no} + place $canvas.scaleY -relx 1.0 -anchor ne + $canvas.scaleX set 150 + $canvas.scaleY set 150 + Info scaleX,widget $canvas.scaleX + Info scaleY,widget $canvas.scaleY + + # Create a new treectrl to copy the states/style/elements into, so I don't + # have to worry about column width or item visibility in the demo list + set T [treectrl $canvas.t] + $T configure -itemheight 0 -minitemheight 0 -showbuttons no -showlines no \ + -font [$Tdemo cget -font] + $T column create + + grid rowconfigure $fCanvas 0 -weight 1 + grid columnconfigure $fCanvas 0 -weight 1 + grid $canvas -row 0 -column 0 -sticky news + grid $fCanvas.xscroll -row 1 -column 0 -sticky we + grid $fCanvas.yscroll -row 0 -column 1 -sticky ns + + $w.pwH.pwV2 add $fRight.propertyList $fCanvas + + $w.pwH add $w.pwH.pwV $w.pwH.pwV2 + + grid rowconfigure $w 0 -weight 1 + grid columnconfigure $w 0 -weight 1 + grid $w.pwH -row 0 -column 0 -sticky news + + wm protocol $w WM_DELETE_WINDOW "ToggleStyleEditorWindow" + if {[Platform macosx macintosh]} { + wm geometry $w +6+30 + } else { + wm geometry $w -0+0 + } + + return +} + +proc StyleEditor::SetListOfStyles {} { + + set T [Info styleList] + set Tdemo [Info Tdemo] + + # Create elements and styles the first time this is called + if {[llength [$T style names]] == 0} { + $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e2 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + + $T style create s1 + $T style elements s1 {e2 e1} + $T style layout s1 e2 -union [list e1] -ipadx 2 -ipady 2 -iexpand e + + $T column configure C0 -itemstyle s1 + } + + # Clear the list + $T item delete all + + # One item for each style in the demo list + foreach style [lsort -dictionary [$Tdemo style names]] { + set I [$T item create] + $T item text $I C0 $style + $T item lastchild root $I + + Info item2style,$I $style + } + + return +} + +proc StyleEditor::SelectStyle {} { + + set T [Info styleList] + set Tdemo [Info Tdemo] + + set selection [$T selection get] + if {![llength $selection]} { + [Info elementList] item delete all + Info selectedStyle "" + StyleToCanvas + return + } + + set I [lindex $selection 0] + set style [Info item2style,$I] + Info selectedStyle $style + SetListOfElements $style + + Info -orient [$Tdemo style cget $style -orient] + [Info scaleX,widget] set 150 + [Info scaleY,widget] set 150 + + StyleToCanvas 1 + + return +} + +proc StyleEditor::SetListOfElements {style} { + + set T [Info elementList] + set Tdemo [Info Tdemo] + + # Create elements and styles the first time this is called + if {[llength [$T style names]] == 0} { + $T element create e1 text -fill [list $::SystemHighlightText {selected focus}] + $T element create e2 rect -fill [list $::SystemHighlight {selected focus} gray {selected !focus}] \ + -showfocus yes + + $T style create s1 + $T style elements s1 {e2 e1} + $T style layout s1 e2 -union [list e1] -ipadx 2 -ipady 2 -iexpand e + + $T column configure C0 -itemstyle s1 + } + + # Clear the list + $T item delete all + + # One item for each element in the style + foreach E [$Tdemo style elements $style] { + set I [$T item create] + $T item text $I C0 "$E ([$Tdemo element type $E])" + $T item lastchild root $I + + Info item2element,$I $E + } + + return +} + +proc StyleEditor::SelectElement {} { + + set T [Info elementList] + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + + set selection [$T selection get] + if {![llength $selection]} { + Info selectedElement "" + SetPropertyList + CanvasSelectElement + return + } + + set I [lindex $selection 0] + set element [Info item2element,$I] + Info selectedElement $element + + SetPropertyList + CanvasSelectElement + + return +} + +proc StyleEditor::SetPropertyList {} { + + set T [Info propertyList] + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + + # Create elements and styles the first time this is called + if {[llength [$T style names]] == 0} { + $T item state define header + + $T element create e1 text \ + -fill [list white header $::SystemHighlightText selected] \ + -font [list DemoFontBold header] + + set headerBG #ACA899 + if {[winfo depth $T] >= 16} { + $T gradient create G_header -steps 16 \ + -stops {{0.0 #ACA899} {0.5 #ACA899} {1.0 #d5d2ca}} + set headerBG G_header + } + $T element create e2 rect \ + -fill [list $headerBG header $::SystemHighlight selected] \ + -outline black -outlinewidth 1 -open nw -showfocus no + + $T element create eWindow window + + set S [$T style create s1] + $T style elements $S {e2 e1} + $T style layout $S e2 -detach yes -indent no -iexpand xy + $T style layout $S e1 -expand ns -padx 4 + + set S [$T style create sWindow] + $T style elements $S {e2 eWindow} + $T style layout $S e2 -detach yes -indent no -iexpand xy + $T style layout $S eWindow -expand ns -padx {0 1} -pady {0 1} + + set S [$T style create sHeader] + $T style elements $S {e2 e1} + $T style layout $S e2 -detach yes -iexpand xy + $T style layout $S e1 -expand ns -padx 4 + + Info editor,pad [MakePadEditor $T] + Info editor,expand [MakeExpandEditor $T] + Info editor,iexpand [MakeIExpandEditor $T] + Info editor,squeeze [MakeSqueezeEditor $T] + Info editor,boolean [MakeBooleanEditor $T] + Info editor,pixels [MakePixelsEditor $T] + Info editor,string [MakeStringEditor $T] + + update idletasks + set height 0 + foreach editor {pad expand iexpand squeeze boolean pixels string} { + set heightWin [winfo reqheight [Info editor,$editor]] + incr heightWin + if {$heightWin > $height} { + set height $heightWin + } + } + $T configure -font [[Info editor,pad].v1 cget -font] \ + -minitemheight $height + + $T column configure C0 -itemstyle s1 + } + + $T item delete all + + if {$element eq ""} return + + foreach {header option} { + "Draw and Visible" "" + "" -draw + "" -visible + "Center" "" + "" -center + "Detach" "" + "" -detach + "" -indent + "Union" "" + "" -union + "Expand and Squeeze" "" + "" -expand + "" -iexpand + "" -squeeze + "Sticky" "" + "" -sticky + "Padding" "" + "" -ipadx + "" -ipady + "" -padx + "" -pady + "Height" "" + "" -minheight + "" -height + "" -maxheight + "Width" "" + "" -minwidth + "" -width + "" -maxwidth + } { + set I [$T item create] + if {$header ne ""} { + $T item style set $I C0 sHeader + $T item span $I C0 2 + $T item element configure $I C0 e1 -text $header ; # -fill White + $T item state set $I header + $T item enabled $I false + $T item tag add $I header + } else { + $T item style set $I value s1 + $T item text $I property $option value [$Tdemo style layout $style $element $option] + } + $T item lastchild root $I + } + + $T column configure C0 -width [expr {[$T column neededwidth C0] * 1.0}] + + return +} + +proc StyleEditor::SelectProperty {select deselect} { + + set T [Info propertyList] + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + + if {[llength $deselect] && ($element ne "")} { + set I [lindex $deselect 0] + if {[$T item tag expr $I !header]} { + set option [$T item text $I property] + $T item style set $I value s1 + $T item text $I value [$Tdemo style layout $style $element $option] + } + } + + set selection [$T selection get] + if {![llength $selection]} { + Info selectedOption "" + return + } + + set I [lindex $selection 0] + if {[$T item tag expr $I header]} { + Info selectedOption "" + return + } + set option [$T item text $I property] + Info selectedOption $option + + $T item style set $I value sWindow + switch -- $option { + -draw - + -visible - + -union { + $T item element configure $I value eWindow -window [Info editor,string] + Info -string [$Tdemo style layout $style $element $option] + } + -padx - + -pady - + -ipadx - + -ipady { + $T item element configure $I value eWindow -window [Info editor,pad] + set pad [$Tdemo style layout $style $element $option] + if {[llength $pad] == 2} { + Info -pad,1 [lindex $pad 0] + Info -pad,2 [lindex $pad 1] + Info -pad,equal 0 + } else { + Info -pad,1 $pad + Info -pad,2 $pad + Info -pad,equal 1 + } + Info -pad,edit "" + } + -expand - + -sticky { + $T item element configure $I value eWindow -window [Info editor,expand] + set value [$Tdemo style layout $style $element $option] + foreach flag {n s w e} { + Info -expand,$flag [expr {[string first $flag $value] != -1}] + } + } + -iexpand { + $T item element configure $I value eWindow -window [Info editor,iexpand] + set value [$Tdemo style layout $style $element $option] + foreach flag {x y n s w e} { + Info -iexpand,$flag [expr {[string first $flag $value] != -1}] + } + } + -detach - + -indent { + $T item element configure $I value eWindow -window [Info editor,boolean] + Info -boolean [$Tdemo style layout $style $element $option] + } + -center - + -squeeze { + $T item element configure $I value eWindow -window [Info editor,squeeze] + set value [$Tdemo style layout $style $element $option] + foreach flag {x y} { + Info -squeeze,$flag [expr {[string first $flag $value] != -1}] + } + } + -minheight - + -height - + -maxheight - + -minwidth - + -width - + -maxwidth { + $T item element configure $I value eWindow -window [Info editor,pixels] + Info -pixels [$Tdemo style layout $style $element $option] + if {[Info -pixels] eq ""} { + Info -pixels,empty 1 + [Info editor,pixels].v1 conf -state disabled + } else { + Info -pixels,empty 0 + [Info editor,pixels].v1 conf -state normal + } + } + } + + return +} + +proc StyleEditor::MakePadEditor {parent} { + + set f [frame $parent.editPad -borderwidth 0 -background $::SystemHighlight] + spinbox $f.v1 -from 0 -to 100 -width 3 \ + -command {StyleEditor::Sync_pad 1} \ + -textvariable ::StyleEditor::Info(-pad,1) + spinbox $f.v2 -from 0 -to 100 -width 3 \ + -command {StyleEditor::Sync_pad 2} \ + -textvariable ::StyleEditor::Info(-pad,2) + $::checkbuttonCmd $f.cb -text "Equal" \ + -command {StyleEditor::Sync_pad_equal} \ + -variable ::StyleEditor::Info(-pad,equal) + pack $f.v1 -side left -padx {0 10} -pady 0 + pack $f.v2 -side left -padx {0 10} -pady 0 + pack $f.cb -side left -padx 0 -pady 0 + + bind $f.v1 { + StyleEditor::Sync_pad 1 + } + bind $f.v2 { + StyleEditor::Sync_pad 2 + } + + return $f +} + +proc StyleEditor::MakeExpandEditor {parent} { + + set f [frame $parent.editExpand -borderwidth 0 -background $::SystemHighlight] + foreach flag {w n e s} { + $::checkbuttonCmd $f.$flag -text $flag -width 1 \ + -variable ::StyleEditor::Info(-expand,$flag) \ + -command {StyleEditor::Sync_expand} + pack $f.$flag -side left -padx 10 + } + + return $f +} + +proc StyleEditor::MakeIExpandEditor {parent} { + + set f [frame $parent.editIExpand -borderwidth 0 -background $::SystemHighlight] + foreach flag {x y w n e s} { + $::checkbuttonCmd $f.$flag -text $flag -width 1 \ + -variable ::StyleEditor::Info(-iexpand,$flag) \ + -command {StyleEditor::Sync_iexpand} + pack $f.$flag -side left -padx 10 + } + + return $f +} + +proc StyleEditor::MakePixelsEditor {parent} { + + set f [frame $parent.editPixels -borderwidth 0] + spinbox $f.v1 -from 0 -to 10000 -width 10 \ + -command {StyleEditor::Sync_pixels} \ + -textvariable ::StyleEditor::Info(-pixels) \ + -validate key -validatecommand {string is integer %P} + $::checkbuttonCmd $f.cb -text "Unspecified" \ + -command {StyleEditor::Sync_pixels} \ + -variable ::StyleEditor::Info(-pixels,empty) + pack $f.v1 -side left -padx 0 -pady 0 + pack $f.cb -side left -padx 0 -pady 0 + + bind $f.v1 { + StyleEditor::Sync_pixels + } + + return $f +} + +proc StyleEditor::MakeSqueezeEditor {parent} { + + set f [frame $parent.editSqueeze -borderwidth 0 -background $::SystemHighlight] + foreach flag {x y} { + $::checkbuttonCmd $f.$flag -text $flag -width 1 \ + -variable ::StyleEditor::Info(-squeeze,$flag) \ + -command {StyleEditor::Sync_squeeze} + pack $f.$flag -side left -padx 10 + } + + return $f +} + +proc StyleEditor::MakeStringEditor {parent} { + set f [frame $parent.editString -borderwidth 0] + $::entryCmd $f.entry -textvariable ::StyleEditor::Info(-string) + bind $f.entry { + ::StyleEditor::Sync_string + } + pack $f.entry -expand yes -fill both + return $f +} + +proc StyleEditor::MakeBooleanEditor {parent} { + + set f [frame $parent.editBoolean -borderwidth 0 -background $::SystemHighlight] + foreach value {yes no} { + $::radiobuttonCmd $f.$value -text $value \ + -variable ::StyleEditor::Info(-boolean) \ + -value $value \ + -command {StyleEditor::Sync_boolean} + pack $f.$value -side left -padx 10 + } + + return $f +} + +proc StyleEditor::Sync_orient {} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + $Tdemo style configure $style -orient [Info -orient] + return +} + +proc StyleEditor::Sync_pad {index} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + set option [Info selectedOption] + if {[Info -pad,equal]} { + if {$index == 1} { + Info -pad,2 [Info -pad,1] + } else { + Info -pad,1 [Info -pad,2] + } + } + $Tdemo style layout $style $element $option [list [Info -pad,1] [Info -pad,2]] + Info -pad,edit $index + StyleToCanvas + return +} + +proc StyleEditor::Sync_pad_equal {} { + if {![Info -pad,equal]} return + if {[Info -pad,edit] eq ""} { + Info -pad,edit 1 + } + if {[Info -pad,edit] == 1} { + Info -pad,2 [Info -pad,1] + } else { + Info -pad,1 [Info -pad,2] + } + Sync_pad [Info -pad,edit] + return +} + +proc StyleEditor::Sync_expand {} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + set option [Info selectedOption] + set value "" + foreach flag {n s w e} { + if {[Info -expand,$flag]} { + append value $flag + } + } + $Tdemo style layout $style $element $option $value + StyleToCanvas + return +} + +proc StyleEditor::Sync_iexpand {} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + set option [Info selectedOption] + set value "" + foreach flag {x y n s w e} { + if {[Info -iexpand,$flag]} { + append value $flag + } + } + $Tdemo style layout $style $element $option $value + StyleToCanvas + return +} + +proc StyleEditor::Sync_squeeze {} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + set option [Info selectedOption] + set value "" + foreach flag {x y} { + if {[Info -squeeze,$flag]} { + append value $flag + } + } + $Tdemo style layout $style $element $option $value + StyleToCanvas + return +} + +proc StyleEditor::Sync_string {} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + set option [Info selectedOption] + if {[catch { + $Tdemo style layout $style $element $option [Info -string] + StyleToCanvas + } msg]} { + tk_messageBox -parent .styleEditor -icon error -title "Style Editor" \ + -message $msg + } + return +} + +proc StyleEditor::Sync_boolean {} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + set option [Info selectedOption] + $Tdemo style layout $style $element $option [Info -boolean] + StyleToCanvas + return +} + +proc StyleEditor::Sync_pixels {} { + + set Tdemo [Info Tdemo] + set style [Info selectedStyle] + set element [Info selectedElement] + set option [Info selectedOption] + set value [Info -pixels] + if {[Info -pixels,empty]} { + set value {} + [Info editor,pixels].v1 conf -state disabled + } else { + [Info editor,pixels].v1 conf -state normal + } + $Tdemo style layout $style $element $option $value + StyleToCanvas + return +} + +proc StyleEditor::StyleToCanvas {{scroll 0}} { + + set Tdemo [Info Tdemo] + set canvas [Info canvas] + set style [Info selectedStyle] + + $canvas delete all + + if {$style eq ""} { + $canvas configure -scrollregion {0 0 0 0} + return + } + + set T $canvas.t + + $T configure -itemheight 0 + $T item configure root -height 0 + $T header configure first -height 0 + $T column configure 0 -width {} + + # Get the state domain, either "item" or "header". + # It is used as the command name as well as the -statedomain value. + set domain [$Tdemo style cget $style -statedomain] + + eval $T $domain state undefine [$T $domain state names] + eval $T style delete [$T style names] + eval $T element delete [$T element names] + eval $T gradient delete [$T gradient names] + + # Copy states + foreach state [$Tdemo $domain state names] { + $T $domain state define $state + } + + # Copy gradients (name only) + foreach gradient [$Tdemo gradient names] { + $T gradient create $gradient + } + + # Copy elements + foreach E [$Tdemo style elements $style] { + $T element create $E [$Tdemo element type $E] \ + -statedomain $domain + foreach list [$Tdemo element configure $E] { + lassign $list name x y default current + $T element configure $E $name $current + } + } + + # Copy style + $T style create $style -orient [$Tdemo style cget $style -orient] \ + -statedomain $domain + $T style elements $style [$Tdemo style elements $style] + foreach E [$T style elements $style] { + eval $T style layout $style $E [$Tdemo style layout $style $E] + #$T style layout $style $E -visible {} + } + + if {$domain eq "header"} { + set match "" + } + if {$domain eq "item"} { + # Find a selected item using the style to copy element config info from + set match "" + foreach I [$Tdemo selection get] { + foreach S [$Tdemo item style set $I] C [$Tdemo column list] { + if {$S eq $style} { + set match $I + break + } + } + if {$match ne ""} break + } + # No selected item uses the current style, look for an unselected item + if {$match eq ""} { + foreach I [$Tdemo item range first last] { + foreach S [$Tdemo item style set $I] C [$Tdemo column list] { + if {$S eq $style} { + set match $I + break + } + } + if {$match ne ""} break + } + } + } + if {$match ne ""} { + set I $match + + if {[$Tdemo selection includes $I]} { + $T selection add root + } else { + $T selection clear + } + foreach state [$Tdemo item state get $I] { + if {[lsearch -exact [$Tdemo item state names] $state] != -1} { + $T item state set root $state + } + } + foreach state [$Tdemo item state forcolumn $I $C] { + $T item state set root $state + } + + foreach E [$Tdemo item style elements $I $C] { + foreach list [$Tdemo item element configure $I $C $E] { + lassign $list name x y default current + set masterDefault [$Tdemo element cget $E $name] + set sameAsMaster [string equal $masterDefault $current] + if {!$sameAsMaster && ![string length $current]} { + set sameAsMaster 1 + set current $masterDefault + } + if {$sameAsMaster} { + } elseif {$name eq "-window"} { + $T style layout $style $E -width [winfo width $current] \ + -height [winfo height $current] + } else { + $T element configure $E $name $current + } + } + } + } +if 0 { + # Do this after creating styles so -defaultstyle works + foreach list [$Tdemo configure] { + if {[llength $list] == 2} continue + lassign $list name x y default current + $T configure $name $current + } +} + if {$domain eq "header"} { + set I first + $T header style set $I 0 $style + } + if {$domain eq "item"} { + set I root + $T item style set $I 0 $style + } + + # Hack some minimum layout size > 0 + foreach E [$T style elements $style] { + if {[scan [$T $domain bbox $I 0 $E] "%d %d %d %d" x1 y1 x2 y2] == 4} { + if {$y2 - $y1 == 0 && $x2 - $x1 == 0} { + $T style layout $style $E -minwidth 10 -minheight 10 + } + } + } + + set scale 2 + + set dx 10 + set dy 10 + + scan [$T $domain bbox $I 0] "%d %d %d %d" x1 y1 x2 y2 + $canvas create rectangle \ + [expr {$dx + $x1 * $scale}] [expr {$dy + $y1 * $scale}] \ + [expr {$dx + $x2 * $scale}] [expr {$dy + $y2 * $scale}] \ + -outline gray90 + + foreach E [$T style elements $style] { + if {[scan [$T $domain bbox $I 0 $E] "%d %d %d %d" x1 y1 x2 y2] == 4} { + $canvas create rectangle \ + [expr {$dx + $x1 * $scale}] [expr {$dy + $y1 * $scale}] \ + [expr {$dx + $x2 * $scale}] [expr {$dy + $y2 * $scale}] \ + -tags [list $E element] + } + } + + scan [$T $domain bbox $I 0] "%d %d %d %d" x1 y1 x2 y2 + incr dy [expr {($y2 - $y1) * $scale + 20}] + + # Now give the style 1.5 times its needed space to test expansion + scan [$T $domain bbox $I 0] "%d %d %d %d" x1 y1 x2 y2 + $T column configure 0 -width [expr {($x2 - $x1) * [Info scaleX]}] +if 1 { + $T $domain configure $I -height [expr {($y2 - $y1) * [Info scaleY]}] +} else { + $T configure -itemheight [expr {($y2 - $y1) * [Info scaleY]}] +} + scan [$T $domain bbox $I 0] "%d %d %d %d" x1 y1 x2 y2 + + $canvas create rectangle \ + [expr {$dx + $x1 * $scale}] [expr {$dy + $y1 * $scale}] \ + [expr {$dx + $x2 * $scale}] [expr {$dy + $y2 * $scale}] \ + -outline gray90 + + foreach E [$T style elements $style] { + if {[scan [$T $domain bbox $I 0 $E] "%d %d %d %d" x1 y1 x2 y2] == 4} { + $canvas create rectangle \ + [expr {$dx + $x1 * $scale}] [expr {$dy + $y1 * $scale}] \ + [expr {$dx + $x2 * $scale}] [expr {$dy + $y2 * $scale}] \ + -tags [list $E element] + } + } + + scan [$canvas bbox all] "%d %d %d %d" x1 y1 x2 y2 + incr x2 10 + incr y2 10 + $canvas configure -scrollregion [list 0 0 $x2 $y2] + if {$scroll} { + $canvas xview moveto 0.0 + $canvas yview moveto 0.0 + } + + CanvasSelectElement + + return +} + +proc StyleEditor::CanvasSelectElement {} { + + set canvas [Info canvas] + set style [Info selectedStyle] + set element [Info selectedElement] + + $canvas itemconfigure element -fill "" -outline black + if {$element ne ""} { + $canvas itemconfigure $element -fill gray75 -outline green + } + + return +} + +proc StyleEditor::ScaleX {value} { + Info scaleX [expr {$value / 100.0}] + StyleToCanvas +} + +proc StyleEditor::ScaleY {value} { + Info scaleY [expr {$value / 100.0}] + StyleToCanvas +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/table.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/table.tcl new file mode 100644 index 00000000..dd744b8d --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/table.tcl @@ -0,0 +1,460 @@ +# Copyright (c) 2011 Tim Baker + +namespace eval DemoTable {} + +proc DemoTable::Init {T} { + variable Priv + + $T configure -showroot no -usetheme no -xscrollsmoothing yes + + $T column create -tags rowtitle -lock left -button no + for {set i 1} {$i <= 10} {incr i} { + $T column create -text $i -minwidth 20 + } + $T column configure all -background gray90 -borderwidth 1 + $T column configure all -justify center -itemjustify left + + # + # Create custom item states to change the appearance of items during + # drag and drop. The 'drag' state is also used when resizing spans. + # + + $T item state define drag + $T item state define drop + + # Another state to highlight the cell under the mouse pointer. + $T item state define mouseover + + # + # Create a style for the row titles + # + + $T element create rowtitle.border border \ + -background gray90 -thickness 1 -relief raised -filled yes + $T element create rowtitle.text text + set S [$T style create rowtitle] + $T style elements $S {rowtitle.border rowtitle.text} + $T style layout $S rowtitle.border \ + -union rowtitle.text -ipadx 3 -ipady 2 -iexpand news + $T style layout $S rowtitle.text -center x + + # + # Create a style for each cell + # + + $T element create cell.text text + $T element create cell.border border -background gray -thickness 2 -relief groove + $T element create cell.bg rect \ + -fill {{light green} drag {light blue} drop gray90 mouseover} + + set S [$T style create cell] + $T style elements $S {cell.bg cell.border cell.text} + $T style layout $S cell.bg -detach yes -iexpand xy \ + -visible {yes drag yes drop yes mouseover no {}} + $T style layout $S cell.border -union cell.text -iexpand wens -ipadx {2 3} -ipady 2 + $T style layout $S cell.text -squeeze x + + # + # Set default styles and create items + # + + $T column configure 0 -itemstyle rowtitle + $T column configure {range 1 10} -itemstyle cell + foreach I [$T item create -count 5000 -parent root] { + $T item text $I rowtitle [$T item order $I] + } + $T item text {root children} {range 1 10} "edit me" + $T item text 10 5 "*** DRAG ME ***" + $T item span 10 5 2 + $T item text 15 2 "RESIZE THE SPAN -->" + $T item span 15 2 3 + + $T notify bind $T { + %T item text %I %C %t + set DemoTable::EditAccepted 1 + } + $T notify bind $T { + if {!$DemoTable::EditAccepted} { + %T item element configure %I %C %E -text $DemoTable::OrigText + } + %T item element configure %I %C %E -textvariable "" + } + + # Set the minimum item height to be as tall as the style and the + # entry widget used to edit text need. Text elements may wrap lines + # causing an item to become even taller. + set height [font metrics [$T cget -font] -linespace] + incr height [expr {[$T style layout cell cell.border -ipady] * 2}] + incr height 2 ; # entry widget YPAD + $T configure -minitemheight $height + + set Priv(buttonMode) "" + set Priv(cursor,want) "" + set Priv(cursor,set) 0 + set Priv(highlight) "" + + bind DemoTable { + DemoTable::ButtonPress1 %W %x %y + } + bind DemoTable { + DemoTable::Button1Motion %W %x %y + DemoTable::MaintainHighlight %W + } + bind DemoTable { + DemoTable::ButtonRelease1 %W %x %y + DemoTable::Motion %W %x %y + DemoTable::MaintainCursor %W + DemoTable::MaintainHighlight %W + } + + # Control-drag to copy text + bind DemoTable { + DemoTable::ButtonRelease1 %W %x %y control + DemoTable::Motion %W %x %y + DemoTable::MaintainCursor %W + DemoTable::MaintainHighlight %W + } + if {[tk windowingsystem] eq "aqua" } { + bind DemoTable { + DemoTable::ButtonRelease1 %W %x %y command + DemoTable::Motion %W %x %y + DemoTable::MaintainCursor %W + DemoTable::MaintainHighlight %W + } + } + + bind DemoTable { + DemoTable::Motion %W %x %y + DemoTable::MaintainCursor %W + DemoTable::MaintainHighlight %W + } + bindtags $T [list $T DemoTable TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoTable::ButtonPress1 {T x y} { + variable Priv + if {[winfo exists $T.entry] && [winfo ismapped $T.entry]} { + TreeCtrl::EditClose $T entry 1 0 + } + set Priv(buttonMode) "" + $T identify -array id $x $y + if {$id(where) ne "item"} return + if {$id(column) eq "tail"} return + if {[$T column tag expr $id(column) rowtitle]} return + + switch -- [WhichSide $T $id(item) $id(column) $x $y] { + left { + if {[$T column compare $id(column) > "first visible lock none"]} { + set Priv(buttonMode) resize + set Priv(item) $id(item) + set Priv(column) [StartOfPrevSpan $T $id(item) $id(column)] + set Priv(y) $y + $T item state forcolumn $Priv(item) $Priv(column) drag + return + } + } + right { + if {[$T column compare $id(column) < "last visible lock none"]} { + set Priv(buttonMode) resize + set Priv(item) $id(item) + set Priv(column) $id(column) + set Priv(y) $y + $T item state forcolumn $Priv(item) $Priv(column) drag + return + } + } + } + + set Priv(buttonMode) dragWait + set Priv(item) $id(item) + set Priv(column) $id(column) + set Priv(x) $x + set Priv(y) $y + + return +} + +proc DemoTable::Button1Motion {T x y} { + variable Priv + set Priv(highlight,want) {} + switch $Priv(buttonMode) { + dragWait { + set Priv(highlight,want) [list $Priv(item) $Priv(column) mouseover] + if {(abs($Priv(x) - $x) > 4) || (abs($Priv(y) - $y) > 4)} { + set Priv(buttonMode) drag + $T item state forcolumn $Priv(item) $Priv(column) drag + set Priv(cx) [$T canvasx $x] + set Priv(cy) [$T canvasy $y] + $T dragimage clear + $T dragimage add $Priv(item) $Priv(column) cell.border + $T dragimage configure -visible yes + } + } + drag { + $T identify -array id $x $y + if {$id(where) eq "item" && [$T column cget $id(column) -lock] eq "none"} { + set Priv(highlight,want) [list $id(item) $id(column) drop] + } + set dx [expr {[$T canvasx $x] - $Priv(cx)}] + set dy [expr {[$T canvasy $y] - $Priv(cy)}] + $T dragimage offset $dx $dy + } + resize { + $T identify -array id $x $Priv(y) + if {$id(where) eq "item"} { + set C [ColumnUnderPoint $T $x $y] + if {[WhichHalf $T $C $x $y] eq "right"} { + if {[$T column compare $id(column) > $Priv(column)]} { + IncrSpan $T $Priv(item) $Priv(column) $C + } + if {[$T column compare $C >= $Priv(column)] && + ([$T item span $Priv(item) $Priv(column)] > 1)} { + DecrSpan $T $Priv(item) $Priv(column) $C + } + } + if {[WhichHalf $T $C $x $y] eq "left"} { + if {[$T column compare $C == $Priv(column)]} { + DecrSpan $T $Priv(item) $Priv(column) $C + } + } + } + } + } + return +} + +proc DemoTable::ButtonRelease1 {T x y args} { + variable Priv + array set modifiers { shift 0 control 0 command 0 } + foreach modifier $args { + set modifiers($modifier) 1 + } + switch $Priv(buttonMode) { + dragWait { + # FIXME: EntryExpanderOpen doesn't work with master elements + $T see $Priv(item) $Priv(column) + set text [$T item text $Priv(item) $Priv(column)] + $T item text $Priv(item) $Priv(column) $text + set exists [winfo exists $T.entry] + TreeCtrl::EntryExpanderOpen $T $Priv(item) $Priv(column) cell.text + if {!$exists} { + $T.entry configure -borderwidth 0 + scan [$T item bbox $Priv(item) $Priv(column) cell.text] "%d %d %d %d" x1 y1 x2 y2 + place $T.entry -y [expr {$y1 - 1}] + } + # Remove the binding on the text entry since typing + # may resize columns, causing the entry to become hidden. + $T notify unbind $T.entry + # Set the -textvariable on the text element and the entry widget + # to be the same, so typing in the entry automatically updates + # the text element. + set ::DemoTable::TextVar $text + set ::DemoTable::OrigText $text + set ::DemoTable::EditAccepted 0 + $T.entry configure -textvariable ::DemoTable::TextVar + $T item element configure $Priv(item) $Priv(column) cell.text \ + -textvariable ::DemoTable::TextVar -text "" + # Override EntryExpanderKeypress to make the entry widget as wide + # as we want. + bind $T.entry { + after idle [list DemoTable::EntryExpanderKeypress [winfo parent %W]] + } + # Now that the text is set, reposition the entry widget. + scan [$T item bbox $Priv(item) $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 + set left [expr {$x1 + 2 - 1}] + set right [expr {$x2 - 2}] + place $T.entry -x $left -width [expr {$right - $left}] + update idletasks + # Emulate a button press in the entry widget. + set entryX [expr {$x - $left}] + set pos [$T.entry index @$entryX] + set bbox [$T.entry bbox $pos] + if {($entryX - [lindex $bbox 0]) >= ([lindex $bbox 2]/2)} { + incr pos + } + $T.entry icursor [$T.entry index $pos] + } + drag { + $T dragimage configure -visible no + $T item state forcolumn $Priv(item) $Priv(column) !drag + $T identify -array id $x $y + if {$id(where) ne "item"} return + if {[$T column cget $id(column) -lock] ne "none"} return + if {[$T item compare $id(item) == $Priv(item)] && + [$T column compare $id(column) == $Priv(column)]} return + set textSource [$T item text $Priv(item) $Priv(column)] + set textDest [$T item text $id(item) $id(column)] + $T item text $id(item) $id(column) $textSource + if {!$modifiers(control) && !$modifiers(command)} { + $T item text $Priv(item) $Priv(column) $textDest + } + } + resize { + $T item state forcolumn $Priv(item) $Priv(column) !drag + } + } + set Priv(buttonMode) "" + return +} + +proc DemoTable::Motion {T x y} { + variable Priv + $T identify -array id $x $y + set Priv(cursor,want) "" + set Priv(highlight,want) {} + if {$id(where) ne "item"} return + if {$id(column) eq "tail"} return + if {[$T column tag expr $id(column) rowtitle]} return + set Priv(highlight,want) [list $id(item) $id(column) mouseover] + switch -- [WhichSide $T $id(item) $id(column) $x $y] { + left { + if {[$T column compare $id(column) > "first visible lock none"]} { + set Priv(cursor,want) sb_h_double_arrow + set prev [StartOfPrevSpan $T $id(item) $id(column)] + set Priv(highlight,want) [list $id(item) $prev mouseover] + } + } + right { + if {[$T column compare $id(column) < "last visible lock none"]} { + set Priv(cursor,want) sb_h_double_arrow + set Priv(highlight,want) [list $id(item) $id(column) mouseover] + } + } + } + return +} + +proc DemoTable::MaintainCursor {T} { + variable Priv + if {!$Priv(cursor,set) && $Priv(cursor,want) ne ""} { + $T configure -cursor $Priv(cursor,want) + set Priv(cursor,set) 1 + return + } + if {$Priv(cursor,set) && [$T cget -cursor] ne $Priv(cursor,want)} { + $T configure -cursor $Priv(cursor,want) + } + if {$Priv(cursor,set) && $Priv(cursor,want) eq ""} { + set Priv(cursor,set) 0 + } + return +} + +proc DemoTable::MaintainHighlight {T} { + variable Priv + if {$Priv(highlight) ne $Priv(highlight,want)} { + if {$Priv(highlight) ne ""} { + lassign $Priv(highlight) item column state + $T item state forcolumn $item $column {!drop !mouseover} + } + if {$Priv(highlight,want) ne ""} { + lassign $Priv(highlight,want) item column state + $T item state forcolumn $item $column [list !drop !mouseover $state] + } + set Priv(highlight) $Priv(highlight,want) + } + return +} + +proc DemoTable::StartOfNextSpan {T I C} { + set span [$T item span $I $C] + set last [$T column id "$C span $span"] + return [$T column id "$last next visible"] +} + +proc DemoTable::StartOfPrevSpan {T I C} { + set prev [$T column id "$C prev visible"] + if {$prev ne ""} { + set starts [GetSpanStarts $T $I] + return [lindex $starts [$T column order $prev]] + } + return "" +} + +proc DemoTable::IncrSpan {T I C newLast} { + set span [expr {[$T column order $newLast] - [$T column order $C] + 1}] + $T item span $I $C $span + return +} + +proc DemoTable::DecrSpan {T I C newLast} { + set span [expr {[$T column order $newLast] - [$T column order $C] + 1}] + $T item span $I $C $span + return +} + +proc DemoTable::ColumnUnderPoint {T x y} { + #return [$T column id "nearest $x $y"] + set totalWidth [lindex [$T cget -canvaspadx] 0] + foreach C [$T column id "lock none"] { + incr totalWidth [$T column width $C] + if {[$T canvasx $x] < $totalWidth} { + return $C + } + } + return "" +} + +proc DemoTable::WhichSide {T I C x y} { + scan [$T item bbox $I $C] "%d %d %d %d" x1 y1 x2 y2 + if {$x < $x1 + 5} { return left } + if {$x >= $x2 - 5} { return right } + return +} + +proc DemoTable::WhichHalf {T C x y} { + scan [$T column bbox $C] "%d %d %d %d" x1 y1 x2 y2 + if {$x < $x1 + ($x2 - $x1) / 2} { return left } + return right +} + +proc DemoTable::GetSpanStarts {T I} { + set columns [list] + set spans [$T item span $I] + if {[lindex [lsort -integer $spans] end] eq 1} { + return [$T column list] + } + for {set index 0} {$index < [$T column count]} {} { + set Cspan [$T column id "order $index"] + set span [lindex $spans $index] + if {![$T column cget $Cspan -visible]} { + set span 1 + } + while {$span > 0 && $index < [$T column count]} { + if {[$T column cget "order $index" -lock] ne [$T column cget $Cspan -lock]} break + lappend columns $Cspan + incr span -1 + incr index + } + } + return $columns +} + +# This is bad, relying on all sorts of private stuff in the library code. +proc DemoTable::EntryExpanderKeypress {T} { + + variable ::TreeCtrl::Priv + + if {![winfo exists $T]} return + + set font $Priv(entry,$T,font) + set text [$T.entry get] + set ebw [$T.entry cget -borderwidth] + set ex [winfo x $T.entry] + + scan [$T item bbox $Priv(entry,$T,item) $Priv(entry,$T,column)] "%d %d %d %d" x1 y1 x2 y2 + set left [expr {$x1 + 2 - 1}] + set right [expr {$x2 - 2}] + set width [expr {$right - $left}] + + scan [$T contentbox] "%d %d %d %d" left top right bottom + if {$ex + $width > $right} { + set width [expr {$right - $ex}] + } + + place configure $T.entry -width $width + + return +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/textvariable.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/textvariable.tcl new file mode 100644 index 00000000..9f4e50a5 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/textvariable.tcl @@ -0,0 +1,84 @@ +# Copyright (c) 2005-2011 Tim Baker + +namespace eval DemoTextvariable {} +proc DemoTextvariable::Init {T} { + + variable Priv + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no \ + -selectmode extended -xscrollincrement 20 \ + -yscrollincrement 10 -showheader yes + + if {!$::clip} { + # Hide the borders because child windows appear on top of them + $T configure -borderwidth 0 -highlightthickness 0 + } + + # + # Create columns + # + + $T column create -text "Resize Me!" -justify center -tags C0 + $T configure -treecolumn C0 + + # + # Create elements + # + + $T element create eWindow window + $T element create eRect rect -rx 7 + $T element create eText1 text -width 300 + $T element create eText2 text -wrap none + + # + # Create styles using the elements + # + + set S [$T style create s1 -orient horizontal] + $T style elements $S eText1 + $T style layout $S eText1 -padx 10 -pady 6 -squeeze x + + set S [$T style create s2 -orient vertical] + $T style elements $S {eRect eText2 eWindow} + $T style layout $S eRect -union {eText2 eWindow} -ipadx 8 -ipady 8 -padx 4 -pady {0 4} + $T style layout $S eText2 -pady {0 6} -squeeze x + $T style layout $S eWindow -iexpand x -squeeze x + + # + # Create items and assign styles + # + + set I [$T item create] + $T item style set $I C0 s1 + $T item element configure $I C0 eText1 -text "Each text element and entry widget share the same -textvariable. Editing the text in the entry automatically updates the text element." + $T item lastchild root $I + + foreach i {0 1} color {gray75 "light blue"} { + set I [$T item create] + $T item style set $I C0 s2 + set tvar ::DemoTextvariable::Priv(tvar,$I) + if {$::clip} { + set clip [frame $T.clip$I -borderwidth 0] + set e [$::entryCmd $clip.e -width 48 -textvariable $tvar] + $T item element configure $I C0 \ + eRect -fill [list $color] + \ + eText2 -textvariable $tvar + \ + eWindow -window $clip -clip yes + } else { + set e [$::entryCmd $T.e$I -width 48 -textvariable $tvar] + $T item element configure $I C0 \ + eRect -fill [list $color] + \ + eText2 -textvariable $tvar + \ + eWindow -window $e + } + $T item lastchild root $I + set Priv(tvar,$I) "This is item $I" + } + + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/www-options.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/www-options.tcl new file mode 100644 index 00000000..85c7aa15 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/demos/www-options.tcl @@ -0,0 +1,295 @@ +# Copyright (c) 2002-2011 Tim Baker + +namespace eval DemoInternetOptions {} +proc DemoInternetOptions::Init {T} { + + variable Priv + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no -itemheight $height \ + -selectmode browse + + $T configure -canvaspadx {4 0} -canvaspady {2 0} + + InitPics internet-* + + # + # Create columns + # + + $T column create -text "Internet Options" -tags C0 + + $T configure -treecolumn C0 + + # + # Create elements + # + + $T item state define check + $T item state define radio + $T item state define on + + $T element create elemImg image -image { + internet-check-on {check on} + internet-check-off {check} + internet-radio-on {radio on} + internet-radio-off {radio} + } + $T element create elemTxt text \ + -fill [list $::SystemHighlightText {selected focus}] -lines 1 + $T element create elemRectSel rect \ + -fill [list $::SystemHighlight {selected focus}] -showfocus yes + + # + # Create styles using the elements + # + + set S [$T style create STYLE] + $T style elements $S {elemRectSel elemImg elemTxt} + $T style layout $S elemImg -padx {0 4} -expand ns + $T style layout $S elemTxt -expand ns -squeeze x + $T style layout $S elemRectSel -union [list elemTxt] -iexpand ns -ipadx 2 + + # + # Create items and assign styles + # + + set parentList [list root {} {} {} {} {} {}] + set parent root + foreach {depth setting text option group} { + 0 print "Printing" "" "" + 1 off "Print background colors and images" "o1" "" + 0 search "Search from Address bar" "" "" + 1 search "When searching" "" "" + 2 off "Display results, and go to the most likely sites" "o2" "r1" + 2 off "Do not search from the Address bar" "o3" "r1" + 2 off "Just display the results in the main window" "o4" "r1" + 2 on "Just go to the most likely site" "o5" "r1" + 0 security "Security" "" "" + 1 on "Check for publisher's certificate revocation" "o5" "" + 1 off "Check for server certificate revocation (requires restart)" "o6" "" + } { + set item [$T item create] + $T item style set $item C0 STYLE + $T item element configure $item C0 elemTxt -text $text + set Priv(option,$item) $option + set Priv(group,$item) $group + if {($setting eq "on") || ($setting eq "off")} { + set Priv(setting,$item) $setting + if {$group eq ""} { + $T item state set $item check + if {$setting eq "on"} { + $T item state set $item on + } + } else { + if {$setting eq "on"} { + set Priv(current,$group) $item + $T item state set $item on + } + $T item state set $item radio + } + } else { + $T item element configure $item C0 elemImg -image internet-$setting + } + $T item lastchild [lindex $parentList $depth] $item + incr depth + set parentList [lreplace $parentList $depth $depth $item] + } + + bind DemoInternetOptions { + TreeCtrl::DoubleButton1 %W %x %y + } + bind DemoInternetOptions { + DemoInternetOptions::Button1 %W %x %y + break + } + + bindtags $T [list $T DemoInternetOptions TreeCtrl [winfo toplevel $T] all] + + return +} + +proc DemoInternetOptions::Button1 {T x y} { + variable Priv + focus $T + set id [$T identify $x $y] + if {[lindex $id 0] eq "header"} { + TreeCtrl::ButtonPress1 $T $x $y + } elseif {$id eq ""} { + set ::TreeCtrl::Priv(buttonMode) "" + } else { + set ::TreeCtrl::Priv(buttonMode) "" + set item [lindex $id 1] + $T selection modify $item all + $T activate $item + if {$Priv(option,$item) eq ""} return + set group $Priv(group,$item) + # a checkbutton + if {$group eq ""} { + $T item state set $item ~on + if {$Priv(setting,$item) eq "on"} { + set setting off + } else { + set setting on + } + set Priv(setting,$item) $setting + # a radiobutton + } else { + set current $Priv(current,$group) + if {$current eq $item} return + $T item state set $current !on + $T item state set $item on + set Priv(setting,$item) on + set Priv(current,$group) $item + } + } + return +} + + +# Alternate implementation that does not rely on run-time states +proc DemoInternetOptions::Init_2 {T} { + + variable Priv + + set height [font metrics [$T cget -font] -linespace] + if {$height < 18} { + set height 18 + } + + # + # Configure the treectrl widget + # + + $T configure -showroot no -showbuttons no -showlines no -itemheight $height \ + -selectmode browse + + InitPics internet-* + + # + # Create columns + # + + $T column create -text "Internet Options" + + # + # Create elements + # + + $T element create elemImg image + $T element create elemTxt text -fill [list $::SystemHighlightText {selected focus}] + $T element create elemRectSel rect -fill [list $::SystemHighlight {selected focus}] -showfocus yes + + # + # Create styles using the elements + # + + set S [$T style create STYLE] + $T style elements $S {elemRectSel elemImg elemTxt} + $T style layout $S elemImg -padx {0 4} -expand ns + $T style layout $S elemTxt -expand ns + $T style layout $S elemRectSel -union [list elemTxt] -iexpand ns -ipadx 2 + + # + # Create items and assign styles + # + + set parentList [list root {} {} {} {} {} {}] + set parent root + foreach {depth setting text option group} { + 0 print "Printing" "" "" + 1 off "Print background colors and images" "o1" "" + 0 search "Search from Address bar" "" "" + 1 search "When searching" "" "" + 2 off "Display results, and go to the most likely sites" "o2" "r1" + 2 off "Do not search from the Address bar" "o3" "r1" + 2 off "Just display the results in the main window" "o4" "r1" + 2 on "Just go to the most likely site" "o5" "r1" + 0 security "Security" "" "" + 1 on "Check for publisher's certificate revocation" "o5" "" + 1 off "Check for server certificate revocation (requires restart)" "o6" "" + } { + set item [$T item create] + $T item style set $item 0 STYLE + $T item element configure $item 0 elemTxt -text $text + set Priv(option,$item) $option + set Priv(group,$item) $group + if {$setting eq "on" || $setting eq "off"} { + set Priv(setting,$item) $setting + if {$group eq ""} { + set img internet-check-$setting + $T item element configure $item 0 elemImg -image $img + } else { + if {$setting eq "on"} { + set Priv(current,$group) $item + } + set img internet-radio-$setting + $T item element configure $item 0 elemImg -image $img + } + } else { + $T item element configure $item 0 elemImg -image internet-$setting + } + $T item lastchild [lindex $parentList $depth] $item + incr depth + set parentList [lreplace $parentList $depth $depth $item] + } + + bind DemoInternetOptions { + TreeCtrl::DoubleButton1 %W %x %y + } + bind DemoInternetOptions { + DemoInternetOptions::Button1 %W %x %y + break + } + + bindtags $T [list $T DemoInternetOptions TreeCtrl [winfo toplevel $T] all] + + return +} + +# Alternate implementation that does not rely on run-time states +proc DemoInternetOptions::Button1_2 {T x y} { + variable Priv + focus $T + set id [$T identify $x $y] + if {[lindex $id 0] eq "header"} { + TreeCtrl::ButtonPress1 $T $x $y + } elseif {$id eq ""} { + set ::TreeCtrl::Priv(buttonMode) "" + } else { + set ::TreeCtrl::Priv(buttonMode) "" + set item [lindex $id 1] + $T selection modify $item all + $T activate $item + if {$Priv(option,$item) eq ""} return + set group $Priv(group,$item) + # a checkbutton + if {$group eq ""} { + if {$Priv(setting,$item) eq "on"} { + set setting off + } else { + set setting on + } + $T item element configure $item 0 elemImg -image internet-check-$setting + set Priv(setting,$item) $setting + # a radiobutton + } else { + set current $Priv(current,$group) + if {$current eq $item} return + $T item element configure $current 0 elemImg -image internet-radio-off + $T item element configure $item 0 elemImg -image internet-radio-on + set Priv(setting,$item) on + set Priv(current,$group) $item + } + } + return +} + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/treectrl2.5.1/filelist-bindings.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/filelist-bindings.tcl similarity index 96% rename from src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/treectrl2.5.1/filelist-bindings.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/filelist-bindings.tcl index 821bb43a..02ea617b 100644 --- a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/treectrl2.5.1/filelist-bindings.tcl +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/filelist-bindings.tcl @@ -1,1293 +1,1293 @@ -# Copyright (c) 2002-2011 Tim Baker - -bind TreeCtrlFileList { - TreeCtrl::FileListEditCancel %W - TreeCtrl::DoubleButton1 %W %x %y - break -} -bind TreeCtrlFileList { - set TreeCtrl::Priv(selectMode) toggle - TreeCtrl::FileListButton1 %W %x %y - break -} -bind TreeCtrlFileList { - set TreeCtrl::Priv(selectMode) add - TreeCtrl::FileListButton1 %W %x %y - break -} -bind TreeCtrlFileList { - set TreeCtrl::Priv(selectMode) set - TreeCtrl::FileListButton1 %W %x %y - break -} -bind TreeCtrlFileList { - TreeCtrl::FileListMotion1 %W %x %y - break -} -bind TreeCtrlFileList { - TreeCtrl::FileListLeave1 %W %x %y - break -} -bind TreeCtrlFileList { - TreeCtrl::FileListRelease1 %W %x %y - break -} - -# Escape cancels any drag-and-drop operation in progress -bind TreeCtrlFileList { - TreeCtrl::FileListEscapeKey %W -} - -## Bindings for the Entry widget used for editing - -# Accept edit when we lose the focus -bind TreeCtrlEntry { - if {[winfo ismapped %W]} { - TreeCtrl::EditClose [winfo parent %W] entry 1 0 - } -} - -# Accept edit on -bind TreeCtrlEntry { - TreeCtrl::EditClose [winfo parent %W] entry 1 1 - break -} - -# Cancel edit on , use break as we are doing a "closing" action -# and don't want that propagated upwards -bind TreeCtrlEntry { - TreeCtrl::EditClose [winfo parent %W] entry 0 1 - break -} - -## Bindings for the Text widget used for editing - -# Accept edit when we lose the focus -bind TreeCtrlText { - if {[winfo ismapped %W]} { - TreeCtrl::EditClose [winfo parent %W] text 1 0 - } -} - -# Accept edit on -bind TreeCtrlText { - TreeCtrl::EditClose [winfo parent %W] text 1 1 - break -} - -# Cancel edit on , use break as we are doing a "closing" action -# and don't want that propagated upwards -bind TreeCtrlText { - TreeCtrl::EditClose [winfo parent %W] text 0 1 - break -} - -namespace eval TreeCtrl { - variable Priv - - # Number of milliseconds after clicking a selected item before the Edit - # widget appears. - set Priv(edit,delay) 500 - - # Try to deal with people importing ttk::entry into the global namespace; - # we want tk::entry - if {[llength [info commands ::tk::entry]]} { - set Priv(entryCmd) ::tk::entry - } else { - set Priv(entryCmd) ::entry - } -} - -# ::TreeCtrl::IsSensitive -# -# Returns 1 if the given window coordinates are over an element that should -# respond to mouse clicks. The list of elements that respond to mouse clicks -# is set by calling ::TreeCtrl::SetSensitive. -# -# Arguments: -# T The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::IsSensitive {T x y} { - variable Priv - $T identify -array id $x $y - if {$id(where) ne "item" || $id(element) eq ""} { - return 0 - } - if {![$T item enabled $id(item)]} { - return 0 - } - foreach list $Priv(sensitive,$T) { - set eList [lassign $list C S] - if {[$T column compare $id(column) != $C]} continue - if {[$T item style set $id(item) $C] ne $S} continue - if {[lsearch -exact $eList $id(element)] == -1} continue - return 1 - } - return 0 -} - -# ::TreeCtrl::IsSensitiveMarquee -# -# Returns 1 if the given window coordinates are over an element that -# should respond to the marquee. The list of elements that respond to the -# marquee is set by calling ::TreeCtrl::SetSensitiveMarquee, or if that list -# is empty then the same list passed to ::TreeCtrl::SetSensitive. -# -# Arguments: -# T The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::IsSensitiveMarquee {T x y} { - variable Priv - $T identify -array id $x $y - if {$id(where) ne "item" || $id(element) eq ""} { - return 0 - } - if {![$T item enabled $id(item)]} { - return 0 - } - if {![info exists Priv(sensitive,marquee,$T)]} { - set sensitive $Priv(sensitive,$T) - } elseif {[llength $Priv(sensitive,marquee,$T)] == 0} { - set sensitive $Priv(sensitive,$T) - } else { - set sensitive $Priv(sensitive,marquee,$T) - } - foreach list $sensitive { - set eList [lassign $list C S] - if {[$T column compare $id(column) != $C]} continue - if {[$T item style set $id(item) $C] ne $S} continue - if {[lsearch -exact $eList $id(element)] == -1} continue - return 1 - } - return 0 -} - -# ::TreeCtrl::FileListButton1 -# -# Handle . -# -# Arguments: -# T The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::FileListButton1 {T x y} { - variable Priv - focus $T - $T identify -array id $x $y - set marquee 0 - set Priv(buttonMode) "" - foreach e {text entry} { - if {[winfo exists $T.$e] && [winfo ismapped $T.$e]} { - EditClose $T $e 1 0 - } - } - FileListEditCancel $T - # Click outside any item - if {$id(where) eq ""} { - set marquee 1 - - # Click in header - } elseif {$id(where) eq "header"} { - ButtonPress1 $T $x $y - - # Click in item - } elseif {$id(where) eq "item"} { - if {$id(button) || $id(line) ne ""} { - ButtonPress1 $T $x $y - } elseif {$id(column) ne ""} { - set item $id(item) - set drag 0 - if {[IsSensitive $T $x $y]} { - set Priv(drag,wasSel) [$T selection includes $item] - $T activate $item - if {$Priv(selectMode) eq "add"} { - BeginExtend $T $item - } elseif {$Priv(selectMode) eq "toggle"} { - BeginToggle $T $item - } elseif {![$T selection includes $item]} { - BeginSelect $T $item - } - - # Changing the selection might change the list - if {[$T item id $item] eq ""} return - - # Click selected item(s) to drag or rename - if {[$T selection includes $item]} { - set drag 1 - } - } elseif {[FileListEmulateWin7 $T] && [IsSensitiveMarquee $T $x $y]} { - # Click selected item(s) to drag or rename - if {[$T selection includes $item]} { - set Priv(drag,wasSel) 1 - $T activate $item - set drag 1 - # Click marquee-sensitive parts of an unselected item - # in single-select mode changes nothing until a drag - # occurs or the mouse button is released. - } elseif {[$T cget -selectmode] eq "single"} { - set Priv(drag,wasSel) 0 - set drag 1 - } else { - set marquee 1 - } - } else { - set marquee 1 - } - if {$drag} { - set Priv(drag,motion) 0 - set Priv(drag,click,x) $x - set Priv(drag,click,y) $y - set Priv(drag,x) [$T canvasx $x] - set Priv(drag,y) [$T canvasy $y] - set Priv(drop) "" - set Priv(drag,item) $item - set Priv(drag,C) $id(column) - set Priv(drag,E) $id(element) - set Priv(buttonMode) drag - } - } - } - if {$marquee && [$T cget -selectmode] eq "single"} { - set marquee 0 - $T selection clear - } - if {$marquee} { - set Priv(buttonMode) marquee - if {![info exists Priv(sensitive,marquee,$T)]} { - set Priv(sensitive,marquee,$T) {} - } - if {$Priv(selectMode) ne "set"} { - set Priv(selection) [$T selection get] - } else { - if {![FileListEmulateWin7 $T]} { - $T selection clear - } - set Priv(selection) {} - } - MarqueeBegin $T $x $y - - set Priv(marquee,motion) 0 - if {[FileListEmulateWin7 $T]} { - if {[IsSensitiveMarquee $T $x $y]} { - set item $id(item) - $T activate $item - if {$Priv(selectMode) ne "add"} { - $T selection anchor $item - } - } - } - } - return -} - -# ::TreeCtrl::FileListMotion1 -# -# Override default to handle "drag" and "marquee". -# -# Arguments: -# T The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::FileListMotion1 {T x y} { - variable Priv - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - "drag" - - "marquee" { - set Priv(autoscan,command,$T) {FileListMotion %T %x %y} - AutoScanCheck $T $x $y - FileListMotion $T $x $y - } - default { - Motion1 $T $x $y - } - } - return -} - -# ::TreeCtrl::FileListMotion -# -# Handle . -# -# Arguments: -# T The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::FileListMotion {T x y} { - variable Priv - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - "marquee" { - MarqueeUpdate $T $x $y - set select $Priv(selection) - set deselect {} - set items {} - - set Priv(marquee,motion) 1 - - set sensitive $Priv(sensitive,marquee,$T) - if {[llength $sensitive] == 0} { - set sensitive $Priv(sensitive,$T) - } - - # Check items covered by the marquee - foreach list [$T marque identify] { - set item [lindex $list 0] - if {![$T item enabled $item]} continue - - # Check covered columns in this item - foreach sublist [lrange $list 1 end] { - set column [lindex $sublist 0] - set ok 0 - - # Check covered elements in this column - foreach E [lrange $sublist 1 end] { - foreach sList $sensitive { - set sEList [lassign $sList sC sS] - if {[$T column compare $column != $sC]} continue - if {[$T item style set $item $sC] ne $sS} continue - if {[lsearch -exact $sEList $E] == -1} continue - set ok 1 - break - } - } - # Some sensitive elements in this column are covered - if {$ok} { - lappend items $item - } - } - } - foreach item $items { - # Toggle selected status - if {$Priv(selectMode) eq "toggle"} { - set i [lsearch -exact $Priv(selection) $item] - if {$i == -1} { - lappend select $item - } else { - set i [lsearch -exact $select $item] - set select [lreplace $select $i $i] - } - } else { - lappend select $item - } - } - $T selection modify $select all - } - "drag" { - if {!$Priv(drag,motion)} { - # Detect initial mouse movement - if {(abs($x - $Priv(drag,click,x)) <= 4) && - (abs($y - $Priv(drag,click,y)) <= 4)} return - - # In Win7 single-selectmode, when the insensitive parts of an - # unselected item are clicked, the active item and selection - # aren't changed until the drag begins. - if {[FileListEmulateWin7 $T] - && [$T cget -selectmode] eq "single" - && !$Priv(drag,wasSel)} { - $T activate $Priv(drag,item) - $T selection modify $Priv(drag,item) all - } - - set Priv(selection) [$T selection get] - set Priv(drop) "" - $T dragimage clear - # For each selected item, add some elements to the dragimage - foreach I $Priv(selection) { - foreach list $Priv(dragimage,$T) { - set EList [lassign $list C S] - if {[$T item style set $I $C] eq $S} { - eval $T dragimage add $I $C $EList - } - } - } - set Priv(drag,motion) 1 - TryEvent $T Drag begin {} - } - - # Find the element under the cursor - set drop "" - $T identify -array id $x $y - if {[IsSensitive $T $x $y]} { - set sensitive 1 - } elseif {[FileListEmulateWin7 $T] && [IsSensitiveMarquee $T $x $y]} { - set sensitive 1 - } else { - set sensitive 0 - } - if {$sensitive} { - set item $id(item) - # If the item is not in the pre-drag selection - # (i.e. not being dragged) and it is a directory, - # see if we can drop on it - if {[lsearch -exact $Priv(selection) $item] == -1} { - if {[$T item order $item -visible] < $Priv(DirCnt,$T)} { - set drop $item - # We can drop if dragged item isn't an ancestor - foreach item2 $Priv(selection) { - if {[$T item isancestor $item2 $item]} { - set drop "" - break - } - } - } - } - } - - # Select the directory under the cursor (if any) and deselect - # the previous drop-directory (if any) - $T selection modify $drop $Priv(drop) - set Priv(drop) $drop - - # Show the dragimage in its new position -if {0 && [$T dragimage cget -style] ne ""} { - set x [$T canvasx $x] - set y [$T canvasy $y] -} else { - set x [expr {[$T canvasx $x] - $Priv(drag,x)}] - set y [expr {[$T canvasy $y] - $Priv(drag,y)}] -} - $T dragimage offset $x $y - $T dragimage configure -visible yes - } - default { - Motion1 $T $x $y - } - } - return -} - -# ::TreeCtrl::FileListLeave1 -# -# Handle . -# -# Arguments: -# T The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::FileListLeave1 {T x y} { - variable Priv - # This gets called when I click the mouse on Unix, and buttonMode is unset - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - default { - Leave1 $T $x $y - } - } - return -} - -# ::TreeCtrl::FileListRelease1 -# -# Handle . -# -# Arguments: -# T The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::FileListRelease1 {T x y} { - variable Priv - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - "marquee" { - AutoScanCancel $T - MarqueeEnd $T $x $y - - if {[FileListEmulateWin7 $T]} { - # If the mouse was clicked in whitespace or insensitive part - # of an item and the mouse did not move then the selection - # is not modified until after the mouse button is released. - if {!$Priv(marquee,motion)} { - if {[IsSensitiveMarquee $T $x $y]} { - set item [$T item id active] - if {$Priv(selectMode) eq "add"} { - BeginExtend $T $item - } elseif {$Priv(selectMode) eq "toggle"} { - BeginToggle $T $item - } else { - BeginSelect $T $item - } - } elseif {$Priv(selectMode) eq "set"} { - # Clicked whitespace - $T selection clear - } - } - } - } - "drag" { - AutoScanCancel $T - - # Some dragging occurred - if {$Priv(drag,motion)} { - $T dragimage configure -visible no - if {$Priv(drop) ne ""} { - $T selection modify {} $Priv(drop) - TryEvent $T Drag receive \ - [list I $Priv(drop) l $Priv(selection)] - } - TryEvent $T Drag end {} - } else { - set rename 0 - if {[FileListEmulateWin7 $T]} { - # If the mouse was clicked in the insensitive parts of - # a selected item and multiple items are selected and the - # mouse did not move then the selection is not modified - # until after the mouse button is released. - set item $Priv(drag,item) - if {[$T selection count] == 1 && $Priv(selectMode) eq "set"} { - # In single-selectmode, when clicking the insensitive - # parts of an unselected item, the active item and - # selection aren't changed until the button is released. - if {[$T cget -selectmode] eq "single" && !$Priv(drag,wasSel)} { - $T activate $item - $T selection modify $item all - } else { - # If clicked already-selected item, rename it - set rename $Priv(drag,wasSel) - } - } elseif {[IsSensitive $T $x $y] && !$Priv(drag,wasSel)} { - # Selection was modified on ButtonPress, do nothing - } elseif {$Priv(selectMode) eq "add"} { - # Shift-click does nothing to already-selected item - #BeginExtend $T $item - } elseif {$Priv(selectMode) eq "toggle"} { - BeginToggle $T $item - } else { - # Make this the only selected item - BeginSelect $T $item - } - } elseif {$Priv(selectMode) eq "toggle"} { - # don't rename - } elseif {$Priv(drag,wasSel)} { - # Clicked/released a selected item, but didn't drag - set rename 1 - } - if {$rename} { - set I [$T item id active] - set C $Priv(drag,C) - set E $Priv(drag,E) - set S [$T item style set $I $C] - set ok 0 - foreach list $Priv(edit,$T) { - set eEList [lassign $list eC eS] - if {[$T column compare $C != $eC]} continue - if {$S ne $eS} continue - if {[lsearch -exact $eEList $E] == -1} continue - set ok 1 - break - } - if {$ok} { - FileListEditCancel $T - set Priv(editId,$T) \ - [after $Priv(edit,delay) [list ::TreeCtrl::FileListEdit $T $I $C $E]] - } - } - } - } - default { - Release1 $T $x $y - } - } - set Priv(buttonMode) "" - return -} - -# ::TreeCtrl::EscapeKey -# -# Handle the key. -# -# T The treectrl widget. - -proc ::TreeCtrl::FileListEscapeKey {T} { - variable Priv - if {[info exists Priv(buttonMode)] && $Priv(buttonMode) eq "drag"} { - set Priv(buttonMode) "" - AutoScanCancel $T - if {$Priv(drag,motion)} { - $T selection modify $Priv(selection) all - $T dragimage configure -visible no - TryEvent $T Drag end {} - } - return -code break - } - return -} - -# ::TreeCtrl::FileListEdit -# -# Displays an Entry or Text widget to allow the user to edit the specified -# text element. -# -# Arguments: -# T The treectrl widget. -# I Item. -# C Column. -# E Element. - -proc ::TreeCtrl::FileListEdit {T I C E} { - variable Priv - array unset Priv editId,$T - - if {![winfo exists $T]} return - - set lines [$T item element cget $I $C $E -lines] - if {$lines eq ""} { - set lines [$T element cget $E -lines] - } - - # Scroll item into view - $T see $I ; update - - # Multi-line edit - if {$lines ne "1"} { - scan [$T item bbox $I $C] "%d %d %d %d" x1 y1 x2 y2 - set S [$T item style set $I $C] - set padx [$T style layout $S $E -padx] - # FIXME: max of padx or union padding - GetPadding $padx padw pade - AddUnionPadding $T $S $E padw pade - TextExpanderOpen $T $I $C $E [expr {$x2 - $x1 - $padw - $pade}] - - # Single-line edit - } else { - EntryExpanderOpen $T $I $C $E - } - - TryEvent $T Edit begin [list I $I C $C E $E] - - return -} - -proc ::TreeCtrl::GetPadding {pad _padw _pade} { - upvar $_padw padw - upvar $_pade pade - if {[llength $pad] == 2} { - lassign $pad padw pade - } else { - set pade [set padw $pad] - } - return -} - -# Recursively adds -padx and -ipadx values of other elements in a style that -# contain the given element in its -union. -proc ::TreeCtrl::AddUnionPadding {T S E _padw _pade} { - upvar $_padw padw - upvar $_pade pade - foreach E2 [$T style elements $S] { - set union [$T style layout $S $E2 -union] - if {[lsearch -exact $union $E] == -1} continue - foreach option {-padx -ipadx} { - set pad [$T style layout $S $E2 $option] - GetPadding $pad p1 p2 - # FIXME: max of padx or union padding - incr padw $p1 - incr pade $p2 - } - AddUnionPadding $T $S $E2 padw pade - } - return -} - -# ::TreeCtrl::FileListEditCancel -# -# Aborts any scheduled display of the text-edit widget. -# -# Arguments: -# T The treectrl widget. - -proc ::TreeCtrl::FileListEditCancel {T} { - variable Priv - if {[info exists Priv(editId,$T)]} { - after cancel $Priv(editId,$T) - array unset Priv editId,$T - } - return -} - -# ::TreeCtrl::SetDragImage -# -# Specifies the list of elements that should be added to the dragimage. -# -# Arguments: -# T The treectrl widget. -# listOfLists {{column style element ...} {column style element ...}} - -proc ::TreeCtrl::SetDragImage {T listOfLists} { - variable Priv - foreach list $listOfLists { - set elements [lassign $list column style] - if {[$T column id $column] eq ""} { - error "column \"$column\" doesn't exist" - } - if {[lsearch -exact [$T style names] $style] == -1} { - error "style \"$style\" doesn't exist" - } - foreach element $elements { - if {[lsearch -exact [$T element names] $element] == -1} { - error "element \"$element\" doesn't exist" - } - } - } - set Priv(dragimage,$T) $listOfLists - return -} - -# ::TreeCtrl::SetEditable -# -# Specifies the list of text elements that can be edited. -# -# Arguments: -# T The treectrl widget. -# listOfLists {{column style element ...} {column style element ...}} - -proc ::TreeCtrl::SetEditable {T listOfLists} { - variable Priv - foreach list $listOfLists { - set elements [lassign $list column style] - if {[$T column id $column] eq ""} { - error "column \"$column\" doesn't exist" - } - if {[lsearch -exact [$T style names] $style] == -1} { - error "style \"$style\" doesn't exist" - } - foreach element $elements { - if {[lsearch -exact [$T element names] $element] == -1} { - error "element \"$element\" doesn't exist" - } - if {[$T element type $element] ne "text"} { - error "element \"$element\" is not of type \"text\"" - } - } - } - set Priv(edit,$T) $listOfLists - return -} - -# ::TreeCtrl::SetSensitive -# -# Specifies the list of elements that respond to mouse clicks. -# -# Arguments: -# T The treectrl widget. -# listOfLists {{column style element ...} {column style element ...}} - -proc ::TreeCtrl::SetSensitive {T listOfLists} { - variable Priv - foreach list $listOfLists { - set elements [lassign $list column style] - if {[$T column id $column] eq ""} { - error "column \"$column\" doesn't exist" - } - if {[lsearch -exact [$T style names] $style] == -1} { - error "style \"$style\" doesn't exist" - } - foreach element $elements { - if {[lsearch -exact [$T element names] $element] == -1} { - error "element \"$element\" doesn't exist" - } - } - } - set Priv(sensitive,$T) $listOfLists - return -} - -# ::TreeCtrl::SetSensitiveMarquee -# -# Specifies the list of elements that are sensitive to the marquee. -# If the list is empty then the same list passed to SetSensitive -# is used. -# -# Arguments: -# T The treectrl widget. -# sensitive Boolean value. - -proc ::TreeCtrl::SetSensitiveMarquee {T listOfLists} { - variable Priv - foreach list $listOfLists { - set elements [lassign $list column style] - if {[$T column id $column] eq ""} { - error "column \"$column\" doesn't exist" - } - if {[lsearch -exact [$T style names] $style] == -1} { - error "style \"$style\" doesn't exist" - } - foreach element $elements { - if {[lsearch -exact [$T element names] $element] == -1} { - error "element \"$element\" doesn't exist" - } - } - } - set Priv(sensitive,marquee,$T) $listOfLists - return -} - -# ::TreeCtrl::SetSelectedItemsSensitive -# -# Specifies whether or not entire items are sensitive to mouse clicks -# when they are already selected. -# -# Arguments: -# T The treectrl widget. -# sensitive Boolean value. - -proc ::TreeCtrl::SetSelectedItemsSensitive {T sensitive} { - variable Priv - if {![string is boolean -strict $sensitive]} { - error "expected boolean but got \"$sensitive\"" - } - set Priv(sensitiveSelected,$T) $sensitive - return -} - -# ::TreeCtrl::FileListEmulateWin7 -# -# Test the flag telling the bindings to use Windows 7 behavior. -# -# Arguments: -# T The treectrl widget. -# win7 Boolean value. - -proc ::TreeCtrl::FileListEmulateWin7 {T args} { - variable Priv - if {[llength $args]} { - set win7 [lindex $args 0] - if {![string is boolean -strict $win7]} { - error "expected boolean but got \"$win7\"" - } - set Priv(win7,$T) $win7 - return - } - if {[info exists Priv(win7,$T)]} { - return $Priv(win7,$T) - } - return 0 -} - -# ::TreeCtrl::EntryOpen -# -# Display a ::tk::entry so the user can edit the specified text element. -# -# Arguments: -# T The treectrl widget. -# item Item. -# column Column. -# element Element. - -proc ::TreeCtrl::EntryOpen {T item column element} { - - variable Priv - - set Priv(entry,$T,item) $item - set Priv(entry,$T,column) $column - set Priv(entry,$T,element) $element - set Priv(entry,$T,focus) [focus] - - # Get window coords of the Element - scan [$T item bbox $item $column $element] "%d %d" x y - - # Get the font used by the Element - set font [$T item element perstate $item $column $element -font] - if {$font eq ""} { - set font [$T cget -font] - } - - # Get the text used by the Element. Could check master Element too. - set text [$T item element cget $item $column $element -text] - - # Create the Entry widget if needed - set e $T.entry - if {[winfo exists $e]} { - $e delete 0 end - } else { - $Priv(entryCmd) $e -borderwidth 1 -relief solid -highlightthickness 0 - bindtags $e [linsert [bindtags $e] 1 TreeCtrlEntry] - } - - # Pesky MouseWheel - $T notify bind $e { TreeCtrl::EditClose %T entry 0 1 } - - $e configure -font $font - $e insert end $text - $e selection range 0 end - - set ebw [$e cget -borderwidth] - set ex [expr {$x - $ebw - 1}] - place $e -x $ex -y [expr {$y - $ebw - 1}] -bordermode outside - - # Make the Entry as wide as the text plus "W" but keep it within the - # TreeCtrl borders - set width [font measure $font ${text}W] - set width [expr {$width + ($ebw + 1) * 2}] - scan [$T contentbox] "%d %d %d %d" left top right bottom - if {$ex + $width > $right} { - set width [expr {$right - $ex}] - } - scan [$T item bbox $item $column] "%d %d %d %d" left top right bottom - if {$ex + $width > $right} { - set width [expr {$right - $ex}] - } - place configure $e -width $width - - focus $e - - return -} - -# ::TreeCtrl::EntryExpanderOpen -# -# Display a ::tk::entry so the user can edit the specified text element. -# Like EntryOpen, but Entry widget expands/shrinks during typing. -# -# Arguments: -# T The treectrl widget. -# item Item. -# column Column. -# element Element. - -proc ::TreeCtrl::EntryExpanderOpen {T item column element} { - - variable Priv - - set Priv(entry,$T,item) $item - set Priv(entry,$T,column) $column - set Priv(entry,$T,element) $element - set Priv(entry,$T,focus) [focus] - - # Get window coords of the Element - scan [$T item bbox $item $column $element] "%d %d" x y - - # Get the font used by the Element - set font [$T item element perstate $item $column $element -font] - if {$font eq ""} { - set font [$T cget -font] - } - - set Priv(entry,$T,font) $font - - # Get the text used by the Element. Could check master Element too. - set text [$T item element cget $item $column $element -text] - - # Create the Entry widget if needed - set e $T.entry - if {[winfo exists $e]} { - $e delete 0 end - } else { - $Priv(entryCmd) $e -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -relief solid - bindtags $e [linsert [bindtags $e] 1 TreeCtrlEntry] - - # Resize as user types - bind $e { - after idle [list TreeCtrl::EntryExpanderKeypress [winfo parent %W]] - } - } - - # Pesky MouseWheel - $T notify bind $e { TreeCtrl::EditClose %T entry 0 1 } - - $e configure -font $font -background [$T cget -background] - $e insert end $text - $e selection range 0 end - - set ebw [$e cget -borderwidth] - set ex [expr {$x - $ebw - 1}] - place $e -x $ex -y [expr {$y - $ebw - 1}] \ - -bordermode outside - - # Make the Entry as wide as the text plus "W" but keep it within the - # TreeCtrl borders - set width [font measure $font ${text}W] - set width [expr {$width + ($ebw + 1) * 2}] - scan [$T contentbox] "%d %d %d %d" left top right bottom - if {$ex + $width > $right} { - set width [expr {$right - $ex}] - } - place configure $e -width $width - - focus $e - - return -} - -# ::TreeCtrl::EditClose -# -# Hides the text-edit widget and restores the focus if needed. -# Generates and events as needed. -# -# Arguments: -# T The treectrl widget. -# type "entry" or "text". -# accept 0/1: should an event be generated. -# refocus 0/1: should the focus be restored to what it was before editing. - -proc ::TreeCtrl::EditClose {T type accept {refocus 0}} { - variable Priv - - set w $T.$type - # We need the double-idle to get winfo ismapped to report properly - # so this don't get the FocusOut following Escape immediately - update idletasks - place forget $w - focus $T - update idletasks - - if {$accept} { - if {$type eq "entry"} { - set t [$w get] - } else { - set t [$w get 1.0 end-1c] - } - TryEvent $T Edit accept \ - [list I $Priv($type,$T,item) C $Priv($type,$T,column) \ - E $Priv($type,$T,element) t $t] - } - - $T notify unbind $w - - TryEvent $T Edit end \ - [list I $Priv($type,$T,item) C $Priv($type,$T,column) \ - E $Priv($type,$T,element)] - - if {$refocus} { - focus $Priv($type,$T,focus) - } - - return -} - -# ::TreeCtrl::EntryExpanderKeypress -# -# Maintains the width of the text-edit widget during typing. -# -# Arguments: -# T The treectrl widget. - -proc ::TreeCtrl::EntryExpanderKeypress {T} { - - variable Priv - - if {![winfo exists $T]} return - - set font $Priv(entry,$T,font) - set text [$T.entry get] - set ebw [$T.entry cget -borderwidth] - set ex [winfo x $T.entry] - - set width [font measure $font ${text}W] - set width [expr {$width + ($ebw + 1) * 2}] - - scan [$T contentbox] "%d %d %d %d" left top right bottom - if {$ex + $width > $right} { - set width [expr {$right - $ex}] - } - - place configure $T.entry -width $width - - return -} - -# ::TreeCtrl::TextOpen -# -# Display a ::tk::text so the user can edit the specified text element. -# -# Arguments: -# T The treectrl widget. -# item Item. -# column Column. -# element Element. -# width unused. -# height unused. - -proc ::TreeCtrl::TextOpen {T item column element {width 0} {height 0}} { - variable Priv - - set Priv(text,$T,item) $item - set Priv(text,$T,column) $column - set Priv(text,$T,element) $element - set Priv(text,$T,focus) [focus] - - # Get window coords of the Element - scan [$T item bbox $item $column $element] "%d %d %d %d" x1 y1 x2 y2 - - # Get the font used by the Element - set font [$T item element perstate $item $column $element -font] - if {$font eq ""} { - set font [$T cget -font] - } - - # Get the text used by the Element. Could check master Element too. - set text [$T item element cget $item $column $element -text] - - set justify [$T element cget $element -justify] - if {$justify eq ""} { - set justify left - } - - set wrap [$T element cget $element -wrap] - if {$wrap eq ""} { - set wrap word - } - - # Create the Text widget if needed - set w $T.text - if {[winfo exists $w]} { - $w delete 1.0 end - } else { - text $w -borderwidth 1 -highlightthickness 0 -relief solid - bindtags $w [linsert [bindtags $w] 1 TreeCtrlText] - } - - # Pesky MouseWheel - $T notify bind $w { TreeCtrl::EditClose %T text 0 1 } - - $w tag configure TAG -justify $justify - $w configure -font $font -background [$T cget -background] -wrap $wrap - $w insert end $text - $w tag add sel 1.0 end - $w tag add TAG 1.0 end - - set tbw [$w cget -borderwidth] - set tx [expr {$x1 - $tbw - 1}] - place $w -x $tx -y [expr {$y1 - $tbw - 1}] \ - -width [expr {$x2 - $x1 + ($tbw + 1) * 2}] \ - -height [expr {$y2 - $y1 + ($tbw + 1) * 2}] \ - -bordermode outside - - focus $w - - return -} - -# ::TreeCtrl::TextExpanderOpen -# -# Display a ::tk::text so the user can edit the specified text element. -# Like TextOpen, but Text widget expands/shrinks during typing. -# -# Arguments: -# T The treectrl widget. -# item Item. -# column Column. -# element Element. -# width Width of the text element. - -proc ::TreeCtrl::TextExpanderOpen {T item column element width} { - - variable Priv - - set Priv(text,$T,item) $item - set Priv(text,$T,column) $column - set Priv(text,$T,element) $element - set Priv(text,$T,focus) [focus] - - # Get window coords of the Element - scan [$T item bbox $item $column $element] "%d %d %d %d" x1 y1 x2 y2 - - set Priv(text,$T,center) [expr {$x1 + ($x2 - $x1) / 2}] - - # Get the font used by the Element - set font [$T item element perstate $item $column $element -font] - if {$font eq ""} { - set font [$T cget -font] - } - - # Get the text used by the Element. Could check master Element too. - set text [$T item element cget $item $column $element -text] - - set justify [$T element cget $element -justify] - if {$justify eq ""} { - set justify left - } - - set wrap [$T element cget $element -wrap] - if {$wrap eq ""} { - set wrap word - } - - # Create the Text widget if needed - set w $T.text - if {[winfo exists $w]} { - $w delete 1.0 end - } else { - text $w -borderwidth 1 -highlightthickness 0 \ - -selectborderwidth 0 -relief solid - bindtags $w [linsert [bindtags $w] 1 TreeCtrlText] - - # Resize as user types - bind $w { - after idle TreeCtrl::TextExpanderKeypress [winfo parent %W] - } - } - - # Pesky MouseWheel - $T notify bind $w { TreeCtrl::EditClose %T text 0 1 } - - $w tag configure TAG -justify $justify - $w configure -font $font -background [$T cget -background] -wrap $wrap - $w insert end $text - $w tag add sel 1.0 end - $w tag add TAG 1.0 end - - set Priv(text,$T,font) $font - set Priv(text,$T,justify) $justify - set Priv(text,$T,width) $width - - scan [textlayout $font $text -justify $justify -width $width] \ - "%d %d" width height - - set tbw [$w cget -borderwidth] - incr tbw - place $w -x [expr {$x1 - $tbw}] -y [expr {$y1 - $tbw}] \ - -width [expr {$width + $tbw * 2}] \ - -height [expr {$height + $tbw * 2}] \ - -bordermode outside - - focus $w - - return -} - -# ::TreeCtrl::TextExpanderKeypress -# -# Maintains the size of the text-edit widget during typing. -# -# Arguments: -# T The treectrl widget. - -proc ::TreeCtrl::TextExpanderKeypress {T} { - - variable Priv - - if {![winfo exists $T]} return - - set font $Priv(text,$T,font) - set justify $Priv(text,$T,justify) - set width $Priv(text,$T,width) - set center $Priv(text,$T,center) - - set text [$T.text get 1.0 end-1c] - - scan [textlayout $font $text -justify $justify -width $width] \ - "%d %d" width height - - set tbw [$T.text cget -borderwidth] - incr tbw - place configure $T.text \ - -x [expr {$center - ($width + $tbw * 2) / 2}] \ - -width [expr {$width + $tbw * 2}] \ - -height [expr {$height + $tbw * 2}] - - $T.text tag add TAG 1.0 end - - return -} - +# Copyright (c) 2002-2011 Tim Baker + +bind TreeCtrlFileList { + TreeCtrl::FileListEditCancel %W + TreeCtrl::DoubleButton1 %W %x %y + break +} +bind TreeCtrlFileList { + set TreeCtrl::Priv(selectMode) toggle + TreeCtrl::FileListButton1 %W %x %y + break +} +bind TreeCtrlFileList { + set TreeCtrl::Priv(selectMode) add + TreeCtrl::FileListButton1 %W %x %y + break +} +bind TreeCtrlFileList { + set TreeCtrl::Priv(selectMode) set + TreeCtrl::FileListButton1 %W %x %y + break +} +bind TreeCtrlFileList { + TreeCtrl::FileListMotion1 %W %x %y + break +} +bind TreeCtrlFileList { + TreeCtrl::FileListLeave1 %W %x %y + break +} +bind TreeCtrlFileList { + TreeCtrl::FileListRelease1 %W %x %y + break +} + +# Escape cancels any drag-and-drop operation in progress +bind TreeCtrlFileList { + TreeCtrl::FileListEscapeKey %W +} + +## Bindings for the Entry widget used for editing + +# Accept edit when we lose the focus +bind TreeCtrlEntry { + if {[winfo ismapped %W]} { + TreeCtrl::EditClose [winfo parent %W] entry 1 0 + } +} + +# Accept edit on +bind TreeCtrlEntry { + TreeCtrl::EditClose [winfo parent %W] entry 1 1 + break +} + +# Cancel edit on , use break as we are doing a "closing" action +# and don't want that propagated upwards +bind TreeCtrlEntry { + TreeCtrl::EditClose [winfo parent %W] entry 0 1 + break +} + +## Bindings for the Text widget used for editing + +# Accept edit when we lose the focus +bind TreeCtrlText { + if {[winfo ismapped %W]} { + TreeCtrl::EditClose [winfo parent %W] text 1 0 + } +} + +# Accept edit on +bind TreeCtrlText { + TreeCtrl::EditClose [winfo parent %W] text 1 1 + break +} + +# Cancel edit on , use break as we are doing a "closing" action +# and don't want that propagated upwards +bind TreeCtrlText { + TreeCtrl::EditClose [winfo parent %W] text 0 1 + break +} + +namespace eval TreeCtrl { + variable Priv + + # Number of milliseconds after clicking a selected item before the Edit + # widget appears. + set Priv(edit,delay) 500 + + # Try to deal with people importing ttk::entry into the global namespace; + # we want tk::entry + if {[llength [info commands ::tk::entry]]} { + set Priv(entryCmd) ::tk::entry + } else { + set Priv(entryCmd) ::entry + } +} + +# ::TreeCtrl::IsSensitive +# +# Returns 1 if the given window coordinates are over an element that should +# respond to mouse clicks. The list of elements that respond to mouse clicks +# is set by calling ::TreeCtrl::SetSensitive. +# +# Arguments: +# T The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::IsSensitive {T x y} { + variable Priv + $T identify -array id $x $y + if {$id(where) ne "item" || $id(element) eq ""} { + return 0 + } + if {![$T item enabled $id(item)]} { + return 0 + } + foreach list $Priv(sensitive,$T) { + set eList [lassign $list C S] + if {[$T column compare $id(column) != $C]} continue + if {[$T item style set $id(item) $C] ne $S} continue + if {[lsearch -exact $eList $id(element)] == -1} continue + return 1 + } + return 0 +} + +# ::TreeCtrl::IsSensitiveMarquee +# +# Returns 1 if the given window coordinates are over an element that +# should respond to the marquee. The list of elements that respond to the +# marquee is set by calling ::TreeCtrl::SetSensitiveMarquee, or if that list +# is empty then the same list passed to ::TreeCtrl::SetSensitive. +# +# Arguments: +# T The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::IsSensitiveMarquee {T x y} { + variable Priv + $T identify -array id $x $y + if {$id(where) ne "item" || $id(element) eq ""} { + return 0 + } + if {![$T item enabled $id(item)]} { + return 0 + } + if {![info exists Priv(sensitive,marquee,$T)]} { + set sensitive $Priv(sensitive,$T) + } elseif {[llength $Priv(sensitive,marquee,$T)] == 0} { + set sensitive $Priv(sensitive,$T) + } else { + set sensitive $Priv(sensitive,marquee,$T) + } + foreach list $sensitive { + set eList [lassign $list C S] + if {[$T column compare $id(column) != $C]} continue + if {[$T item style set $id(item) $C] ne $S} continue + if {[lsearch -exact $eList $id(element)] == -1} continue + return 1 + } + return 0 +} + +# ::TreeCtrl::FileListButton1 +# +# Handle . +# +# Arguments: +# T The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::FileListButton1 {T x y} { + variable Priv + focus $T + $T identify -array id $x $y + set marquee 0 + set Priv(buttonMode) "" + foreach e {text entry} { + if {[winfo exists $T.$e] && [winfo ismapped $T.$e]} { + EditClose $T $e 1 0 + } + } + FileListEditCancel $T + # Click outside any item + if {$id(where) eq ""} { + set marquee 1 + + # Click in header + } elseif {$id(where) eq "header"} { + ButtonPress1 $T $x $y + + # Click in item + } elseif {$id(where) eq "item"} { + if {$id(button) || $id(line) ne ""} { + ButtonPress1 $T $x $y + } elseif {$id(column) ne ""} { + set item $id(item) + set drag 0 + if {[IsSensitive $T $x $y]} { + set Priv(drag,wasSel) [$T selection includes $item] + $T activate $item + if {$Priv(selectMode) eq "add"} { + BeginExtend $T $item + } elseif {$Priv(selectMode) eq "toggle"} { + BeginToggle $T $item + } elseif {![$T selection includes $item]} { + BeginSelect $T $item + } + + # Changing the selection might change the list + if {[$T item id $item] eq ""} return + + # Click selected item(s) to drag or rename + if {[$T selection includes $item]} { + set drag 1 + } + } elseif {[FileListEmulateWin7 $T] && [IsSensitiveMarquee $T $x $y]} { + # Click selected item(s) to drag or rename + if {[$T selection includes $item]} { + set Priv(drag,wasSel) 1 + $T activate $item + set drag 1 + # Click marquee-sensitive parts of an unselected item + # in single-select mode changes nothing until a drag + # occurs or the mouse button is released. + } elseif {[$T cget -selectmode] eq "single"} { + set Priv(drag,wasSel) 0 + set drag 1 + } else { + set marquee 1 + } + } else { + set marquee 1 + } + if {$drag} { + set Priv(drag,motion) 0 + set Priv(drag,click,x) $x + set Priv(drag,click,y) $y + set Priv(drag,x) [$T canvasx $x] + set Priv(drag,y) [$T canvasy $y] + set Priv(drop) "" + set Priv(drag,item) $item + set Priv(drag,C) $id(column) + set Priv(drag,E) $id(element) + set Priv(buttonMode) drag + } + } + } + if {$marquee && [$T cget -selectmode] eq "single"} { + set marquee 0 + $T selection clear + } + if {$marquee} { + set Priv(buttonMode) marquee + if {![info exists Priv(sensitive,marquee,$T)]} { + set Priv(sensitive,marquee,$T) {} + } + if {$Priv(selectMode) ne "set"} { + set Priv(selection) [$T selection get] + } else { + if {![FileListEmulateWin7 $T]} { + $T selection clear + } + set Priv(selection) {} + } + MarqueeBegin $T $x $y + + set Priv(marquee,motion) 0 + if {[FileListEmulateWin7 $T]} { + if {[IsSensitiveMarquee $T $x $y]} { + set item $id(item) + $T activate $item + if {$Priv(selectMode) ne "add"} { + $T selection anchor $item + } + } + } + } + return +} + +# ::TreeCtrl::FileListMotion1 +# +# Override default to handle "drag" and "marquee". +# +# Arguments: +# T The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::FileListMotion1 {T x y} { + variable Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + "drag" - + "marquee" { + set Priv(autoscan,command,$T) {FileListMotion %T %x %y} + AutoScanCheck $T $x $y + FileListMotion $T $x $y + } + default { + Motion1 $T $x $y + } + } + return +} + +# ::TreeCtrl::FileListMotion +# +# Handle . +# +# Arguments: +# T The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::FileListMotion {T x y} { + variable Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + "marquee" { + MarqueeUpdate $T $x $y + set select $Priv(selection) + set deselect {} + set items {} + + set Priv(marquee,motion) 1 + + set sensitive $Priv(sensitive,marquee,$T) + if {[llength $sensitive] == 0} { + set sensitive $Priv(sensitive,$T) + } + + # Check items covered by the marquee + foreach list [$T marque identify] { + set item [lindex $list 0] + if {![$T item enabled $item]} continue + + # Check covered columns in this item + foreach sublist [lrange $list 1 end] { + set column [lindex $sublist 0] + set ok 0 + + # Check covered elements in this column + foreach E [lrange $sublist 1 end] { + foreach sList $sensitive { + set sEList [lassign $sList sC sS] + if {[$T column compare $column != $sC]} continue + if {[$T item style set $item $sC] ne $sS} continue + if {[lsearch -exact $sEList $E] == -1} continue + set ok 1 + break + } + } + # Some sensitive elements in this column are covered + if {$ok} { + lappend items $item + } + } + } + foreach item $items { + # Toggle selected status + if {$Priv(selectMode) eq "toggle"} { + set i [lsearch -exact $Priv(selection) $item] + if {$i == -1} { + lappend select $item + } else { + set i [lsearch -exact $select $item] + set select [lreplace $select $i $i] + } + } else { + lappend select $item + } + } + $T selection modify $select all + } + "drag" { + if {!$Priv(drag,motion)} { + # Detect initial mouse movement + if {(abs($x - $Priv(drag,click,x)) <= 4) && + (abs($y - $Priv(drag,click,y)) <= 4)} return + + # In Win7 single-selectmode, when the insensitive parts of an + # unselected item are clicked, the active item and selection + # aren't changed until the drag begins. + if {[FileListEmulateWin7 $T] + && [$T cget -selectmode] eq "single" + && !$Priv(drag,wasSel)} { + $T activate $Priv(drag,item) + $T selection modify $Priv(drag,item) all + } + + set Priv(selection) [$T selection get] + set Priv(drop) "" + $T dragimage clear + # For each selected item, add some elements to the dragimage + foreach I $Priv(selection) { + foreach list $Priv(dragimage,$T) { + set EList [lassign $list C S] + if {[$T item style set $I $C] eq $S} { + eval $T dragimage add $I $C $EList + } + } + } + set Priv(drag,motion) 1 + TryEvent $T Drag begin {} + } + + # Find the element under the cursor + set drop "" + $T identify -array id $x $y + if {[IsSensitive $T $x $y]} { + set sensitive 1 + } elseif {[FileListEmulateWin7 $T] && [IsSensitiveMarquee $T $x $y]} { + set sensitive 1 + } else { + set sensitive 0 + } + if {$sensitive} { + set item $id(item) + # If the item is not in the pre-drag selection + # (i.e. not being dragged) and it is a directory, + # see if we can drop on it + if {[lsearch -exact $Priv(selection) $item] == -1} { + if {[$T item order $item -visible] < $Priv(DirCnt,$T)} { + set drop $item + # We can drop if dragged item isn't an ancestor + foreach item2 $Priv(selection) { + if {[$T item isancestor $item2 $item]} { + set drop "" + break + } + } + } + } + } + + # Select the directory under the cursor (if any) and deselect + # the previous drop-directory (if any) + $T selection modify $drop $Priv(drop) + set Priv(drop) $drop + + # Show the dragimage in its new position +if {0 && [$T dragimage cget -style] ne ""} { + set x [$T canvasx $x] + set y [$T canvasy $y] +} else { + set x [expr {[$T canvasx $x] - $Priv(drag,x)}] + set y [expr {[$T canvasy $y] - $Priv(drag,y)}] +} + $T dragimage offset $x $y + $T dragimage configure -visible yes + } + default { + Motion1 $T $x $y + } + } + return +} + +# ::TreeCtrl::FileListLeave1 +# +# Handle . +# +# Arguments: +# T The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::FileListLeave1 {T x y} { + variable Priv + # This gets called when I click the mouse on Unix, and buttonMode is unset + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + default { + Leave1 $T $x $y + } + } + return +} + +# ::TreeCtrl::FileListRelease1 +# +# Handle . +# +# Arguments: +# T The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::FileListRelease1 {T x y} { + variable Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + "marquee" { + AutoScanCancel $T + MarqueeEnd $T $x $y + + if {[FileListEmulateWin7 $T]} { + # If the mouse was clicked in whitespace or insensitive part + # of an item and the mouse did not move then the selection + # is not modified until after the mouse button is released. + if {!$Priv(marquee,motion)} { + if {[IsSensitiveMarquee $T $x $y]} { + set item [$T item id active] + if {$Priv(selectMode) eq "add"} { + BeginExtend $T $item + } elseif {$Priv(selectMode) eq "toggle"} { + BeginToggle $T $item + } else { + BeginSelect $T $item + } + } elseif {$Priv(selectMode) eq "set"} { + # Clicked whitespace + $T selection clear + } + } + } + } + "drag" { + AutoScanCancel $T + + # Some dragging occurred + if {$Priv(drag,motion)} { + $T dragimage configure -visible no + if {$Priv(drop) ne ""} { + $T selection modify {} $Priv(drop) + TryEvent $T Drag receive \ + [list I $Priv(drop) l $Priv(selection)] + } + TryEvent $T Drag end {} + } else { + set rename 0 + if {[FileListEmulateWin7 $T]} { + # If the mouse was clicked in the insensitive parts of + # a selected item and multiple items are selected and the + # mouse did not move then the selection is not modified + # until after the mouse button is released. + set item $Priv(drag,item) + if {[$T selection count] == 1 && $Priv(selectMode) eq "set"} { + # In single-selectmode, when clicking the insensitive + # parts of an unselected item, the active item and + # selection aren't changed until the button is released. + if {[$T cget -selectmode] eq "single" && !$Priv(drag,wasSel)} { + $T activate $item + $T selection modify $item all + } else { + # If clicked already-selected item, rename it + set rename $Priv(drag,wasSel) + } + } elseif {[IsSensitive $T $x $y] && !$Priv(drag,wasSel)} { + # Selection was modified on ButtonPress, do nothing + } elseif {$Priv(selectMode) eq "add"} { + # Shift-click does nothing to already-selected item + #BeginExtend $T $item + } elseif {$Priv(selectMode) eq "toggle"} { + BeginToggle $T $item + } else { + # Make this the only selected item + BeginSelect $T $item + } + } elseif {$Priv(selectMode) eq "toggle"} { + # don't rename + } elseif {$Priv(drag,wasSel)} { + # Clicked/released a selected item, but didn't drag + set rename 1 + } + if {$rename} { + set I [$T item id active] + set C $Priv(drag,C) + set E $Priv(drag,E) + set S [$T item style set $I $C] + set ok 0 + foreach list $Priv(edit,$T) { + set eEList [lassign $list eC eS] + if {[$T column compare $C != $eC]} continue + if {$S ne $eS} continue + if {[lsearch -exact $eEList $E] == -1} continue + set ok 1 + break + } + if {$ok} { + FileListEditCancel $T + set Priv(editId,$T) \ + [after $Priv(edit,delay) [list ::TreeCtrl::FileListEdit $T $I $C $E]] + } + } + } + } + default { + Release1 $T $x $y + } + } + set Priv(buttonMode) "" + return +} + +# ::TreeCtrl::EscapeKey +# +# Handle the key. +# +# T The treectrl widget. + +proc ::TreeCtrl::FileListEscapeKey {T} { + variable Priv + if {[info exists Priv(buttonMode)] && $Priv(buttonMode) eq "drag"} { + set Priv(buttonMode) "" + AutoScanCancel $T + if {$Priv(drag,motion)} { + $T selection modify $Priv(selection) all + $T dragimage configure -visible no + TryEvent $T Drag end {} + } + return -code break + } + return +} + +# ::TreeCtrl::FileListEdit +# +# Displays an Entry or Text widget to allow the user to edit the specified +# text element. +# +# Arguments: +# T The treectrl widget. +# I Item. +# C Column. +# E Element. + +proc ::TreeCtrl::FileListEdit {T I C E} { + variable Priv + array unset Priv editId,$T + + if {![winfo exists $T]} return + + set lines [$T item element cget $I $C $E -lines] + if {$lines eq ""} { + set lines [$T element cget $E -lines] + } + + # Scroll item into view + $T see $I ; update + + # Multi-line edit + if {$lines ne "1"} { + scan [$T item bbox $I $C] "%d %d %d %d" x1 y1 x2 y2 + set S [$T item style set $I $C] + set padx [$T style layout $S $E -padx] + # FIXME: max of padx or union padding + GetPadding $padx padw pade + AddUnionPadding $T $S $E padw pade + TextExpanderOpen $T $I $C $E [expr {$x2 - $x1 - $padw - $pade}] + + # Single-line edit + } else { + EntryExpanderOpen $T $I $C $E + } + + TryEvent $T Edit begin [list I $I C $C E $E] + + return +} + +proc ::TreeCtrl::GetPadding {pad _padw _pade} { + upvar $_padw padw + upvar $_pade pade + if {[llength $pad] == 2} { + lassign $pad padw pade + } else { + set pade [set padw $pad] + } + return +} + +# Recursively adds -padx and -ipadx values of other elements in a style that +# contain the given element in its -union. +proc ::TreeCtrl::AddUnionPadding {T S E _padw _pade} { + upvar $_padw padw + upvar $_pade pade + foreach E2 [$T style elements $S] { + set union [$T style layout $S $E2 -union] + if {[lsearch -exact $union $E] == -1} continue + foreach option {-padx -ipadx} { + set pad [$T style layout $S $E2 $option] + GetPadding $pad p1 p2 + # FIXME: max of padx or union padding + incr padw $p1 + incr pade $p2 + } + AddUnionPadding $T $S $E2 padw pade + } + return +} + +# ::TreeCtrl::FileListEditCancel +# +# Aborts any scheduled display of the text-edit widget. +# +# Arguments: +# T The treectrl widget. + +proc ::TreeCtrl::FileListEditCancel {T} { + variable Priv + if {[info exists Priv(editId,$T)]} { + after cancel $Priv(editId,$T) + array unset Priv editId,$T + } + return +} + +# ::TreeCtrl::SetDragImage +# +# Specifies the list of elements that should be added to the dragimage. +# +# Arguments: +# T The treectrl widget. +# listOfLists {{column style element ...} {column style element ...}} + +proc ::TreeCtrl::SetDragImage {T listOfLists} { + variable Priv + foreach list $listOfLists { + set elements [lassign $list column style] + if {[$T column id $column] eq ""} { + error "column \"$column\" doesn't exist" + } + if {[lsearch -exact [$T style names] $style] == -1} { + error "style \"$style\" doesn't exist" + } + foreach element $elements { + if {[lsearch -exact [$T element names] $element] == -1} { + error "element \"$element\" doesn't exist" + } + } + } + set Priv(dragimage,$T) $listOfLists + return +} + +# ::TreeCtrl::SetEditable +# +# Specifies the list of text elements that can be edited. +# +# Arguments: +# T The treectrl widget. +# listOfLists {{column style element ...} {column style element ...}} + +proc ::TreeCtrl::SetEditable {T listOfLists} { + variable Priv + foreach list $listOfLists { + set elements [lassign $list column style] + if {[$T column id $column] eq ""} { + error "column \"$column\" doesn't exist" + } + if {[lsearch -exact [$T style names] $style] == -1} { + error "style \"$style\" doesn't exist" + } + foreach element $elements { + if {[lsearch -exact [$T element names] $element] == -1} { + error "element \"$element\" doesn't exist" + } + if {[$T element type $element] ne "text"} { + error "element \"$element\" is not of type \"text\"" + } + } + } + set Priv(edit,$T) $listOfLists + return +} + +# ::TreeCtrl::SetSensitive +# +# Specifies the list of elements that respond to mouse clicks. +# +# Arguments: +# T The treectrl widget. +# listOfLists {{column style element ...} {column style element ...}} + +proc ::TreeCtrl::SetSensitive {T listOfLists} { + variable Priv + foreach list $listOfLists { + set elements [lassign $list column style] + if {[$T column id $column] eq ""} { + error "column \"$column\" doesn't exist" + } + if {[lsearch -exact [$T style names] $style] == -1} { + error "style \"$style\" doesn't exist" + } + foreach element $elements { + if {[lsearch -exact [$T element names] $element] == -1} { + error "element \"$element\" doesn't exist" + } + } + } + set Priv(sensitive,$T) $listOfLists + return +} + +# ::TreeCtrl::SetSensitiveMarquee +# +# Specifies the list of elements that are sensitive to the marquee. +# If the list is empty then the same list passed to SetSensitive +# is used. +# +# Arguments: +# T The treectrl widget. +# sensitive Boolean value. + +proc ::TreeCtrl::SetSensitiveMarquee {T listOfLists} { + variable Priv + foreach list $listOfLists { + set elements [lassign $list column style] + if {[$T column id $column] eq ""} { + error "column \"$column\" doesn't exist" + } + if {[lsearch -exact [$T style names] $style] == -1} { + error "style \"$style\" doesn't exist" + } + foreach element $elements { + if {[lsearch -exact [$T element names] $element] == -1} { + error "element \"$element\" doesn't exist" + } + } + } + set Priv(sensitive,marquee,$T) $listOfLists + return +} + +# ::TreeCtrl::SetSelectedItemsSensitive +# +# Specifies whether or not entire items are sensitive to mouse clicks +# when they are already selected. +# +# Arguments: +# T The treectrl widget. +# sensitive Boolean value. + +proc ::TreeCtrl::SetSelectedItemsSensitive {T sensitive} { + variable Priv + if {![string is boolean -strict $sensitive]} { + error "expected boolean but got \"$sensitive\"" + } + set Priv(sensitiveSelected,$T) $sensitive + return +} + +# ::TreeCtrl::FileListEmulateWin7 +# +# Test the flag telling the bindings to use Windows 7 behavior. +# +# Arguments: +# T The treectrl widget. +# win7 Boolean value. + +proc ::TreeCtrl::FileListEmulateWin7 {T args} { + variable Priv + if {[llength $args]} { + set win7 [lindex $args 0] + if {![string is boolean -strict $win7]} { + error "expected boolean but got \"$win7\"" + } + set Priv(win7,$T) $win7 + return + } + if {[info exists Priv(win7,$T)]} { + return $Priv(win7,$T) + } + return 0 +} + +# ::TreeCtrl::EntryOpen +# +# Display a ::tk::entry so the user can edit the specified text element. +# +# Arguments: +# T The treectrl widget. +# item Item. +# column Column. +# element Element. + +proc ::TreeCtrl::EntryOpen {T item column element} { + + variable Priv + + set Priv(entry,$T,item) $item + set Priv(entry,$T,column) $column + set Priv(entry,$T,element) $element + set Priv(entry,$T,focus) [focus] + + # Get window coords of the Element + scan [$T item bbox $item $column $element] "%d %d" x y + + # Get the font used by the Element + set font [$T item element perstate $item $column $element -font] + if {$font eq ""} { + set font [$T cget -font] + } + + # Get the text used by the Element. Could check master Element too. + set text [$T item element cget $item $column $element -text] + + # Create the Entry widget if needed + set e $T.entry + if {[winfo exists $e]} { + $e delete 0 end + } else { + $Priv(entryCmd) $e -borderwidth 1 -relief solid -highlightthickness 0 + bindtags $e [linsert [bindtags $e] 1 TreeCtrlEntry] + } + + # Pesky MouseWheel + $T notify bind $e { TreeCtrl::EditClose %T entry 0 1 } + + $e configure -font $font + $e insert end $text + $e selection range 0 end + + set ebw [$e cget -borderwidth] + set ex [expr {$x - $ebw - 1}] + place $e -x $ex -y [expr {$y - $ebw - 1}] -bordermode outside + + # Make the Entry as wide as the text plus "W" but keep it within the + # TreeCtrl borders + set width [font measure $font ${text}W] + set width [expr {$width + ($ebw + 1) * 2}] + scan [$T contentbox] "%d %d %d %d" left top right bottom + if {$ex + $width > $right} { + set width [expr {$right - $ex}] + } + scan [$T item bbox $item $column] "%d %d %d %d" left top right bottom + if {$ex + $width > $right} { + set width [expr {$right - $ex}] + } + place configure $e -width $width + + focus $e + + return +} + +# ::TreeCtrl::EntryExpanderOpen +# +# Display a ::tk::entry so the user can edit the specified text element. +# Like EntryOpen, but Entry widget expands/shrinks during typing. +# +# Arguments: +# T The treectrl widget. +# item Item. +# column Column. +# element Element. + +proc ::TreeCtrl::EntryExpanderOpen {T item column element} { + + variable Priv + + set Priv(entry,$T,item) $item + set Priv(entry,$T,column) $column + set Priv(entry,$T,element) $element + set Priv(entry,$T,focus) [focus] + + # Get window coords of the Element + scan [$T item bbox $item $column $element] "%d %d" x y + + # Get the font used by the Element + set font [$T item element perstate $item $column $element -font] + if {$font eq ""} { + set font [$T cget -font] + } + + set Priv(entry,$T,font) $font + + # Get the text used by the Element. Could check master Element too. + set text [$T item element cget $item $column $element -text] + + # Create the Entry widget if needed + set e $T.entry + if {[winfo exists $e]} { + $e delete 0 end + } else { + $Priv(entryCmd) $e -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -relief solid + bindtags $e [linsert [bindtags $e] 1 TreeCtrlEntry] + + # Resize as user types + bind $e { + after idle [list TreeCtrl::EntryExpanderKeypress [winfo parent %W]] + } + } + + # Pesky MouseWheel + $T notify bind $e { TreeCtrl::EditClose %T entry 0 1 } + + $e configure -font $font -background [$T cget -background] + $e insert end $text + $e selection range 0 end + + set ebw [$e cget -borderwidth] + set ex [expr {$x - $ebw - 1}] + place $e -x $ex -y [expr {$y - $ebw - 1}] \ + -bordermode outside + + # Make the Entry as wide as the text plus "W" but keep it within the + # TreeCtrl borders + set width [font measure $font ${text}W] + set width [expr {$width + ($ebw + 1) * 2}] + scan [$T contentbox] "%d %d %d %d" left top right bottom + if {$ex + $width > $right} { + set width [expr {$right - $ex}] + } + place configure $e -width $width + + focus $e + + return +} + +# ::TreeCtrl::EditClose +# +# Hides the text-edit widget and restores the focus if needed. +# Generates and events as needed. +# +# Arguments: +# T The treectrl widget. +# type "entry" or "text". +# accept 0/1: should an event be generated. +# refocus 0/1: should the focus be restored to what it was before editing. + +proc ::TreeCtrl::EditClose {T type accept {refocus 0}} { + variable Priv + + set w $T.$type + # We need the double-idle to get winfo ismapped to report properly + # so this don't get the FocusOut following Escape immediately + update idletasks + place forget $w + focus $T + update idletasks + + if {$accept} { + if {$type eq "entry"} { + set t [$w get] + } else { + set t [$w get 1.0 end-1c] + } + TryEvent $T Edit accept \ + [list I $Priv($type,$T,item) C $Priv($type,$T,column) \ + E $Priv($type,$T,element) t $t] + } + + $T notify unbind $w + + TryEvent $T Edit end \ + [list I $Priv($type,$T,item) C $Priv($type,$T,column) \ + E $Priv($type,$T,element)] + + if {$refocus} { + focus $Priv($type,$T,focus) + } + + return +} + +# ::TreeCtrl::EntryExpanderKeypress +# +# Maintains the width of the text-edit widget during typing. +# +# Arguments: +# T The treectrl widget. + +proc ::TreeCtrl::EntryExpanderKeypress {T} { + + variable Priv + + if {![winfo exists $T]} return + + set font $Priv(entry,$T,font) + set text [$T.entry get] + set ebw [$T.entry cget -borderwidth] + set ex [winfo x $T.entry] + + set width [font measure $font ${text}W] + set width [expr {$width + ($ebw + 1) * 2}] + + scan [$T contentbox] "%d %d %d %d" left top right bottom + if {$ex + $width > $right} { + set width [expr {$right - $ex}] + } + + place configure $T.entry -width $width + + return +} + +# ::TreeCtrl::TextOpen +# +# Display a ::tk::text so the user can edit the specified text element. +# +# Arguments: +# T The treectrl widget. +# item Item. +# column Column. +# element Element. +# width unused. +# height unused. + +proc ::TreeCtrl::TextOpen {T item column element {width 0} {height 0}} { + variable Priv + + set Priv(text,$T,item) $item + set Priv(text,$T,column) $column + set Priv(text,$T,element) $element + set Priv(text,$T,focus) [focus] + + # Get window coords of the Element + scan [$T item bbox $item $column $element] "%d %d %d %d" x1 y1 x2 y2 + + # Get the font used by the Element + set font [$T item element perstate $item $column $element -font] + if {$font eq ""} { + set font [$T cget -font] + } + + # Get the text used by the Element. Could check master Element too. + set text [$T item element cget $item $column $element -text] + + set justify [$T element cget $element -justify] + if {$justify eq ""} { + set justify left + } + + set wrap [$T element cget $element -wrap] + if {$wrap eq ""} { + set wrap word + } + + # Create the Text widget if needed + set w $T.text + if {[winfo exists $w]} { + $w delete 1.0 end + } else { + text $w -borderwidth 1 -highlightthickness 0 -relief solid + bindtags $w [linsert [bindtags $w] 1 TreeCtrlText] + } + + # Pesky MouseWheel + $T notify bind $w { TreeCtrl::EditClose %T text 0 1 } + + $w tag configure TAG -justify $justify + $w configure -font $font -background [$T cget -background] -wrap $wrap + $w insert end $text + $w tag add sel 1.0 end + $w tag add TAG 1.0 end + + set tbw [$w cget -borderwidth] + set tx [expr {$x1 - $tbw - 1}] + place $w -x $tx -y [expr {$y1 - $tbw - 1}] \ + -width [expr {$x2 - $x1 + ($tbw + 1) * 2}] \ + -height [expr {$y2 - $y1 + ($tbw + 1) * 2}] \ + -bordermode outside + + focus $w + + return +} + +# ::TreeCtrl::TextExpanderOpen +# +# Display a ::tk::text so the user can edit the specified text element. +# Like TextOpen, but Text widget expands/shrinks during typing. +# +# Arguments: +# T The treectrl widget. +# item Item. +# column Column. +# element Element. +# width Width of the text element. + +proc ::TreeCtrl::TextExpanderOpen {T item column element width} { + + variable Priv + + set Priv(text,$T,item) $item + set Priv(text,$T,column) $column + set Priv(text,$T,element) $element + set Priv(text,$T,focus) [focus] + + # Get window coords of the Element + scan [$T item bbox $item $column $element] "%d %d %d %d" x1 y1 x2 y2 + + set Priv(text,$T,center) [expr {$x1 + ($x2 - $x1) / 2}] + + # Get the font used by the Element + set font [$T item element perstate $item $column $element -font] + if {$font eq ""} { + set font [$T cget -font] + } + + # Get the text used by the Element. Could check master Element too. + set text [$T item element cget $item $column $element -text] + + set justify [$T element cget $element -justify] + if {$justify eq ""} { + set justify left + } + + set wrap [$T element cget $element -wrap] + if {$wrap eq ""} { + set wrap word + } + + # Create the Text widget if needed + set w $T.text + if {[winfo exists $w]} { + $w delete 1.0 end + } else { + text $w -borderwidth 1 -highlightthickness 0 \ + -selectborderwidth 0 -relief solid + bindtags $w [linsert [bindtags $w] 1 TreeCtrlText] + + # Resize as user types + bind $w { + after idle TreeCtrl::TextExpanderKeypress [winfo parent %W] + } + } + + # Pesky MouseWheel + $T notify bind $w { TreeCtrl::EditClose %T text 0 1 } + + $w tag configure TAG -justify $justify + $w configure -font $font -background [$T cget -background] -wrap $wrap + $w insert end $text + $w tag add sel 1.0 end + $w tag add TAG 1.0 end + + set Priv(text,$T,font) $font + set Priv(text,$T,justify) $justify + set Priv(text,$T,width) $width + + scan [textlayout $font $text -justify $justify -width $width] \ + "%d %d" width height + + set tbw [$w cget -borderwidth] + incr tbw + place $w -x [expr {$x1 - $tbw}] -y [expr {$y1 - $tbw}] \ + -width [expr {$width + $tbw * 2}] \ + -height [expr {$height + $tbw * 2}] \ + -bordermode outside + + focus $w + + return +} + +# ::TreeCtrl::TextExpanderKeypress +# +# Maintains the size of the text-edit widget during typing. +# +# Arguments: +# T The treectrl widget. + +proc ::TreeCtrl::TextExpanderKeypress {T} { + + variable Priv + + if {![winfo exists $T]} return + + set font $Priv(text,$T,font) + set justify $Priv(text,$T,justify) + set width $Priv(text,$T,width) + set center $Priv(text,$T,center) + + set text [$T.text get 1.0 end-1c] + + scan [textlayout $font $text -justify $justify -width $width] \ + "%d %d" width height + + set tbw [$T.text cget -borderwidth] + incr tbw + place configure $T.text \ + -x [expr {$center - ($width + $tbw * 2) / 2}] \ + -width [expr {$width + $tbw * 2}] \ + -height [expr {$height + $tbw * 2}] + + $T.text tag add TAG 1.0 end + + return +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/pkgIndex.tcl new file mode 100644 index 00000000..0de62c30 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/pkgIndex.tcl @@ -0,0 +1,8 @@ + if {[catch {package require Tcl 9.0} o]} return + set script "" + if {![info exists ::env(TREECTRL_LIBRARY)] + && [file exists [file join $dir treectrl.tcl]]} { + append script "[list set ::treectrl_library $dir]\n" + } + append script [list load [file join $dir tcl9treectrl252.dll]] + package ifneeded treectrl 2.5.2 $script diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/tcl9treectrl252.dll b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/tcl9treectrl252.dll new file mode 100644 index 00000000..4d246b75 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/tcl9treectrl252.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/treectrl.html b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/treectrl.html new file mode 100644 index 00000000..9593735e --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/treectrl.html @@ -0,0 +1,4417 @@ + + +treectrl - Tk Commands + + + + +
+

treectrl(n) 2.4.2 treectrl "Tk Commands"

+

Name

+

treectrl - Create and manipulate hierarchical multicolumn widgets

+
+ +

Synopsis

+
+
    +
  • package require treectrl 2.4.2
    • +
+ +
+
+

Description

+
+
treectrl pathName ?options?
+
+
+

The treectrl command creates a new window (given by the +pathName argument) and makes it into a treectrl widget. +Additional options, described above, may be specified on the +command line or in the option database +to configure aspects of the treectrl such as its background color +and relief. The treectrl command returns the +path name of the new window. +At the time this command is invoked, there must not +exist a window named pathName, but pathName's parent must exist.

+

A treectrl is a listbox widget which displays items in a one- or +two-dimensional arrangement. +Items have a parent-child relationship with other items. +Items may be arranged from top-to-bottom or from left-to-right. +Items may be spread about one or more columns. +Each item-column may be configured to span one or more adjacent item-columns. +The visibility of items can be set individually.

+

Items have a set of states, which are boolean properties. +For each column of an item there is a style associated, +which determines how to display the item's column +taking into account the item's current state set. +New states may be defined to further control the appearance of items; +these custom states may be turned on or off in individual columns of items.

+

Multiple rows of column headers are supported. +Column headers have platform-native appearance on Windows, Mac OS X, and Gtk+. +The appearance of column headers may be customized using styles.

+

Columns may be rearranged by the user using drag-and-drop. +One column can be specified to display the data in a hierarchical structure. +The visibility of columns can be set individually.

+

A treectrl can display a user-resizable selection rectangle called the +marquee. Another feature, the drag image, may be used to provide feedback +during drag-and-drop operations. Both of these are features commonly found in +file browsers.

+

A treectrl can generate events when various things happen, such as changes to +the selection, or a parent item being toggled open or closed. Scripts may be +bound to these events. New events can be defined.

+

A treectrl can display a background image. The background image can be +configured to be scrolled and tiled on each axis individually.

+
+

STANDARD OPTIONS

+
+
-background
+
+
-borderwidth
+
+
-cursor
+
+
-font
+
+
-highlightbackground
+
+
-highlightcolor
+
+
-highlightthickness
+
+
-orient
+
+
-relief
+
+
-takefocus
+
+
-xscrollcommand
+
+
-yscrollcommand
+
+
-foreground
+
+
+

See the option manual entry for details on the standard options.

+
+

WIDGET SPECIFIC OPTIONS

+
+
Command-Line Switch: -backgroundimage
+Database Name: backgroundImage
+Database Class: BackgroundImage
+
+

Specifies the name of an image to draw as the list background. Other options +control whether the image is tiled and whether the image scrolls. If the image is +transparent it is drawn on top of any column -itembackground colors.

+
Command-Line Switch: -backgroundmode
+Database Name: backgroundMode
+Database Class: BackgroundMode
+
+

Specifies how the background color of items is chosen in each column. +The value should be one of row, column, order, +or ordervisible. The default is row. +This option has only an effect +for columns which have -itembackground defined as list of two or more +colors (see section COLUMNS below for more on this). If row or +column is specified, the background color is chosen based on the location +of the item in the 1- or 2-dimensional grid of items as layed out on the screen; +this layout of items is affected by the -orient and -wrap options as +well as item visibility. +When order or ordervisible is specified, +the background color is chosen based on the result of the item order +command, regardless of the layout of items.

+
Command-Line Switch: -bgimage
+Database Name: bgImage
+Database Class: BgImage
+
+

Synonym for -backgroundimage.

+
Command-Line Switch: -bgimageanchor
+Database Name: bgImageAnchor
+Database Class: BgImageAnchor
+
+

Specifies how the background image should be aligned in any of the forms +acceptable to Tk_GetAnchor. Must be one of the values +n, ne, e, se, s, sw, +w, nw, or center. The default is nw. +When the background image scrolls, the anchor position is relative to +the canvas, otherwise it is relative to the contentbox.

+
Command-Line Switch: -bgimageopaque
+Database Name: bgImageOpaque
+Database Class: BgImageOpaque
+
+

Specifies a boolean indicating whether or not the background image is fully +opaque. This is needed because there is no way in Tk to determine whether an image +contains transparency or not. The default value is true, so if you use a +transparent -backgroundimage you must set this to false.

+
Command-Line Switch: -bgimagescroll
+Database Name: bgImageScroll
+Database Class: BgImageScroll
+
+

Specifies whether the background image scrolls along with the items or whether it +remains locked in place relative to the edges of the window. +The value must be a string that contains zero or more of the characters +x or y. The default is xy.

+
Command-Line Switch: -bgimagetile
+Database Name: bgImageTile
+Database Class: BgImageTile
+
+

Specifies whether the background image is tiled along the x and/or y axes. +The value must be a string that contains zero or more of the characters +x or y. The default is xy.

+
Command-Line Switch: -buttonbitmap
+Database Name: buttonBitmap
+Database Class: ButtonBitmap
+
+

Specifies the name of a bitmap be used to display the expand/collapse button of an item. +This is a per-state option. +If a bitmap is specified for a certain item state, it overrides the effects of +-usetheme.

+
Command-Line Switch: -buttoncolor
+Database Name: buttonColor
+Database Class: ButtonColor
+
+

Specifies the foreground color which should be used for drawing the outline +and the plus or minus sign of an item's expand/collapse button.

+
Command-Line Switch: -buttonimage
+Database Name: buttonImage
+Database Class: ButtonImage
+
+

Specifies the name of an image to be used to display the expand/collapse button of an item. +This is a per-state option. +If an image is specified for a certain item state, it overrides the effects of +-buttonbitmap and -usetheme.

+
Command-Line Switch: -buttonsize
+Database Name: buttonSize
+Database Class: ButtonSize
+
+

Specifies the width and height of the expand/collapse button of an item +in any of the forms acceptable to Tk_GetPixels.

+
Command-Line Switch: -buttonthickness
+Database Name: buttonThickness
+Database Class: ButtonThickness
+
+

Specifies the width of the outline and the plus or minus sign +of the expand/collapse button of an item +in any of the forms acceptable to Tk_GetPixels.

+
Command-Line Switch: -buttonttracking
+Database Name: buttonTracking
+Database Class: ButtonTracking
+
+

Specifies a boolean that determines if the expand/collapse buttons are tracked +like pushbuttons when clicking them. When true, buttons are not toggled until +the <ButtonRelease> event occurs over them. When false, buttons are toggled as +soon as the <ButtonPress> event occurs over them. This option defaults to +true on Mac OS X and Gtk+, false on Win32 and X11.

+
Command-Line Switch: -canvaspadx
+Database Name: canvasPadX
+Database Class: CanvasPadX
+
+

Specifies the width of extra whitespace on the left and right edges of the +canvas in any of the forms acceptable to Tk_GetPixels. +The option value may be a list of one or two screen distances to specify padding +for the two edges separately. The default is 0.

+
Command-Line Switch: -canvaspady
+Database Name: canvasPadY
+Database Class: CanvasPadY
+
+

Specifies the height of extra whitespace on the top and bottom edges of the +canvas in any of the forms acceptable to Tk_GetPixels. +The option value may be a list of one or two screen distances to specify padding +for the two edges separately. The default is 0.

+
Command-Line Switch: -columnprefix
+Database Name: columnPrefix
+Database Class: ColumnPrefix
+
+

Specifies an ascii string that changes the way column ids are reported and +processed. If this option is a non-empty string, the usual integer value +of a column id is prefixed with the given string. This can aid debugging +but it is important your code doesn't assume column ids are integers if you +use it.

+
Command-Line Switch: -columnproxy
+Database Name: columnProxy
+Database Class: ColumnProxy
+
+

If this option specifies a non empty value, +it should be a screen distance +in any of the forms acceptable to Tk_GetPixels. +Then a 1 pixel thick vertical line will be drawn +at the specified screen distance from the left edge of the treectrl widget, +which reaches from top to bottom of the treectrl widget +and uses an inverting color +(i.e black on lighter background, white on darker background). +This line can be used to give the user a visual feedback +during column resizing.

+
Command-Line Switch: -columnresizemode
+Database Name: columnResizeMode
+Database Class: ColumnResizeMode
+
+

Specifies the visual feedback used when resizing columns. The value should be +one of proxy or realtime. For proxy, a 1-pixel thick +vertical line is drawn representing where the right edge of the column will +be after resizing. For realtime, the column's size is changed while +the user is dragging the right edge of the column. The default is realtime.

+
Command-Line Switch: -columntagexpr
+Database Name: columnTagExpr
+Database Class: ColumnTagExpr
+
+

Specifies a boolean that enables or disables tag expressions in column +descriptions. See ITEM AND COLUMN TAGS.

+
Command-Line Switch: -defaultstyle
+Database Name: defaultStyle
+Database Class: DefaultStyle
+
+

This option is deprecated; use the column option -itemstyle instead. +Specifies a list of styles, one per column, to apply to each item created by +the item create command. The number of styles in the list can be +different from the number of tree columns. +Each list element should be a valid style name or an empty string to +indicate no style should be applied to a specific column. The list of styles +is updated if a style is deleted or if a column is moved.

+
Command-Line Switch: -doublebuffer
+Database Name: doubleBuffer
+Database Class: DoubleBuffer
+
+

This option no longer has any effect, but was left in for compatibility. +It used to control the amount of double-buffering that was used when +displaying a treectrl.

+
Command-Line Switch: -headerfont
+Database Name: headerFont
+Database Class: Font
+
+

Specifies the font to draw text in column headers with. The default value is +TkHeadingFont where available (on Tk 8.5+). This option can be overridden by +setting the -font option for individual column headers.

+
Command-Line Switch: -headerfg
+Database Name: headerForeground
+Database Class: Foreground
+
+

Synonym for -headerforeground.

+
Command-Line Switch: -headerforeground
+Database Name: headerForeground
+Database Class: Foreground
+
+

Specifies the color to draw text in column headers with. +The default value is the Tk button foreground color (usually black). +On Gtk+, the system theme may override this color. +This option (and the Gtk+ system theme color) can be overridden by setting the +-textcolor option for individual column headers.

+
Command-Line Switch: -height
+Database Name: height
+Database Class: Height
+
+

Specifies the desired height for the window +in any of the forms acceptable to Tk_GetPixels. +The default is 200 pixels. +If this option is less than or equal to zero then the window will +not request any size at all.

+
Command-Line Switch: -indent
+Database Name: indent
+Database Class: Indent
+
+

Specifies the screen distance an item is indented relative to its parent item +in any of the forms acceptable to Tk_GetPixels. +The default is 19 pixels.

+
Command-Line Switch: -itemgapx
+Database Name: itemGapX
+Database Class: ItemGapX
+
+

Specifies the horizontal spacing between adjacent items +in any of the forms acceptable to Tk_GetPixels. +The default is 0.

+
Command-Line Switch: -itemgapy
+Database Name: itemGapY
+Database Class: ItemGapY
+
+

Specifies the vertical spacing between adjacent items +in any of the forms acceptable to Tk_GetPixels. +The default is 0.

+
Command-Line Switch: -itemheight
+Database Name: itemHeight
+Database Class: ItemHeight
+
+

Specifies a fixed height for every item +in any of the forms acceptable to Tk_GetPixels. If non-zero, this +option overrides the requested height of an item and the -minitemheight option. +If an item's own -height option is specified then that is the height used for +the item. In any case, items are never shorter than the maximum height of a +button if they display one. The default is 0.

+
Command-Line Switch: -itemprefix
+Database Name: itemPrefix
+Database Class: ItemPrefix
+
+

Specifies an ascii string that changes the way item ids are reported and +processed. If this option is a non-empty string, the usual integer value +of an item id is prefixed with the given string. This can aid debugging +but it is important your code doesn't assume item ids are integers if you +use it.

+
Command-Line Switch: -itemtagexpr
+Database Name: itemTagExpr
+Database Class: ItemTagExpr
+
+

Specifies a boolean that enables or disables tag expressions in item +descriptions. See ITEM AND COLUMN TAGS.

+
Command-Line Switch: -itemwidth
+Database Name: itemWidth
+Database Class: ItemWidth
+
+

Specifies a fixed width for every item in any of the forms acceptable to Tk_GetPixels. +If more than one column is visible, then this option has no effect. +If the -orient option is vertical, and the -wrap option is unspecified, then this +option has no effect (in that case all items are as wide as the column).

+
Command-Line Switch: -itemwidthequal
+Database Name: itemWidthEqual
+Database Class: ItemWidthEqual
+
+

Specifies a boolean that says whether all items should have the same width. +If more than one column is visible, then this option has no effect. +If the -orient option is vertical, and the -wrap option is unspecified, then this +option has no effect (in that case all items are as wide as the column). +If the -itemwidth option is specified, then this option has no effect.

+
Command-Line Switch: -itemwidthmultiple
+Database Name: itemWidthMultiple
+Database Class: ItemWidthMultiple
+
+

Specifies a screen distance that every item's width will be evenly divisible by in any of the forms acceptable to Tk_GetPixels. +If more than one column is visible, then this option has no effect. +If the -orient option is vertical, and the -wrap option is unspecified, then this +option has no effect (in that case all items are as wide as the column). +If the -itemwidth option is specified, then this option has no effect.

+
Command-Line Switch: -linecolor
+Database Name: lineColor
+Database Class: LineColor
+
+

Specifies the color which should be used for drawing +the connecting lines between related items.

+
Command-Line Switch: -linestyle
+Database Name: lineStyle
+Database Class: LineStyle
+
+

Specifies the appearance of the connecting lines between related items. +The value should be dot, which is the default, or solid.

+
Command-Line Switch: -linethickness
+Database Name: lineThickness
+Database Class: LineThickness
+
+

Specifies the thickness of the connecting lines between related items +in any of the forms acceptable to Tk_GetPixels.

+
Command-Line Switch: -minitemheight
+Database Name: minItemHeight
+Database Class: MinItemHeight
+
+

Specifies a minimum height for every item +in any of the forms acceptable to Tk_GetPixels. +The default is 0, which means that every item has the height requested by the +arrangement of elements in each column. +This option has no effect if either the -itemheight widget option or -height +item option is specified. +In any case, items are never shorter than the maximum height of an expand/collapse button.

+
Command-Line Switch: -rowproxy
+Database Name: rowProxy
+Database Class: RowProxy
+
+

If this option specifies a non empty value, +it should be a screen distance +in any of the forms acceptable to Tk_GetPixels. +Then a 1 pixel thick horizontal line will be drawn +at the specified screen distance from the top edge of the treectrl widget, +which reaches from left to right of the treectrl widget +and uses an inverting color +(i.e black on lighter background, white on darker background). +This line can be used to give the user a visual feedback +during row resizing.

+
Command-Line Switch: -scrollmargin
+Database Name: scrollMargin
+Database Class: ScrollMargin
+
+

Specifies a positive screen distance +in any of the forms acceptable to Tk_GetPixels. +This option is used by the default bindings to determine how close to the +edges of the contentbox the mouse pointer must be before scrolling occurs. +Specifying a positive value is useful when items may be drag-and-dropped. +Defaults to 0.

+
Command-Line Switch: -selectmode
+Database Name: selectMode
+Database Class: SelectMode
+
+

Specifies one of several styles for manipulating the selection. +The value of the option may be arbitrary, but the default bindings +expect it to be either single, browse, multiple, +or extended; the default value is browse.

+
Command-Line Switch: -showbuttons
+Database Name: showButtons
+Database Class: ShowButtons
+
+

Specifies a boolean value that determines whether this widget +leaves indentation space to display the expand/collapse buttons next to items. +The default value is true. +The item option -button determines whether an item has a button. +See also the widget options -showrootbutton and -showrootchildbuttons.

+
Command-Line Switch: -showheader
+Database Name: showHeader
+Database Class: ShowHeader
+
+

Specifies a boolean value that determines whether this widget +should display the header line with the column names at the top of the widget. +The default value is true.

+
Command-Line Switch: -showlines
+Database Name: showLines
+Database Class: ShowLines
+
+

Specifies a boolean value that determines whether this widget +should draw the connecting lines between related items. +The default value is true on Win32 and X11, false on Mac OS X and Gtk+.

+
Command-Line Switch: -showroot
+Database Name: showRoot
+Database Class: ShowRoot
+
+

Specifies a boolean value that determines whether this widget +should draw the root item. +By suppressing the drawing of the root item the widget can have +multiple items that appear as toplevel items. +The default value is true.

+
Command-Line Switch: -showrootbutton
+Database Name: showRootButton
+Database Class: ShowRootButton
+
+

Specifies a boolean value that determines whether this widget +leaves indentation space to display the expand/collapse button next to the +root item. The default value is false. +The item option -button determines whether the root item has a button.

+
Command-Line Switch: -showrootchildbuttons
+Database Name: showRootChildButtons
+Database Class: ShowRootChildButtons
+
+

Specifies a boolean value that determines whether this widget +should draw the expand/collapse buttons next to children of the root item. +The default value is true.

+
Command-Line Switch: -showrootlines
+Database Name: showRootLines
+Database Class: ShowRootLines
+
+

Specifies a boolean value that determines whether this widget +should draw the connecting lines between children of the root item. +The default value is true.

+
Command-Line Switch: -treecolumn
+Database Name: treeColumn
+Database Class: TreeColumn
+
+

Specifies a column description that determines which +column displays the expand/collapse buttons and connecting lines between items. +The default is unspecified.

+
Command-Line Switch: -usetheme
+Database Name: useTheme
+Database Class: UseTheme
+
+

Specifies a boolean value that determines whether this widget should draw +parts of itself using a platform-specific theme manager. +The default is true.

+
Command-Line Switch: -width
+Database Name: width
+Database Class: Width
+
+

Specifies the desired width for the window +in any of the forms acceptable to Tk_GetPixels. +The default is 200 pixel. +If this option is less than or equal to zero then the window will +not request any size at all.

+
Command-Line Switch: -wrap
+Database Name: wrap
+Database Class: Wrap
+
+

Specifies whether items are arranged in a 1- or 2-dimensional layout.

+

If the value is an empty string (the default), then items are arranged from top +to bottom (-orient=vertical) or from left to right (-orient=horizontal) in +a 1-dimensional layout.

+

If the value is "N items", then no more than N items will appear in +a vertical group (-orient=vertical) or horizontal group (-orient=horizontal).

+

If the value is "N pixels", then no vertical group of items will be +taller than N pixels (-orient=vertical) or no horizontal group of items will +be wider than N pixels (-orient=horizontal).

+

If the value is window, then a no vertical group of items will be +taller than the window (-orient=vertical) or no horizontal group of items will +be wider than the window (-orient=horizontal).

+

It is also possible to cause wrapping to occur on a per-item basis by using +the item option -wrap. See the item create command for that option.

+
Command-Line Switch: -xscrolldelay
+Database Name: xScrollDelay
+Database Class: ScrollDelay
+
+

This option controls how quickly horizontal scrolling occurs while dragging +the mouse with button 1 pressed. +The value should be a list of 1 or 2 integers interpreted as milliseconds. +If 2 values are specified, then the first value determines the intial delay +after the first scroll, and the second value determines the delay for all +scrolling after the first. If only 1 value is specified, each scroll takes +place after that delay.

+
Command-Line Switch: -xscrollincrement
+Database Name: xScrollIncrement
+Database Class: ScrollIncrement
+
+

Specifies an increment for horizontal scrolling, in any of the usual forms +permitted for screen distances. If the value of this option is greater +than zero, the horizontal view in the window will be constrained so that +the canvas x coordinate at the left edge of the window is always an even +multiple of -xscrollincrement; furthermore, the units for scrolling +(e.g., the change in view when the left and right arrows of a scrollbar +are selected) will also be -xscrollincrement. If the value of +this option is less than or equal to zero, then horizontal scrolling +snaps to the left of an item, or part of an item if items are wider than the +contentbox.

+
Command-Line Switch: -xscrollsmoothing
+Database Name: xScrollSmoothing
+Database Class: ScrollSmoothing
+
+

Specifies whether scrolling should be done as if -xscrollincrement=1 whenever +scrolling is performed by non-unit amounts. When the value of this option is true +and the xview command is called to scroll by "units", scrolling occurs according +to the -xscrollincrement option, and all other scrolling is done as if the +-xscrollincrement option was set to 1. The effect is that when dragging the +scrollbar thumb scrolling is very smooth, but when clicking the scrollbar buttons +scrolling is done in coarser increments. The default value is false.

+
Command-Line Switch: -yscrolldelay
+Database Name: yScrollDelay
+Database Class: ScrollDelay
+
+

This option controls how quickly vertical scrolling occurs while dragging +the mouse with button 1 pressed. +The value should be a list of 1 or 2 integers interpreted as milliseconds. +If 2 values are specified, then the first value determines the intial delay +after the first scroll, and the second value determines the delay for all +scrolling after the first. If only 1 value is specified, each scroll takes +place after that delay.

+
Command-Line Switch: -yscrollincrement
+Database Name: yScrollIncrement
+Database Class: ScrollIncrement
+
+

Specifies an increment for vertical scrolling, in any of the usual forms +permitted for screen distances. If the value of this option is greater +than zero, the vertical view in the window will be constrained so that +the canvas y coordinate at the top edge of the window is always an even +multiple of -yscrollincrement; furthermore, the units for scrolling +(e.g., the change in view when the top and bottom arrows of a scrollbar +are selected) will also be -yscrollincrement. If the value of +this option is less than or equal to zero, then vertical scrolling +snaps to the top of an item, or part of an item if items are taller than the +contentbox.

+
Command-Line Switch: -yscrollsmoothing
+Database Name: yScrollSmoothing
+Database Class: ScrollSmoothing
+
+

Specifies whether scrolling should be done as if -yscrollincrement=1 whenever +scrolling is performed by non-unit amounts. When the value of this option is true +and the yview command is called to scroll by "units", scrolling occurs according +to the -yscrollincrement option, and all other scrolling is done as if the +-yscrollincrement option was set to 1. The effect is that when dragging the +scrollbar thumb scrolling is very smooth, but when clicking the scrollbar buttons +scrolling is done in coarser increments. The default value is false.

+
+
+

THE CANVAS

+

Throughout this manual page the term canvas is sometimes used. The canvas +can be thought of as the virtual sheet of paper upon which all visible items are +drawn. The treectrl window displays different areas of the canvas within its +borders as the list is scrolled.

+
+

ITEM AND COLUMN TAGS

+

Columns and items may have any number of tags associated with them. +A tag is just a string of characters, and it may take any form, +including that of an integer, although the characters '(', ')', '&', '|', '^' +and '!' should be avoided.

+

The same tag may be associated with many columns or items. This is commonly done to group +items in various interesting ways; for example, in a file browser all directories +might be given the tag "directory".

+

Tag expressions are used in column descriptions +and item descriptions to specify which columns +and items to operate on. +A tag expression can be a single tag name or a logical expression of tags +using operators '&&', '||', '^' and '!', and parenthesized subexpressions. +For example:

+
+.t item id "tag {(a && !b) || (!a && b)}"
+
+

or equivalently:

+
+.t item id "tag {a ^ b}"
+
+

will return the unique ids of any items with either "a" or "b" tags, but not both.

+

Within a tag expression a tag name may be enclosed in double quotes to avoid special +processing of the operator characters. For example:

+
+.t item id {tag {"a&&b"||c}}
+
+

will return the unique ids of any items with either "a&&b" or "c" tags; in this +example the && is not treated as an operator. A double-quote may be escaped within +a quoted tag name using a backslash '\'.

+

Tag operators may be bypassed completely by setting the -columntagexpr and +-itemtagexpr options. This can be useful if your application has column +or item tags containing arbitrary text.

+
+.t configure -itemtagexpr false
+.t item delete "tag a&&b"
+
+
+

WIDGET COMMAND

+

The treectrl command creates a new Tcl command whose +name is the same as the path name of the treectrl's window. +This command may be used to invoke various +operations on the widget. It has the following general form:

+

pathName option ?arg arg ...?

+

PathName is the name of the command, which is the same as +the treectrl widget's path name. Option and the args +determine the exact behavior of the command. The following +commands are possible for treectrl widgets:

+
+
pathName activate itemDesc
+

Sets the active item to the one described by itemDesc, +and switches on the state active for that item. +The active item can be referred to by the item description active. +If this command changes which item is active an <ActiveItem> event is generated. +If the active item is deleted the root item becomes the new active item.

+
pathName bbox ?area?
+

Returns a list with four elements giving the bounding box (left, top, right +and bottom) of an area of the window. If area is not specified, then +the result is the bounding box of the entire window. +If area is content, then the result is the part of the window +not including borders, headers, or locked columns. +If area is header, then the result is the part of the window +not including borders where column titles are displayed. +If area is left, then the result is the part of the window +not including borders or headers where left-locked columns are displayed. +If area is right, then the result is the part of the window +not including borders or headers where right-locked columns are displayed.

+

If area is one of header.left, header.none or +header.right then the area of the column headers occupied by columns +with -lock=left, -lock=none or -lock=right is returned.

+

An empty string is returned if the display area has +no height or width, which can be true for various reasons such as the window +is too small, or the header is not displayed, or there aren't any locked +columns.

+
pathName canvasx windowx
+

Translates the given window x-coordinate windowx in the treectrl +to canvas coordinate space. The marquee command +expects canvas coordinates.

+
pathName canvasy windowy
+

Translates the given window y-coordinate windowy in the treectrl +to canvas coordinate space. The marquee command +expects canvas coordinates.

+
pathName cget option
+

Returns the current value of the configuration option given +by option. +Option may have any of the values accepted by the tree +command.

+
pathName collapse ?-recurse? ?itemDesc ...?
+

Deprecated. Use item collapse instead.

+
pathName column option column ?arg ...?
+

This command is used to manipulate the columns of the treectrl widget +(see section COLUMNS below). +The exact behavior of the command depends on the option argument +that follows the column argument. +The following forms of the command are supported:

+
+
pathName column bbox columnDesc
+

Returns a list with four elements giving the bounding box +of the header of the column specified by the +column description columnDesc. +The returned coordinates are relative to the top-left corner of the widget. +If the column option -visible=false or if the widget option +-showheader=false, then an empty list is returned.

+
pathName column cget columnDesc option
+

This command returns the current value of the option named option +for the column specified by the +column description columnDesc, +ColumnDesc may also be the string tail to specify the tail column. +Option may have any of the values accepted by the +column configure widget command.

+
pathName column configure columnDesc ?option? ?value? ?option value ...?
+

This command is similar to the configure widget command except +that it modifies options associated with the columns specified by the +column description columnDesc +instead of modifying options for the overall treectrl widget. +ColumnDesc may be the string tail to specify the tail column. +If columnDesc refers to more than one column, then at least one option-value pair +must be given. +If no option is specified, the command returns a list describing +all of the available options for columnDesc (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no option +is specified). +If one or more option-value pairs are specified, then the command +modifies the given option(s) to have the given value(s) for columnDesc; +in this case the command returns an empty string.

+

See COLUMNS below for details on the options available for columns.

+

For compatibility with older versions of treectrl (which did not support more +than one row of column headers) any of the configuration options mentioned in +the HEADERS section, such as -arrow, -text, etc, +may be passed to the top header-row through this command.

+
pathName column compare column1 op column2
+

For both column descriptions column1 +and column2 the index is retrieved +(as returned from the column order widget command). +Then these indexes are compared using the operator op, which must +be either <, <=, ==, >=, >, +or !=. +The return value of this command is 1 if the comparison evaluated to true, +0 otherwise.

+
pathName column count ?columnDesc?
+

If no additional arguments are given, the result is a decimal string giving the number of +columns created by the column create widget command which haven't been +deleted by the column delete widget command; in this case the tail column +is not counted. +If columnDesc is given, then the result is the number of columns that +match that column description.

+
pathName column create ?option value ...?
+

This command creates a new column in the treectrl widget. The new column is +placed to the right of all other columns (except the tail column). Any +option-value arguments configure the new column according to the +column configure command. The return value is the unique identifier +of the new column.

+
pathName column delete first ?last?
+

Deletes the specified column(s). First and last must be valid +column descriptions. If both first +and last are specified, then they may refer to a single column only. +The tail column cannot be deleted and it is an error to specify it. +The order of first and last doesn't matter, and first may +be equal to last.

+
pathName column dragcget option
+

Deprecated. Use header dragcget instead.

+
pathName column dragconfigure ?option? ?value? ?option value ...?
+

Deprecated. Use header dragconfigure instead.

+
pathName column index columnDesc
+

Deprecated. Use column id instead.

+
pathName column id columnDesc
+

This command resolves the column description +columnDesc into a list of unique column identifiers. If the column(s) described by +columnDesc don't exist, this command returns an empty list.

+
pathName column list ?-visible?
+

This command returns a list of identifiers for every column (except the tail) +from left to right. If -visible is given, only columns whose -visible +option is true are returned.

+
pathName column move columnDesc beforeDesc
+

Moves the column specified by columnDesc to the left of the column +specified by beforeDesc. Both columnDesc and beforeDesc +must be valid column descriptions. +If beforeDesc is the string tail, +the column columnDesc will become the last column.

+
pathName column neededwidth columnDesc
+

This command returns a decimal string giving the needed width +of the column specified by the column description +columnDesc. +The needed width is the maximum of the width of the column header +and the width of the widest style in any visible item.

+

When an item style or column header spans multiple columns, the needed width +of a column is affected by the widths of other columns in the span, in which +case the result of this command isn't particularly useful.

+
pathName column order columnDesc ?-visible?
+

This command returns a decimal string giving the position of the column +specified by the column description +columnDesc +in the list of columns starting from zero for the leftmost column. +If -visible is given, only columns whose -visible +option is true are considered, and -1 is returned if columnDesc's -visible +option is false.

+
pathName column tag option ?arg arg ...?
+

This command is used to manipulate tags on columns. +The exact behavior of the command depends on the option argument +that follows the column tag argument. +The following forms of the command are supported:

+
+
pathName column tag add columnDesc tagList
+

Adds each tag in tagList to the columns specified by the +column description columnDesc. +Duplicate tags are ignored. The list of tags for a column can also be +changed via a column's -tags option.

+
pathName column tag expr columnDesc tagExpr
+

Evaluates the tag expression tagExpr against every column +specified by the column description +columnDesc. The result is 1 if the tag expression evaluates to true +for every column, 0 otherwise.

+
pathName column tag names columnDesc
+

Returns a list of tag names assigned to the columns +specified by the column description +columnDesc. The result is the union of any tags assigned to the +columns.

+
pathName column tag remove columnDesc tagList
+

Removes each tag in tagList from the columns specified by the +column description columnDesc. +It is not an error if any of the columns do not use any of the tags. +The list of tags for a column can also be changed via a column's +-tags option.

+
+
pathName column width columnDesc
+

This command returns a decimal string giving the width in pixels +of the column specified by the column description +columnDesc, +even if the treectrl is configured to not display the column headers +by means of the -showheader option.

+
+
pathName compare itemDesc1 op itemDesc2
+

Deprecated. Use the item compare command instead.

+
pathName configure ?option? ?value option value ...?
+

Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option-value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the treectrl +command.

+
pathName contentbox
+

Returns a list with four elements giving the bounding box +of the screen area used to display items. +This is the area of the window not including borders, column headers, or +locked columns. An empty string is returned if the display area has +no height or width, which can happen if the window is too small. +The result of this command is the same as that of bbox content.

+
pathName debug option ?arg arg ...?
+

This command is used to facilitate debugging of the treectrl widget. +The exact behavior of the command depends on the option argument +that follows the debug argument. +The following forms of the command are supported:

+
+
pathName debug alloc
+

Returns a string giving partial statistics on memory allocations, if the package +was built with TREECTRL_DEBUG defined.

+
pathName debug cget option
+

This command returns the current value of the debugging option +named option. +Option may have any of the values accepted by the +debug configure widget command.

+
pathName debug configure ?option? ?value? ?option value ...?
+

This command is similar to the configure widget command except +that it modifies debugging options +instead of modifying options for the overall treectrl widget. +If no option is specified, the command returns a list describing +all of the available debugging options (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no option +is specified). +If one or more option-value pairs are specified, then the command +modifies the given debugging option(s) to have the given value(s); +in this case the command returns an empty string.

+

The following debugging options are supported:

+
+
-displaydelay millis
+

Specifies a time duration in milliseconds, which should be waited +after something has been drawn to the screen. +Setting this option has only an effect, if the +debugging options -enable and -display are switched on.

+
-data boolean
+

If this option is switched on +(together with the debugging option -enable), +at various places a consistence check +on the internal data structure is made +(e.g. for every item is checked, +if the registered number of children is equal to the number of child items). +If an inconsistency was found, a Tcl background error is raised.

+
-display boolean
+

If this option is switched on +(together with the debugging option -enable), +at varios places additional debugging output is printed to stdout.

+
-drawcolor color
+

When specified, areas of the window are painted with this color when drawing +in those areas is about to occur. +Setting this option has only an effect if the +debugging options -enable and -display are switched on.

+
-enable boolean
+

All other debugging options only take effect +if this option is also switched on.

+
-erasecolor color
+

When specified, areas of the window which have been marked as "invalid" +(for example, when part of the window is exposed) are +painted with this color. +If you use an unusual color for this option (like pink), +superflous screen redraws can be spotted more easily. +Setting this option has only an effect if the +debugging options -enable and -display are switched on.

+
-span boolean
+

Debugging related to column spanning.

+
-textlayout boolean
+

Debugging related to text-element layout.

+
+
pathName debug dinfo option
+

Returns a string describing display-related stuff. Option must be one +of alloc, ditem, onscreen or range.

+
pathName debug expose x1 y1 x2 y2
+

Causes the area of the window bounded by the given window-coords to be +marked as invalid. This simulates uncovering part of the window.

+
+
pathName depth ?itemDesc?
+

If the additional argument itemDesc is given, +then the result is a decimal string giving the depth of +the item described by itemDesc. +If no itemDesc is specified, then the maximum depth of all +items in the treectrl widget is returned instead. +Depth is defined as the number of ancestors an item has.

+
pathName dragimage option ?arg ...?
+

This command is used to manipulate the drag image, which is used to provide +feedback when items are drag-and-dropped within the window. The drag image is +displayed as the dotted outlines of one or more items, columns and/or elements. +The exact behavior of the command depends on the option argument +that follows the dragimage argument. +The following forms of the command are supported:

+
+
pathName dragimage add itemDesc ?column? ?element?
+

Adds the shapes of the item described by itemDesc +to the shapes of the dragimage. +Specifying additional arguments reduces +the number of rectangles that are added to the dragimage. +If no additional arguments is specified, +for every element of the item in every column a dotted rectangles is added. +If column is specified, all elements in other columns are ignored. +If also element is specified, only a rectangle for this one element +of the specified item in the given column is added.

+
pathName dragimage cget option
+

This command returns the current value of the dragimage option +named option. +Option may have any of the values accepted by the +dragimage configure widget command.

+
pathName dragimage clear
+

Removes all shapes (if there are any) from the dragimage. +This command does not modify the dragimage offset.

+
pathName dragimage configure ?option? ?value? ?option value ...?
+

This command is similar to the configure widget command except +that it modifies the dragimage options +instead of modifying options for the overall treectrl widget. +If no option is specified, the command returns a list describing +all of the available dragimage options (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named dragimage option (this list will be identical +to the corresponding sublist of the value returned if no option +is specified). +If one or more option-value pairs are specified, then the command +modifies the given dragimage option(s) to have the given value(s); +in this case the command returns an empty string.

+

The following dragimage options are supported:

+
+
-visible boolean
+

Specifies a boolean value which determines +whether the dragimage should currently be visible.

+
+
pathName dragimage offset ?x y?
+

Returns a list containing the x and y offsets of the dragimage, +if no additional arguments are specified. +The dragimage offset is the screen distance the image is displayed at +relative to the item(s) its shape is derived from. +If two coordinates are specified, +sets the dragimage offset to the given coordinates x and y.

+
+
pathName element option ?element? ?arg arg ...?
+

This command is used to manipulate elements (see ELEMENTS AND STYLES below). +The exact behavior of the command depends on the option argument +that follows the element argument. +The following forms of the command are supported:

+
+
pathName element cget element option
+

This command returns the current value of the option named option +associated with the element given by element. +Option may have any of the values accepted by the +element configure widget command.

+

This command also accepts the -statedomain option.

+
pathName element configure element ?option? ?value? ?option value ...?
+

This command is similar to the configure widget command except +that it modifies options associated with the element given by element +instead of modifying options for the overall treectrl widget. +If no option is specified, the command returns a list describing +all of the available options for element (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no option +is specified). +If one or more option-value pairs are specified, then the command +modifies the given option(s) to have the given value(s) in element; +in this case the command returns an empty string. +See ELEMENTS AND STYLES below for details on the options available for elements.

+
pathName element create name type ?option value ...?
+

Creates a new master element of type type with the unique user-defined name +name and configures it with zero or more option/value pairs. +See the subsections on individual element types in ELEMENTS AND STYLES +for the options that are valid for each type of element. +This command returns the name of the new element (the same as the name argument).

+

This command also accepts the -statedomain option with a value of +either header or item to specify where this element will be +displayed.

+
pathName element delete ?element ...?
+

Deletes each of the named elements and returns an empty string. +If an element is deleted while it is still configured +as an element of one or more styles +by means of the style elements widget command, +it is also removed from the element lists of these styles.

+
pathName element names
+

Returns a list containing the names of all existing elements.

+
pathName element perstate element option stateList
+

This command returns the value of the per-state +option named option for element for a certain state. +StateList is a list of state names (static and dynamic, see STATES) +which specifies the state to use.

+
pathName element type element
+

Returns the type of the element given by element, +such as rect or text.

+
+
pathName expand ?-recurse? ?itemDesc ...?
+

Deprecated. Use item expand instead.

+
pathName gradient option ?arg ...?
+

This command is used to manipulate color gradients. +See GRADIENTS for more information about using gradients. +The exact behavior of the command depends on the option argument +that follows the gradient argument. +The following forms of the command are supported:

+
+
pathName gradient cget gradient option
+

Returns the current value of the configuration option for the gradient specified by +gradient whose name is option. Option may have any of the +values accepted by the gradient configure command.

+
pathName gradient configure gradient ?option value ...?
+

If no option is specified, the command returns a list describing +all of the available gradient options (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named gradient option (this list will be identical +to the corresponding sublist of the value returned if no option +is specified). +If one or more option-value pairs are specified, then the command +modifies the given gradient option(s) to have the given value(s); +in this case the command returns an empty string.

+

The following options are supported (see gradient create for the meaning of each option):

+
+
-bottom coordSpec
+
+
-left coordSpec
+
+
-orient direction
+
+
-right coordSpec
+
+
-steps stepCount
+
+
-stops stopsList
+
+
-top coordSpec
+
+
+
pathName gradient create name ?option value ...?
+

Creates a new gradient with the name name, which must be a unique name +not used by another gradient created by this treectrl widget.

+

The following options are supported:

+
+
-bottom coordSpec
+
+
-left coordSpec
+
+
-right coordSpec
+
+
-top coordSpec
+

Each of these options specifies one edge of the gradient brush. +If the option is specified as an empty string (the default), the gradient brush's +edge is the same as that of whatever rectangle is being painted using the gradient. +See GRADIENT COORDINATES for details on gradient brush coordinates.

+

The format of each of these options is a list of 2 or more values {value coordType ?arg ...?}, +where value is a floating point number (usually from 0.0 to 1.0) and +coordType is one of area, canvas, column +or item. The area keyword must be followed by one of the same +area names that the bbox command accepts. The column keyword may +be followed by a column description specifying exactly one column. The +item keyword may be followed by an item description specifying exactly +one item.

+
-orient direction
+

This option specifies the direction a linear gradient changes color in. +Must be either horizontal (the default) +or vertical or an abbreviation of one of these.

+
-steps stepCount
+

Specifies the number of bands of color drawn for each color stop described by +the -stops option. The default value is 1, the maximum is 25. +This option has no effect if gradients are drawn using something better than +Tk API calls. See GRADIENTS for more on this.

+
-stops stopsList
+

Specifies the color stops along this gradient. The argument stopsList +has the following form:

+
+{{offset color ?opacity?} {offset color ?opacity?} ...}
+
+

Each offset is a floating point number from 0.0 to 1.0 specifying the +distance from the start of the gradient where the color begins. +Each color is a Tk color name or description. +Each optional opacity is a floating point number from 0.0 to 1.0 +specifying how transparent the gradient is.

+

If stopsList is non-empty there must be at least two stops specified, and +the first offset must be 0.0 and the last offset must be 1.0. Any other +stop offsets must be listed in increasing order. +Specifying opacity has no effect if gradients are drawn using Tk API calls. +See GRADIENTS for more on this.

+
+
pathName gradient delete ?name ...?
+

Deletes each gradient specified by name. If the gradient is still being +used then it is not actually deleted until all elements etc +using the gradient have stopped using it. A deleted-but-in-use gradient is +not recognized by the various gradient commands. Creating a new gradient +with the same name as a deleted-but-in-use gradient resurrects the deleted +gradient.

+
pathName gradient names
+

Returns a list of names of all the gradients that have been created by this treectrl +widget.

+
pathName gradient native ?preference?
+

Without any arguments, this command returns a boolean indicating whether +or not the platform supports native transparent gradients. The preference +argument is a boolean that indicates whether native gradients should be used; +this can be used to test the appearance of the application.

+
+
pathName header option ?arg ...?
+

This command is used to manipulate column headers. +The exact behavior of the command depends on the option argument +that follows the header argument. +The following forms of the command are supported:

+
+
pathName header bbox headerDesc ?column? ?element?
+

See the item bbox command.

+
pathName header compare headerDesc1 op headerDesc2
+

See the item compare command.

+
pathName header configure headerDesc ?arg ...?
+

There are two forms of this command distinguished by whether or not a +column description appears after the +headerDesc argument. If the first argument after headerDesc begins +with a '-' character it is assumed to be an option name, not a column description, +in which case the command applies to the header-row. If the first argument +after headerDesc does not being with a '-' it is assumed to be a +column description, in which case the command applies to a header-column.

+
+
pathName header configure headerDesc ?option? ?value? ?option value ...?
+

If no option is specified, returns a list describing all of the available +options for the header given by headerDesc (see Tk_ConfigureInfo for +information on the format of this list). If option is specified with no +value, then the command returns a list describing the one named option (this +list will be identical to the corresponding sublist of the value returned if +no option is specified).

+

If one or more option-value pairs +are specified, then the command modifies the given option(s) to have the +given value(s); in this case the command returns an empty string. This is the +only case where headerDesc may refer to multiple header-rows.

+

The following options are supported by this command (see header create for +the meaning of each option):

+
+
-height height
+
+
-tags tagList
+
+
-visible boolean
+
+
+
pathName header configure headerDesc column ?option? ?value? ?option value ...?
+

If no option is specified, returns a list describing all of the available +options for the single column column of the header-row given by headerDesc +(see Tk_ConfigureInfo for information on the format of this list). +If option is specified with no value, then the command returns a list +describing the one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified).

+

If one or more option-value pairs +are specified, then the command modifies the given option(s) to have the +given value(s); in this case the command returns an empty string. This is the +only case where both headerDesc may refer to multiple header-rows and +column may refer to multiple header-columns.

+

The following options are supported by this command (see HEADERS) for +the meaning of each option):

+
+
-arrow direction
+
+
-arrowbitmap bitmap
+
+
-arrowgravity direction
+
+
-arrowimage image
+
+
-arrowpadx amount
+
+
-arrowpady amount
+
+
-arrowside side
+
+
-background color
+
+
-bitmap bitmap
+
+
-borderwidth size
+
+
-button boolean
+
+
-font fontName
+
+
-image image
+
+
-imagepadx amount
+
+
-imagepady amount
+
+
-justify justification
+
+
-state state
+
+
-text text
+
+
-textcolor color
+
+
-textlines count
+
+
-textpadx amount
+
+
-textpady amount
+
+
+
+
pathName header count ?headerDesc?
+

If no additional arguments are given, the result is a decimal string giving +the number of header-rows created by the header create widget command +which haven't been deleted by the header delete widget command, plus 1 +for the ever-present top header-row created along with the widget. +If the optional argument headerDesc is given, then the result is the +number of header-rows that match that header description.

+
pathName header create ?option value?
+

Creates a new header-row and returns its unique identifier. +The following configuration options are supported:

+
+
-height height
+

Specifies a fixed height for the header-row in any of the forms acceptable to +Tk_GetPixels. Must be >= 0. If height is zero then the +header-row's height is the maximum height of all of its column headers. +Defaults to 0.

+
-tags tagList
+

TagList is a list of tag names to be added to the new header-row. The +header tag command can also be used to manipulate this list of tags.

+
-visible boolean
+

Boolean must have one of the forms accepted by Tcl_GetBoolean. It +indicates whether or not the header-row should be displayed. If the widget +option -showheader is false then the header-row will not be displayed +regardless of the value of this option.

+
+
pathName header delete headerDesc
+

Deletes the header-rows given by the header description +headerDesc. Attempts to delete the ever-present top header-row are +ignored without raising an error.

+
pathName header dragcget ?arg ...?
+

There are two forms of this command distinguished by whether or not a +header description appears as the first +argument. If the first argument begins with a '-' character it is assumed to +be an option name, not a header description, in which case the command applies +to the header-drag-and-drop options for the widget. If the first argument +does not being with a '-' it is assumed to be a header description, in which +case the command applies to a header-row.

+
+
pathName header dragcget option
+

This command returns the current value of the header-drag-and-drop option named +option for the widget. +The following configuration options are supported (see header dragconfigure +for the meaning of each option):

+
+
-enable boolean
+
+
-imagealpha alpha
+
+
-imagecolor background
+
+
-imagecolumn column
+
+
-imageoffset offset
+
+
-imagespan count
+
+
-indicatorcolor color
+
+
-indicatorcolumn column
+
+
-indicatorside side
+
+
-indicatorspan count
+
+
+
pathName header dragcget headerDesc option
+

This command returns the current value of the header-drag-and-drop option named +option for a header-row. +The following configuration options are supported (see header dragconfigure +for the meaning of each option):

+
+
-draw boolean
+
+
-enable boolean
+
+
+
+
pathName header dragconfigure ?arg ...?
+

There are two forms of this command distinguished by whether or not a +header description appears as the first +argument. If the first argument begins with a '-' character it is assumed to +be an option name, not a header description, in which case the command applies +to the header-drag-and-drop options for the widget. If the first argument +does not being with a '-' it is assumed to be a header description, in which +case the command applies to a header-row.

+
+
pathName header dragconfigure ?option? ?value? ?option value ...?
+

This command queries and sets header-drag-and-drop options for the widget, not +for individual header-rows. +The following configuration options are supported:

+
+
-enable boolean
+

Controls whether the user is allowed to rearrange columns by drag-and-drop. +The default is false. Each header-row also has an -enable +dragconfigure option.

+
-imagealpha alpha
+

Alpha is an integer from 0 (invisible) to 255 (opaque) controlling the +transparency of the drag image. Any value outside this range is clipped. +The default is 200.

+
-imagecolor background
+

Unused.

+
-imagecolumn column
+

Column specifies the column to create the drag image from.

+
-imageoffset offset
+

Offset is the horizontal screen distance the drag image is offset from its +starting position.

+
-imagespan count
+

Count is the number of columns, starting with -imagecolumn, that will +be dragged as a group.

+
-indicatorcolor color
+

Unused.

+
-indicatorcolumn column
+

The 2-pixel-thick line will be drawn over the left or right edge of column.

+
-indicatorside side
+

Unused.

+
-indicatorspan count
+

Count is the number of columns, starting with -indicatorcolumn, that +will be displaced as a group by the dragged column(s)

+
+
pathName header dragconfigure header ?option? ?value? ?option value ...?
+

This command queries and sets header-drag-and-drop options for header-rows, +not for the widget as a whole. +The following configuration options are supported:

+
+
-draw boolean
+

Controls whether a header-row displays any feedback during header drag-and-drop. +The default is true.

+
-enable boolean
+

Controls whether clicking and dragging in this header-row initiates drag-and-drop. +The default is true. If the -enable option for the widget is false +(see above) then this option has no effect.

+
+
+
pathName header element ?arg ...?
+

See the item element command.

+
pathName header id headerDesc
+

This command resolves the header description +headerDesc into a list of unique header-row identifiers. If headerDesc +doesn't refer to any existing header-rows, then this command returns an empty list.

+
pathName header image headerDesc ?column? ?image? ?column image ...?
+

The behavior of this command depends on whether or not a column header was assigned +a style containing an image element. If a column header has no style or no style +with an image element then this command operates on the same -image option as +header configure. Otherwise this command operates on the -image option +of the first image element in a column header's style. See the item image +command.

+
pathName header span headerDesc ?column? ?numColumns? ?column numColumns ...?
+

See the item span command.

+
pathName header state command headerDesc ?arg ...?
+

See the item state command.

+
pathName header style command headerDesc ?arg ...?
+

See the item style command.

+
pathName header text headerDesc ?column? ?text? ?column text ...?
+

The behavior of this command depends on whether or not a column header was assigned +a style containing a text element. If a column header has no style or no style +with a text element then this command operates on the same -text option as +header configure. Otherwise this command operates on the -text option +of the first text element in a column header's style. See item text.

+
pathName header tag command headerDesc ?arg ...?
+

See the item tag command.

+
+
pathName identify ?-array varName? x y
+

This command returns information about the what +is displayed at the given window coordinates x and y. +When the -array option is used to specify the name of an array variable, +elements of the array variable are set as follows:

+
    +

  1. If the coordinates are outside the window, over the borders, or over any +whitespace in the window, then:

    +

    $varName(where) is ""

    2. +

  2. If the coordinates are over a column header, then:

    +

    $varName(where) is header

    +

    $varName(header) is the unique id of the header-row

    +

    $varName(column) is the unique id of the column

    +

    $varName(element) is the name of an element, or ""

    +

    $varName(side) is left or right if the coordinates are close +to the edge of the column header, otherwise ""

    3. +

  3. If the coordinates are over an item, then:

    +

    $varName(where) is item

    +

    $varName(item) is the unique id of the item

    +

    $varName(column) is the unique id of the column

    +

    $varName(element) is the name of an element, or ""

    +

    $varName(button) is a boolean indicating whether or not the coordinates are +over the item's expand/collapse button

    +

    $varName(line) is the unique id of an ancestor of the item +(but not the parent of the item) if the coordinates +are over a line descending from that ancestor. If the coordinates are not +over such a line then $varName(line) is "". +This is used to collapse the ancestor when the line is clicked on.

    4. +
+

When the -array option is not used, this command returns a list +describing what is displayed at the given window coordinates. The format +of this list can be like one of the following:

+
    +

  1. {}

    +

    An empty list is returned if the coordinates are outside the window, over the +borders, or over any whitespace in the window.

    2. +

  2. header C ?left|right?

    +

    header C elem E ?left|right?

    +

    header H column C ?left|right?

    +

    header H column C elem E ?left|right?

    +

    Only when there is more than one header-row is there a +unique id of a header-row H followed by the keyword column. +This is for compatibility with older versions when there was only one row +of column headers allowed.

    3. +

  3. item I column C

    4. +

  4. item I column C elem E

    5. +

  5. item I button

    +

    This is the result when the coordinates are over the expand/collapse button +next to an item.

    6. +

  6. item I line I2

    +

    This is the result when the coordinates are over a line descending from an +ancestor I2 of the item I (but not the parent of that item). This is used to +collapse the ancestor when the line is clicked on.

    7. +
+
pathName index itemDesc
+

Deprecated. Use item id instead.

+
pathName item option ?arg ...?
+

This command is used to manipulate items. +The exact behavior of the command depends on the option argument +that follows the item argument. +The following forms of the command are supported:

+
+
pathName item ancestors itemDesc
+

Returns a list containing the item ids of the ancestors +of the item specified by itemDesc. The first list value is the parent, +the second is the parent's parent, an so on. The last list value will be the +root item if itemDesc is a descendant of the root item.

+
pathName item bbox itemDesc ?column? ?element?
+

Returns a list with four elements giving the bounding box of the item described +by itemDesc. If no further argument is specified, the bbox spans the area +of the item over all non-locked columns. If a column is specified, only the +area of the item in this column is considered. If an additional element is +specified, the area of this element in column of the specified item +is returned. The returned coordinates are relative to the top-left corner of the +widget. If the item is not visible for any reason, the result in an empty string.

+
pathName item buttonstate itemDesc ?state?
+

If state is specified, this command sets the state of the expand/collapse +button for the single item specified by itemDesc. The state +argument may be one of active, normal or pressed. +The current (or newly-set) state of the button is returned. The button state +is used by the system theme, if any, to change the appearance of the button.

+
pathName item cget itemDesc option
+

Returns the current value of the configuration option for the item specified by +itemDesc whose name is option. Option may have any of the +values accepted by the item configure command.

+
pathName item children itemDesc
+

Returns a list containing the item ids of all children +of the item specified by itemDesc in the correct order from +the first child to the last child.

+
pathName item collapse itemDesc ?-animate? ?-recurse?
+

Switches off the open state of the item(s) described by itemDesc. +If an item has descendants, then they are no longer displayed. +If an item is already closed, then this command has no effect on that item. +If -animate is specified, then the item's button will animate as it +transitions between states if the theme supports it; in this case only one item +may be specified. +If -recurse is specified, then all descendants of the items described +by itemDesc will also be collapsed. +For every item that actually will be collapsed, two events are generated: +a <Collapse-before> event before the item state is changed, +and a <Collapse-after> event after the item state was changed.

+
pathName item compare itemDesc1 op itemDesc2
+

From both items described by the itemDescs the index is retrieved +(as returned from the item order widget command). +Then these indexes are compared using the operator op, which must +be either <, <=, ==, >=, >, +or !=. +The return value of this command is 1 if the comparison evaluated to true, +0 otherwise.

+
pathName item complex itemDesc ?list...?
+

This horrible command is now deprecated. Use item element configure +instead. For every column of the treectrl there may be specified one list. +Each list should look like this:

+
+{ {element option value ...} {element option value ...} ...}
+
+

Every option must be known by the element's type +(see ELEMENTS AND STYLES below). +Each option will be set to value for the element in this +one column in this item.

+
pathName item configure itemDesc ?option? ?value? ?option value ...?
+

If no option is specified, returns a list describing all of the available +options for the item given by itemDesc (see Tk_ConfigureInfo for +information on the format of this list). If option is specified with no +value, then the command returns a list describing the one named option (this +list will be identical to the corresponding sublist of the value returned if +no option is specified).

+

If one or more option-value pairs +are specified, then the command modifies the given item option(s) to have the +given value(s); in this case the command returns an empty string. This is the +only case where itemDesc may refer to multiple items.

+

The following options are supported by this command (see item create for +the meaning of each option):

+
+
-button boolean|auto
+
+
-height height
+
+
-tags tagList
+
+
-visible boolean
+
+
-wrap boolean
+
+
+
pathName item count ?itemDesc?
+

If no additional arguments are given, the result is a decimal string giving the number of +items created by the item create widget command which haven't been +deleted by the item delete widget command, plus 1 for the ever-present +root item. +If the optional argument itemDesc is given, then the result is the +number of items that match that item description.

+
pathName item create ?option value ...?
+

Creates some new items and optionally returns a list of unique identifiers for +those items. +The new items have the states open and enabled set by default. +If the treectrl widget currently has the focus, +the state focus is also set.

+

The following options are supported by this command:

+
+
-button boolean|auto
+

The value of this option must have one of the forms accepted by Tcl_GetBoolean +or be the word auto (or any abbreviation of it). It indicates whether or not an expand/collapse +button should be drawn next to the item, typically to indicate that the item has +children. +If the value of this option is auto, then a button is displayed next to the +item whenever the item has any children whose item option -visible is true. +The button will only be displayed if:

+
    +

  1. the column specified by the treectrl option -treecolumn is visible, and

    2. +

  2. the treectrl option -showbuttons is true, and

    3. +

  3. for the root item, the treectrl option -showrootbutton is true, and

    4. +

  4. for immediate children of the root item, the treectrl option -showrootchildbuttons is true.

    5. +
+
-count numItems
+

Specifies the number of items to create. Must be >= 0. Defaults to 1.

+
-enabled boolean
+

Specifies whether the items should be enabled. Default is true.

+
-height height
+

Specifies a fixed height in any of the forms acceptable to Tk_GetPixels. +Must be >= 0. If height is zero then the item's height is unspecified. +Defaults to 0. See also the widget options -itemheight and +-minitemheight.

+
-nextsibling itemDesc
+

Specifies the item before which the new items will be inserted. The new items +will have the same parent as itemDesc.

+
-open boolean
+

Specifies whether the items should be open or closed. Default is true.

+
-parent itemDesc
+

Specifies the item which the new items will be the children of. The new items +will be appended to the list of children of itemDesc. When no parent is +specified, the new items are orphan items (see the widget command +orphans) and will not be displayed in the list.

+
-prevsibling itemDesc
+

Specifies the item after which the new items will be inserted. The new items +will have the same parent as itemDesc.

+
-returnid boolean
+

Specifies whether or not to return a list of item identifiers for the newly +created items. Specifying false is useful when creating a large number of items in the +console or to improve performance. Default is true.

+
-tags tagList
+

TagList is a list of tag names to be added to the new items. +The item tag command can also be used to manipulate this list of tags.

+
-visible boolean
+

Boolean must have one of the forms accepted by Tcl_GetBoolean. It +indicates that the item should be displayed in the list. The item will only be +displayed if:

+
    +

  1. each ancestor is a descendant of the root item (not an orphan), and

    2. +

  2. each ancestor's -visible option is true

    3. +
+
-wrap boolean
+

Boolean must have one of the forms accepted by Tcl_GetBoolean. It +indicates that this item should be the first one in a horizontal range or +vertical range of items. See also the widget option -wrap.

+
+
pathName item delete first ?last?
+

Deletes the specified item(s). +First and last must be valid +item descriptions. +If last isn't specified, then first may specify multiple items. +If both first and last are specified, +they must each decribe a single item with a common ancestor; +then the range of items between first and last is deleted. +The order of first and last doesn't matter.

+

Deleting an item deletes any child items of the deleted item recursively. +If the current active item is deleted, the root item becomes the new active item. +If the current selection anchor item is deleted, the root item becomes the new anchor item. +There is no way to delete the root item of the treectrl widget; +in all cases the specification of the root item is ignored.

+

For each call to this command, two events may be generated. +If any of the deleted items are selected, then they are removed from the selection +and a <Selection> event is generated just before the items are deleted. +If any items are going to be deleted, then an <ItemDelete> event is +generated just before the items are deleted.

+
pathName item descendants itemDesc
+

Returns a list containing the item ids of the descendants +of the item specified by itemDesc, i.e. the children, grandchildren, +great-grandchildren etc, of the item.

+
pathName item dump itemDesc
+

Debug command. Returns a list with 4 words in the form +index index indexVis indexVis.

+
pathName item element command itemDesc column element ?arg ...?
+

This command is used to manipulate elements of the item. +The exact behavior of the command depends on the command argument +that follows the element argument. +The following forms of the command are supported:

+
+
pathName item element actual itemDesc column element option
+

Deprecated. Use item element perstate instead.

+
pathName item element cget itemDesc column element option
+

This command returns the value of the option named option +associated with element inside column of the item described by +itemDesc, if it was already configured for the actual item. +Option may have any of the values accepted by the type of the +specified element (see ELEMENTS AND STYLES below)

+
pathName item element configure itemDesc column element ?option? ?value? ?option value ...?
+

This command modifies configuration options for an element in a column of +an item. +If no option is specified, the command returns a list describing +all of the available options for the element (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no option +is specified).

+

If one or more option-value pairs are specified, then the command +modifies the given option(s) to have the given value(s) in the +element inside column of the item(s) described by itemDesc; +in this case the command returns an empty string. This is the only case where +itemDesc may refer to multiple items.

+

It is possible to configure multiple elements in multiple columns with +a single call. To configure another element in the same column, append a +'+' argument followed by the element name. To configure elements in +another column, append a ',' argument followed by the column. +For example:

+
+.t item element configure $I \
+	$C1 $E1 -text "hello" + $E2 -text "world" , \
+	$C2 $E3 -fill Blue , \
+	$C3 $E1 -text "apples and oranges"
+
+

Each of the column description arguments +to this command may refer to multiple columns if at least one +option-value pair is given.

+
pathName item element perstate itemDesc column element option ?stateList?
+

This command returns the current value of the per-state +option named option for element inside column of the item described by +itemDesc. If stateList is specified, the list of state names (static +and dynamic, see STATES) is used in place of the current state for +item and column.

+
+
pathName item enabled itemDesc ?boolean?
+

Returns 1 if the item described by itemDesc has the +state enabled switched on, 0 otherwise. If boolean is specified, +then the enabled state of every item described by the +item description itemDesc is set accordingly. +New items are enabled by default when created. Disabled items cannot be selected, +and are ignored by the default key-navigation and mouse bindings.

+
pathName item expand itemDesc ?-animate? ?-recurse?
+

Switches on the open state of the item(s) described by itemDesc. +If an item has descendants, then they are now displayed. +If an item is already open, then this command has no effect on that item. +If -animate is specified, then the item's button will animate as it +transitions between states if the theme supports it; in this case only one item +may be specified. +If -recurse is specified, then all descendants of the items described by +itemDesc will also be expanded. +For every item that actually will be expanded, two events are generated: +an <Expand-before> event before the item state is changed, +and an <Expand-after> event after the item state was changed.

+
pathName item firstchild parent ?child?
+

If child is not specified, returns the item id of the first +child of the item described by parent. +If child is specified, it must describe an item +that is neither the root item nor an ancestor of parent. +Then it will become the new first child of parent.

+
pathName item id itemDesc
+

This command resolves the item description +itemDesc into a list of unique item identifiers. If itemDesc +doesn't refer to any existing items, then this command returns an empty list.

+
pathName item image itemDesc ?column? ?image? ?column image ...?
+

This command sets or retrieves the value of the per-state +-image option for the first image element in one or more columns. +If no column is specified, this command returns a list of values, +one per column. +If no image is specified, this command returns the value for column.

+

If one or more column-image pairs is specified, +then the value of the -image option in each column is set to image. +In this case itemDesc may refer to multiple items and each column +may refer to multiple columns.

+

Note that this command is provided as a convenience. Use the +item element configure or item element cget commands if you want +to set or retrieve the value of the -image option for a specific image element.

+
pathName item isancestor itemDesc descendant
+

Returns 1 if the item described by itemDesc is a direct or indirect +parent of the item decribed by descendant, 0 otherwise.

+
pathName item isopen itemDesc
+

Returns 1 if the item described by itemDesc has the +state open switched on, 0 otherwise.

+
pathName item lastchild parent ?child?
+

If child is not specified, returns the item id of the last +child of the item described by parent. +If child is specified, it must describe an item +that is not an ancestor of parent. +Then it will become the new last child of parent.

+
pathName item nextsibling sibling ?next?
+

If next is not specified, returns the item id of the next +sibling of the item described by sibling. +If next is specified, it must describe an item +that is not an ancestor of sibling. +Then it will become the new next sibling of sibling.

+
pathName item numchildren itemDesc
+

Returns the number of children of the item described by itemDesc.

+
pathName item order itemDesc ?-visible?
+

This command returns the position of the item itemDesc relative to +its toplevel ancestor (usually the root item, unless the ancestor is an +orphan). If you imagine all the items flattened into a vertical list, the +result of this command is the row the item falls in. If the optional argument +-visible is given, only the items whose ancestors are expanded, and whose +-visible option is true, get counted; in this case -1 is returned if the item +is not visible.

+
pathName item parent itemDesc
+

Returns the item id of the parent of the item +described by itemDesc.

+
pathName item prevsibling sibling ?prev?
+

If prev is not specified, returns the item id of the previous +sibling of the item described by sibling. +If prev is specified, it must describe an item +that is not an ancestor of sibling. +Then it will become the new previous sibling of sibling.

+
pathName item range first last
+

Returns a list containing the item ids of all items +in the range between first and last, inclusive. +The order between first and last doesn't matter, +and the result is always sorted by the increasing order of the items (as +returned by the item order command). +The items specified by first and last must share a common +ancestor.

+
pathName item remove itemDesc
+

Removes the item described by itemDesc +from the list of children of its parent, so that it will become an orphan.

+
pathName item rnc itemDesc
+

Returns a list of two integers, which corresponds to the row and column +of the item described by itemDesc. The row and column corresponds to +the on-screen arrangement of items as determined by the -orient and -wrap +options. If the item is not displayed, this command returns an empty string.

+
pathName item sort itemDesc ?option ...?
+

Sorts the children of the item described by itemDesc, +and redisplays the tree with the items in the new order.

+

The range of items which should be sorted can be restricted +by means of the -first and/or -last options, +which should be children of the item described by itemDesc; +the order between these two limiting items doesn't matter.

+

The sort column can be specified by means of the -column option; +this option can be used repeatedly to define a multicolumn sort. +The sorting is done by looking at the text +of the element specified by the -element option, +which must be a text element defined in the style of the sorting column, +by default the first text element is used.

+

If the -notreally option is specified, +no rearranging of the items is done; +instead the sorted items are returned as result of the command.

+

By default ASCII sorting is used with the result returned in increasing order. +Any of the following options may be specified to control +the sorting process of the previously specified column +(unique abbreviations are accepted):

+
+
-ascii
+

Use string comparison with ASCII collation order. This is the default.

+
-command command
+

Use command as a comparison command. +To compare two items, evaluate a Tcl script consisting of +command with the numerical ids of the two items appended as additional +arguments. The script should return an integer less than, +equal to, or greater than zero if the first item is to +be considered less than, equal to, or greater than the second, +respectively.

+
-decreasing
+

Sort the items in decreasing order ("largest" items first).

+
-dictionary
+

Use dictionary-style comparison. This is the same as -ascii +except (a) case is ignored except as a tie-breaker and (b) if two +strings contain embedded numbers, the numbers compare as integers, +not characters. For example, in -dictionary mode, bigBoy +sorts between bigbang and bigboy, and x10y +sorts between x9y and x11y.

+
-increasing
+

Sort the items in increasing order ("smallest" items first). This is the default.

+
-integer
+

Convert to integers and use integer comparison.

+
-real
+

Convert to floating-point values and use floating comparison.

+
+
pathName item span itemDesc ?column? ?numColumns? ?column numColumns ...?
+

This command sets or retrieves the number of columns that a style covers. +If no column is specified, the return value is a list of spans, one per column. +If no numColumns is specified, the return value is the span for column.

+

If one or more column-numColumns pairs is specified, the +span for each column is set to numColumns. In this case itemDesc +may refer to multiple items and each column may refer to multiple +columns.

+
pathName item state command itemDesc ?arg ...?
+

This command is used to manipulate the states of an item. +The exact behavior of the command depends on the command argument +that follows the style argument. +The following forms of the command are supported:

+
+
pathName item state define stateName
+

Defines a new state with the name stateName, +which must not be the name of an existing state.

+
pathName item state forcolumn itemDesc column ?stateDescList?
+

Just like item state set but manipulates dynamic states for a single +item column, not the item as a whole. If stateDescList is unspecified, +this command returns a list containing the names of all the dynamic states +which are switched on in column.

+

If stateDescList is specified, then itemDesc may refer to multiple +items and column may refer to multiple columns.

+
pathName item state get itemDesc ?stateName?
+

If no stateName is specified, returns a list containing +the names of all (static and dynamic) states +which are currently switched on for the item described by itemDesc. +If a stateName is specified, +1 is returned if the specified state is currently switched on for the item, +0 otherwise.

+
pathName item state linkage stateName
+

Returns a string indicating whether the specified state is user-defined +by means of the item state define widget command (dynamic) +or predefined by the treectrl widget itself (static).

+
pathName item state names
+

Returns a list containing the names of all user-defined states.

+
pathName item state set itemDesc ?lastItem? stateDescList
+

Every element of stateDescList +must be the name of a dynamic state (see STATES below), +optionally preceded by a ~ or ! character. +Every state with a leading ! will be switched off for the +item described by itemDesc, +every state with a leading ~ will be toggled, and +every state without leading ! or ~ will be switched on. +If lastItem is specified, the state changes will be made for all items +in the range between itemDesc and lastItem. +If lastItem unspecified, +then the state changes are made for all items described by itemDesc.

+
pathName item state undefine ?stateName ...?
+

Every stateName must be the name of a user-defined state. +Removes this state from the list of user-defined states.

+
+
pathName item style command itemDesc ?arg ...?
+

This command is used to manipulate the styles of an item. +The exact behavior of the command depends on the command argument +that follows the style argument. +The following forms of the command are supported:

+
+
pathName item style elements itemDesc column
+

This command returns a list containing the names of elements which were +configured by the item element configure command for the item +described by itemDesc in column. If there is no style assigned +to column an error is returned.

+
pathName item style map itemDesc column style map
+

Like the item style set command, this command may be used to assign a +style to a specific column of an item. Unlike item style set, this +command can transfer configuration values of elements in the current style +to elements in the new style specified by style. +Map must be a list of elementOld-elementNew pairs, where +elementOld is an element in the current style, and elementNew is +an element in the style specified by style. Both elementOld and +elementNew must be of the same type (bitmap, text etc). +ItemDesc may refer to multiple items and column may refer to +multiple columns.

+
pathName item style set itemDesc ?column? ?style? ?column style ...?
+

This command sets or retrieves the style assigned to one or more columns. +If no column is specified, this command returns a list containing the names of the +styles set for all columns of the item described by itemDesc. +If no style is specified, this command +returns the name of the style set for the item described by +itemDesc in column.

+

If one or more column-style pairs is specified, +then the style in each column is set to style. In this case +itemDesc may refer to multiple items and each column may refer to +multiple columns.

+
+
pathName item tag option ?arg arg ...?
+

This command is used to manipulate tags on items. +The exact behavior of the command depends on the option argument +that follows the item tag argument. +The following forms of the command are supported:

+
+
pathName item tag add itemDesc tagList
+

Adds each tag in tagList to the items specified by the +item description itemDesc. +Duplicate tags are ignored. The list of tags for an item can also be +changed via an item's -tags option.

+
pathName item tag expr itemDesc tagExpr
+

Evaluates the tag expression tagExpr against every item +specified by the item description +itemDesc. The result is 1 if the tag expression evaluates to true +for every item, 0 otherwise.

+
pathName item tag names itemDesc
+

Returns a list of tag names assigned to the items +specified by the item description +itemDesc. The result is the union of any tags assigned to the +items.

+
pathName item tag remove itemDesc tagList
+

Removes each tag in tagList from the items specified by the +item description itemDesc. +It is not an error if any of the items do not use any of the tags. +The list of tags for an item can also be changed via an item's +-tags option.

+
+
pathName item text itemDesc ?column? ?text? ?column text ...?
+

This command sets or retrieves the value of the -text option for the first +text element in one or more columns. +If no column is specified, this command returns a list of values, +one per column. +If no text is specified, this command returns the value for column.

+

If one or more column-text pairs is specified, +then the value of the -text option in each column is set to text. +In this case itemDesc may refer to multiple items and each column +may refer to multiple columns.

+

Note that this command is provided as a convenience. Use the +item element configure or item element cget commands if you +want to set or retrieve the value of the -text option for a specific text element.

+
pathName item toggle itemDesc ?-animate? ?-recurse?
+

Changes the open state of the item(s) described by itemDesc. +If the open state is currently switched off, then +this command does the same as the item expand widget command; +otherwise the same as the item collapse widget command. +If -animate is specified, then the item's button will animate as it +transitions between states if the theme supports it; in this case only one item +may be specified. +If -recurse is specified, then the open state of all descendants of +the items described by itemDesc will also be toggled.

+
+
pathName marquee option ?arg ...?
+

This command is used to manipulate the marquee, +which can be used to implement a resizable selection rectangle, in a +file browser for example. +One corner point of the marquee is fixed as long as the marquee is visible +and called the anchor; the diagonally opposite corner is dragged with the +mouse while resizing the marquee and simply called the corner.

+

All coordinates handled by this widget command are canvas +coordinates, i.e. the canvasx or canvasy widget command should be +used to translate window coordinates to canvas coordinates.

+

By default, the marquee is displayed as a 1-pixel thick dotted rectangle. +If either of the -fill or -outline options is specified, then +the marquee is drawn as a filled and/or outlined rectangle of the specified +color(s). The -fill option should specify a transparent gradient to +avoid hiding what is inside the marquee. See GRADIENTS for more info.

+

The exact behavior of the command depends on the option argument +that follows the marquee argument. +The following forms of the command are supported:

+
+
pathName marquee anchor ?x y?
+

Returns a list containing the x and y coordinates of the anchor, +if no additional arguments are specified. +If two coordinates are specified, +sets the anchor to the given coordinates x and y.

+
pathName marquee cget option
+

This command returns the current value of the marquee option +named option. +Option may have any of the values accepted by the +marquee configure widget command.

+
pathName marquee configure ?option? ?value? ?option value ...?
+

This command is similar to the configure widget command except +that it modifies the marquee options +instead of modifying options for the overall treectrl widget. +If no option is specified, the command returns a list describing +all of the available marquee options (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named marquee option (this list will be identical to +the corresponding sublist of the value returned if no option +is specified). +If one or more option-value pairs are specified, then the command +modifies the given marquee option(s) to have the given value(s); +in this case the command returns an empty string.

+

The following marquee options are supported:

+
+
-fill color
+

Specifies the color to fill the marquee rectangle with. See the comments above +about using a transparent gradient here.

+
-outline color
+

Specifies the color to outline the marquee rectangle with.

+
-outlinewidth color
+

Specifies the width of the outline drawn inside the marquee's rectangle. +The outline is not drawn if this value is less than 1. +This option has no effect if the -outline option is unspecified, +i.e., the default dotted rectangle is unaffected by this option. +outlineWidth may be in any of the forms acceptable to Tk_GetPixels. +Defaults to 1.

+
-visible boolean
+

Specifies a boolean value which determines +whether the marquee is displayed.

+
+
pathName marquee coords ?x1 y1 x2 y2?
+

Returns a list containing the x and y coordinates of the anchor +followed by the x and y coordinates of the corner, +if no additional arguments are specified. +If four coordinates are specified, +sets the anchor to the given coordinates x1 and y1 +and the corner to the coordinates x2 and y2.

+
pathName marquee corner ?x y?
+

Returns a list containing the x and y coordinates of the corner, +if no additional arguments are specified. +If two coordinates are specified, +sets the corner to the given coordinates x and y.

+
pathName marquee identify
+

Returns a list with information about any items intersecting the marquee. +The format of the returned list is:

+
+{
+    {item {column element element ...} {column element element ...} ...}
+    {item {column element element ...} {column element element ...} ...}
+    ...
+}
+
+

There may be zero sublists following an item id if the marquee is in the +button/line area of an item. There may be zero element names following a +column id if the item-column has no style or if the marquee does not +intersect any elements in that column.

+
+
pathName notify option ?arg ...?
+

Many Tk widgets communicate with the outside world via -command +callbacks and/or virtual events. For example, the Text widget +evaluates its -yscrollcommand when the view in the widget changes, +and generates a <<Modified>> virtual event when text is inserted or deleted. +A treectrl widget replaces both methods of communication with its own event +mechanism accessed through the notify subcommands.

+

The exact behavior of the command depends on the option argument +that follows the notify argument. +The following forms of the command are supported:

+
+
pathName notify bind ?object? ?pattern? ?+??script?
+

This command associates Tcl scripts with events generated by a +treectrl widget. +If all three arguments are specified, notify bind will arrange for +script (a Tcl script) to be evaluated whenever the event(s) specified +by pattern are generated by this treectrl widget. +If script is prefixed with a "+", then it is appended to any existing +binding for pattern; otherwise script replaces any existing binding. +If script is an empty string then the current binding for pattern +is destroyed, leaving pattern unbound. In all of the cases where a script +argument is provided, notify bind returns an empty string.

+

If pattern is specified without a script, then the script currently +bound to pattern is returned, or an empty string is returned if there is +no binding for pattern. If neither pattern nor script is +specified, then the return value is a list whose elements are all the patterns +for which there exist bindings for object.

+

The object argument determines which window(s) the binding applies to. +If object begins with a dot, as in .a.b.c, then it must be the path name +for a window; otherwise it may be an arbitrary string. Like the regular +bind command, bindings on window names are automatically removed if +that window is destroyed.

+
pathName notify configure object pattern ?option? ?value? ?option value ...?
+

This command sets and retrieves options for bindings created by the +notify bind command.

+

If no option is specified, the command returns a list with +option-value pairs describing all +the available binding options for pattern on object. +If option is specified with no value, +then the command returns the current value of that option. +If one or more option-value pairs are specified, then the command +modifies the given option(s) to have the given value(s) for the binding; +in this case the command returns an empty string.

+

The following binding options are supported:

+
+
-active boolean
+

Specifies if the binding should be active. +As long as this option is specified as false, +a binding script will not be evaluated when the corresponding event is +generated.

+
+
pathName notify detailnames eventName
+

Returns a list containing the names of all details, +which are installed for the event with the name eventName +by means of the notify install widget command +or by the treectrl widget itself.

+
pathName notify eventnames
+

Returns a list containing the names of all events, +which are installed by means of the notify install widget command +or by the treectrl widget itself.

+
pathName notify generate pattern ?charMap? ?percentsCommand?
+

This command causes the treectrl widget to generate an event. This command is +typically used to generate dynamic events created by the notify install +command, but may be used to generate static events also. +The event specified by pattern is generated, and any active binding +scripts on the event are evaluated after undergoing %-substitution. +If there are details defined for the event, +pattern must describe an <eventName-detail> pair, +otherwise pattern should be <eventName>.

+

The optional charMap is a list of char-value pairs +as in the form returned by array get. +Each char has to be exactly one character. +The charMap is used in %-substitution.

+

If percentsCommand is specified, then it will be used to perform %-substitution +on any scripts bound to the event. If percentsCommand is not specified and +the event is dynamic, then the %-subtitution command passed to notify install +will be used if it was provided. If the event is static or no %-substitution +command is available, then all %-substitution is done using charMap only . +See notify install for a description of percentsCommand.

+
pathName notify install pattern ?percentsCommand?
+

This command installs a new event or detail specified by pattern. +Events created by this command are called dynamic, +whereas events created by the treectrl widget itself are called static. +This command may be called to set or retrieve the percentsCommand for +an existing dynamic event.

+

The optional percentsCommand is a list containing the name of a Tcl +command, plus any optional arguments, to which five additional arguments +will be appended. The command will be called to perform %-substitution on any +scripts bound to the event specified by pattern (see EVENTS AND SCRIPT SUBSTITUTIONS). +PercentsCommand should be defined as follows:

+
+proc percentsCommand {?arg arg ...? char object event detail charMap} {
+	switch -- $char {
+		...
+	}
+	return $value
+}
+
+

The optional arg arguments are part of the percentsCommand list. +Char is the %-character to be substituted. Object is the same +as the argument to notify bind. Event and detail specify +the event. CharMap is the same as the argument to notify generate. +PercentsCommand should return the value to replace the %-character by. +If an error occurs evaluating percentsCommand, the %-character is replaced +by itself.

+

notify install returns the current percentsCommand for the event, +or an error if the event is not dynamic.

+
pathName notify install detail eventName detail ?percentsCommand?
+

Deprecated. +Use notify install with a pattern of <eventName-detail> instead.

+
pathName notify install event eventName ?percentsCommand?
+

Deprecated. +Use notify install with a pattern of <eventName> instead.

+
pathName notify linkage pattern
+

Returns a string indicating +whether the specified event or detail is created +by means of the notify install widget command (dynamic) +or by the treectrl widget itself (static).

+
pathName notify linkage eventName ?detail?
+

Deprecated. +Use notify linkage with a pattern of <eventName> or +<eventName-detail> instead.

+
pathName notify unbind object ?pattern?
+

If no pattern is specified, all bindings on object are removed. +If pattern is specified, then the current binding for pattern +is destroyed, leaving pattern unbound.

+
pathName notify uninstall pattern
+

If the event or detail specified by pattern is static +(i.e. created by the treectrl widget itself), an error is generated. +Otherwise the dynamic event or detail is removed. If an event name is specified +without a detail, all details for that event are also removed.

+
pathName notify uninstall detail eventName detail
+

Deprecated. +Use notify uninstall with a pattern of <eventName-detail> instead.

+
pathName notify uninstall event eventName
+

Deprecated. +Use notify uninstall with a pattern of <eventName> instead.

+
+
pathName numcolumns
+

Deprecated. Use the column count command instead.

+
pathName numitems
+

Deprecated. Use the item count command instead.

+
pathName orphans
+

Returns a list containing the item ids of all items +which have no parent. +When an item is created, it has no parent by default, +and can later become an orphan +by means of the item remove widget command. The root item is not returned.

+
pathName range first last
+

Deprecated. Use the item range command instead.

+
pathName scan option args
+

This command is used to implement scanning on treectrls. It has two forms, +depending on option:

+
+
pathName scan mark x y
+

Records x and y and the treectrl's current view; used in conjunction with +later scan dragto commands. Typically this command is associated with a +mouse button press in the widget and x and y are the coordinates of the +mouse. It returns an empty string.

+
pathName scan dragto x y ?gain?
+

This command computes the difference between its x and y arguments (which +are typically mouse coordinates) and the x and y arguments to the last +scan mark command for the widget. It then adjusts the view by gain +times the difference in coordinates, where gain defaults to 10. This +command is typically associated with mouse motion events in the widget, +to produce the effect of dragging the treectrl at high speed through its window. +The return value is an empty string.

+
+
pathName see itemDesc ?columnDesc? ?option value ...?
+

Adjust the view in the treectrl so that the item described by itemDesc +is visible. +If the item is already visible then the command has no effect; +otherwise the treectrl scrolls to bring the item into view, +and the corresponding <Scroll-x> and/or <Scroll-y> +events are generated. If columnDesc is specified then a specific column +of the item is scrolled into view instead of the entire item.

+

The following options are supported:

+
+
-center flags
+

Flags is a string that contains zero or more of the characters x +or y. This option is used to center the item horizontally and/or +vertically in the window. The item will be centered regardless of whether it +is already visible.

+
+
pathName selection option args
+

This command is used to adjust the selection within a treectrl. +It has several forms, depending on option:

+
+
pathName selection add first ?last?
+

First and last (if specified) +must be valid item descriptions. If both +first and last are specified, then they may refer to a single +item only; in this case +the command adds every unselected item in the range between +first and last, inclusive, to the selection +without affecting the selected state of items outside that range. +If only first is specified, then +every unselected item specified by first is added to the selection. +A <Selection> event is generated if any items were added to the +selection.

+
pathName selection anchor ?itemDesc?
+

If itemDesc is specified, +the selection anchor is set to the described item. +The selection anchor is the end of the selection that is fixed +while dragging out a selection with the mouse. +The item description anchor may be used to refer to the anchor item. +This command doesn't modify the selection state of any item. +Returns the unique id of the selection anchor item.

+
pathName selection clear ?first? ?last?
+

First and last (if specified) +must be valid item descriptions. If both +first and last are specified, then they may refer to a single +item only; in this case any selected items between first and last +(inclusive) are removed from the selection without affecting +the selected state of items outside that range. +If only first is specified, then +every selected item specified by first is removed from the selection. +If neither first nor last are specified, +then all selected items are removed from the selection. +A <Selection> event is generated if any items were removed from the +selection.

+
pathName selection count
+

Returns an integer indicating the number +of items in the treectrl that are currently selected.

+
pathName selection get ?first? ?last?
+

When no additional arguments are given, the result is an unsorted list +containing the item ids of all of the items in the treectrl that are currently selected. +If there are no items selected in the treectrl, then an empty string is returned. +The optional arguments first and last are treated as indices into +the sorted list of selected items; these arguments allow in-place lindex +and lrange operations on the selection. For example:

+
+.t selection get 0       ; # return the first selected item
+.t selection get end     ; # return the last selected item
+.t selection get 1 end-1 ; # return every selected item except the first and last
+
+
+
pathName selection includes itemDesc
+

Returns 1 if the item described by itemDesc is currently +selected, 0 if it isn't.

+
pathName selection modify select deselect
+

Both arguments select and deselect are +a possibly-empty list of item descriptions. +Any unselected items in select are added to the selection, +and any selected items in deselect are removed from the selection (except +for those items which are also in select). +A <Selection> event is generated if any items were selected or deselected.

+
+
pathName state option args
+

This command is used to manipulate the list of user-defined item states, +see section STATES below. Item states can also be managed using the +item state command. To manage states for header-rows, +use the header state widget command. +The exact behavior of the command depends on the option argument +that follows the state argument. +The following forms of the command are supported:

+
+
pathName state define stateName
+

Defines a new state with the name stateName, +which must not be the name of an existing state.

+
pathName state linkage stateName
+

Returns a string indicating +whether the specified state is user-defined +by means of the state define widget command (dynamic) +or predefined by the treectrl widget itself (static).

+
pathName state names
+

Returns a list containing the names of all user-defined states.

+
pathName state undefine ?stateName ...?
+

Every stateName must be the name of a user-defined state. +Removes this state from the list of user-defined states.

+
+
pathName style option ?element? ?arg arg ...?
+

This command is used to manipulate styles, which can be thought of +as a geometry manager for elements. +The exact behavior of the command depends on the option argument +that follows the style argument. +The following forms of the command are supported:

+
+
pathName style cget style option
+

This command returns the current value of the option named option +associated with the style given by style. +Option may have any of the values accepted by the +style configure widget command.

+

This command also accepts the -statedomain option.

+
pathName style configure style ?option? ?value? ?option value ...?
+

This command is similar to the configure widget command except +that it modifies options associated with the style given by style +instead of modifying options for the overall treectrl widget. +If no option is specified, the command returns a list describing +all of the available options for style (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no option +is specified). +If one or more option-value pairs are specified, then the command +modifies the given option(s) to have the given value(s) in style; +in this case the command returns an empty string.

+

The following options are supported:

+
+
-buttony offset
+

Specifies the distance from the top of the item that the expand/collapse button +should be drawn. If offset is an empty string (the default) then the button +is centered vertically in the item. +The value may have any of the forms acceptable to Tk_GetPixels. +This option only has effect when the style is set in an item in the tree column.

+
-orient varName
+

This option specifies which orientation should be used +when laying out the elements associated with this style. +Must be either horizontal (the default) +or vertical or an abbreviation of one of these.

+
+
pathName style create name ?option value ...?
+

Creates a new style with the unique user-defined name name. +After name there may be any number of option-value +pairs, each of which sets one of the configuration options +for the style. See the style configure command for the possible +options. +The result of this command is the name of the new style (the same as the +name option).

+

This command also accepts the -statedomain option with a value of +either header or item to specify where this style will be +displayed.

+
pathName style delete ?style ...?
+

Deletes each of the named styles and returns an empty string. +If a style is deleted while it is still used to display +one or more items, +it is also removed from the style list of these items.

+
pathName style elements style ?elementList?
+

Specifies the elements which should be layed out by this style. +Each element of elementList must be the name of an element +created by the widget command element create. +Duplicate names in elementList are ignored. +An element which was specified in a former call of this command +for style but is not included in elementList, +will be deleted from the elements layed out by style.

+

Every element used by a style must have been created with the same value +for the -statedomain option.

+

If the elementList argument is not specified, a list is returned +containing the currently defined elements of style.

+
pathName style layout style element ?option? ?value? ?option value ...?
+

This command is similar to the configure widget command except +that it modifies options used by style for laying out element +instead of modifying options for the overall treectrl widget. +If no option is specified, the command returns a list with +option-value pairs describing +all of the available options for the layout. +If option is specified with no value, then the command returns +the value of the named option. +If one or more option-value pairs are specified, then the command +modifies the given option(s) to have the given value(s) for the layout; +in this case the command returns an empty string.

+

The options of a layout have effect on exactly the one element element +managed by style. +The following options are supported:

+
+
-detach boolean
+

Specifies whether the element should be positioned by itself, +i.e. independent from the other elements. The default is false.

+
-center flags
+

Flags is a string that contains zero or more of the characters +x or y. +x causes the element to be centered horizontally, +y causes the element to be centered vertically. +When more than one element has -center layout, all the elements between the +first and last with -center layout in the style's list of elements are centered +as a group. Consider the following when there is another element to the right +of MyElement:

+
+.t style layout MyStyle MyElement -expand we
+.t style layout MyStyle MyElement -center x
+
+

With the first call, MyElement will be centered only within the space that +is not occupied by the other element, so MyElement will appear off-center +towards the left of the style. With the second call, MyElement will be +centered within the style so long as it doesn't overlap the other element.

+
-draw boolean
+

This is a per-state option that determines whether +an element should be drawn. If the value of the option evaluates to false for a given +item state, then the element is not drawn, although it still consumes space in +the layout.

+
-expand flags
+

This option allows the external padding around the element +to increase when a style has more screen space than it needs. +Flags is a string that contains zero or more of the characters +n, s, w or e. +Each letter refers to the padding on the top, bottom, +left, or right that should be allowed to increase. +This option is typically used to justify an element. +The default is an empty string.

+
-iexpand flags
+

This option allows the internal padding of the element +and the display area of the element to increase +when a style has more screen space than it needs. +Flags is a string that contains zero or more of the characters +x, y, n, s, w or e. +For n, s, w and e, each letter refers to the +padding on the top, bottom, left, or right that should be allowed to increase. +For x and y, each letter refers to the horizontal and +vertical screen space the element can display itself in (i.e., the space +between the padding). Note that if the +-union option is specified for this element, then the x and +y flags have no effect, since the size of an element with +-union layout is determined by the elements it surrounds. +The default is an empty string.

+
-indent boolean
+

For item styles, this option specifies whether the element should be +positioned to the right of the button/line area in the tree column. When +false, the element is displayed beneath the buttons and lines in the tree +column. This option is ignored unless the -detach option is true.

+

For header styles, this option specifies whether the element should be +positioned to the right of the -canvaspadx padding. This option is ignored +unless the -detach option is true or the -union option is +specified.

+

The default is true.

+
-ipadx amount
+
+
-ipady amount
+

Amount specifies how much internal padding to leave on the left and +right (for -ipadx) or top and bottom (for -ipady) sides of +the element. Amount may be a list of two values to specify padding for +the two sides separately. The default value is 0. This option is typically +used with the -union layout option, to create space around the +enclosed elements.

+
-minheight pixels
+
+
-height pixels
+
+
-maxheight pixels
+

Specifies the minimum, fixed, and maximum height of the display area of the element. +The default is unspecified.

+
-minwidth pixels
+
+
-width pixels
+
+
-maxwidth pixels
+

Specifies the minimum, fixed, and maximum width of the display area of the element. +The default is unspecified.

+
-padx amount
+
+
-pady amount
+

Amount specifies how much external padding to leave on the left and +right (for -padx) or top and bottom (for -pady) sides of the +element. Amount may be a list of two values to specify padding for the +two sides separately. The default value is 0.

+
-squeeze flags
+

This option allows the display area of an element to decrease when a +style has less space than it needs. +Flags is a string that contains zero or more of the characters +x or y. +x allows display area to decrease horizontally, +y allows display area to decrease vertically. +This option is typically used for text elements and will cause +the text element to display an ellipsis (...) and/or wrap lines. +The default is an empty string.

+
-sticky flags
+

This option controls how the actual display information (image, text, etc) +of an element is positioned (or stretched) within its display area. +Flags is a string that contains zero or more of the characters n, +s, w or e. Each letter refers to the top, bottom, left +or right side of the display area that the display information should "stick" to. +The default is nswe.

+
-union elementList
+

Specifies a list of other elements which this element will surround. +The size of an element with -union layout is determined by the +size and position of the elements in elementList. +The -ipadx and -ipady options in this case refer to the +distance of the edges of the display area of this element from those elements +it surrounds. This option is typically used to display a selection rectangle +around a piece of text. If none of the elements in elementList are +visible, then the element is not displayed.

+
-visible boolean
+

This is a per-state option that controls visibility +of an element. If the value of the option evaluates to false for a given +item state, then the element is not displayed and consumes no space in the layout.

+
+
pathName style names
+

Returns a list containing the names of all existing styles.

+
+
pathName theme option ?arg ...?
+

This command is used to interact with the platform-specific theme. +The exact behavior of the command depends on the option argument +that follows the theme argument. +The following forms of the command are supported:

+
+
pathName theme platform
+

Returns the API used to draw themed parts of the treectrl. On Mac OS X the result +is always aqua. On MS Windows the result is visualstyles if the +uxtheme.dll was loaded and visual themes are in use, otherwise X11 is +returned to indicate the Tk Xlib calls are drawing the themed parts. +On Unix systems the result is gtk if the Gtk+ version of treectrl +was built, otherwise X11 is returned.

+
pathName theme setwindowtheme appname
+

The command is available on MS Windows only. If appname is "Explorer" then +the item buttons look like those in the Explorer file browser (disclosure +triangles under Windows Vista/7). If appname is an empty string then +the buttons revert to their default appearance according to the system's +current visual style.

+
+
pathName toggle ?-recurse? ?itemDesc ...?
+

Use item toggle instead.

+
pathName xview ?args?
+

This command is used to query and change the horizontal position of the +information displayed in the treectrl's window. +It can take any of the following forms:

+
+
pathName xview
+

Returns a list containing two elements. +Each element is a real fraction between 0 and 1; together they describe +the horizontal span that is visible in the window. +For example, if the first element is .2 and the second element is .6, +20% of the tree's area +is off-screen to the left, the middle 40% is visible +in the window, and 40% of the tree is off-screen to the right. +These are the same values passed to scrollbars via the -xscrollcommand +option.

+
pathName xview moveto fraction
+

Adjusts the view in the window so that fraction of the +total width of the tree is off-screen to the left. +Fraction must be a fraction between 0 and 1. +A <Scroll-x> event is generated.

+
pathName xview scroll number what
+

This command shifts the view in the window left or right according to +number and what. +Number must be an integer. +What must be either units or pages or an abbreviation +of one of these. +If what is units, the view adjusts left or right in units +determined by the -xscrollincrement option (which may be zero, +see the description of that option). +If what is pages then the view +adjusts in units of nine-tenths the window's width. +If number is negative then information farther to the left +becomes visible; if it is positive then information farther to the right +becomes visible. +A <Scroll-x> event is generated.

+
+
pathName yview ?args?
+

This command is used to query and change the vertical position of the +information displayed in the treectrl's window. +It can take any of the following forms:

+
+
pathName yview
+

Returns a list containing two elements. +Each element is a real fraction between 0 and 1; together they describe +the vertical span that is visible in the window. +For example, if the first element is .6 and the second element is 1.0, +the lowest 40% of the tree's area is visible in the window. +These are the same values passed to scrollbars via the -yscrollcommand +option.

+
pathName yview moveto fraction
+

Adjusts the view in the window so that fraction of the tree's +area is off-screen to the top. +Fraction is a fraction between 0 and 1. +A <Scroll-y> event is generated.

+
pathName yview scroll number what
+

This command adjusts the view in the window up or down according to +number and what. +Number must be an integer. +What must be either units or pages. +If what is units, the view adjusts up or down in units +of the -yscrollincrement option (which may be zero, +see the description of that option). +If what is pages then +the view adjusts in units of nine-tenths the window's height. +If number is negative then higher information becomes +visible; if it is positive then lower information +becomes visible. +A <Scroll-y> event is generated.

+
+
+
+

HEADERS

+

A treectrl widget can display zero or more rows of column headers. +When a treectrl widget is created, a single row of column headers (aka a header-row) +is created as well; this top header-row cannot be deleted. Additional header-rows +can be created with the header create command and deleted with header delete.

+

There are no commands for changing the order of header-rows; they are displayed +from top to bottom in the order they were created.

+

Drag-and-drop reordering of column headers is supported within a widget. +To control column header drag-and-drop, use the header dragconfigure command.

+

Header-rows in a treectrl may be specified in a number of ways. +See HEADER DESCRIPTION below.

+

The appearance of individual column headers within a header-row may be +customized in two different ways:

+
    +

  1. By configuring various column header options with the header configure command

    2. +

  2. By assigning a style to a column header with the header style command.

    3. +
+

When one of the options below is specified as per-state, +the state names are those described in STATES for headers only, +i.e. do not use item state names.

+

The following options are supported for each individual column header:

+
+
-arrow direction
+

Indicates whether or not a sort arrow should be drawn in the column header. +Direction must have one of the values +none (the default), up, or down.

+
-arrowbitmap bitmap
+

Specifies as a per-state option the name of a bitmap to +use to draw the arrow if this column's -arrow option is not none.

+
-arrowgravity direction
+

Indicates onto which side the sort arrow should be packed, +if there is more space available for drawing the arrow then needed. +direction must be either left (the default) or right.

+
-arrowimage image
+

Specifies as a per-state option the name of an image to +use to draw the sort arrow if this column's -arrow option is not none. +If an image is specified for a certain state, it overrides the -arrowbitmap option.

+
-arrowpadx amount
+

Amount specifies how much padding to +leave on the left and right of the sort arrow. +Amount may be a list +of two values to specify padding for left and right separately; +it defaults to 6.

+
-arrowpady amount
+

Amount specifies how much padding to +leave on the top and bottom of the sort arrow. +Amount may be a list +of two values to specify padding for top and bottom separately; +it defaults to 0.

+
-arrowside side
+

Indicates on which side of the bitmap/image/text the sort arrow should be drawn. +Side must be either left or right (the default).

+
-bitmap bitmap
+

Specifies the name of a bitmap to display to the left of the column title.

+
-background color
+

Specifies as a per-state option the color to +use for the background of the column header.

+
-borderwidth size
+

Specifies a non-negative value indicating the width +of the 3-D border to draw around the outside of the column header + (if such a border is being drawn; the -relief column option +determines this). +The value may have any of the forms acceptable to Tk_GetPixels.

+
-button boolean
+

Indicates whether or not the column header should be treated like a pushbutton. +When this option is true, the default bindings track <Button-1> events +in the header and generate a <Header-invoke> event when a <ButtonRelease-1> +event occurs in the header. See DYNAMIC EVENTS.

+
-font fontName
+

Specifies the font to use for displaying the column title inside the column header. +When the value of this option is unspecified, the font specified by the widget +option -headerfont is used.

+
-image image
+

Specifies the name of an image to display to the left of the column title. +This option overrides the -bitmap column option.

+
-imagepadx amount
+

Amount specifies how much padding to +leave on the left and right of the image (or bitmap). +Amount may be a list +of two values to specify padding for left and right separately; +it defaults to 6.

+
-imagepady amount
+

Amount specifies how much padding to +leave on the top and bottom of the image (or bitmap). +Amount may be a list +of two values to specify padding for top and bottom separately; +it defaults to 0.

+
-justify justification
+

This option determines how the image and text in the column header are +positioned. +Must be one of left (the default), center, or right.

+
-state state
+

Specifies one of three states for the column header: normal, active, +or pressed. The active state is used when the mouse is over the header. +The pressed state is used when the mouse button is pressed in the header.

+

Changing the value of this option also affects the current set of +header states for the column header, which may +affect both the per-state options mentioned +here (such as -arrowimage) as well as the elements in any style that +may be assigned to the column header.

+
-text text
+

Specifies a text string to be displayed as the column title.

+
-textcolor color
+

Specifies as a per-state option the color to +display the column title with. When the value of this option is unspecified, +the title will be drawn according to the system theme color, if any, otherwise +the widget option -headerforeground is used. The default is unspecified.

+
-textlines count
+

Specifies the maximum number of lines of text to display in the column title. +If this value is zero, the number of lines displayed is determined by any newline +characters and the effects of wrapping when the column width is less than +needed. The default is 1. Note: Under OSX/Aqua this value is always set to 1 when the +treectrl's -usetheme option is true, because the Appearance Manager +uses a fixed height for the column header; there is only room for a single line +of text.

+
-textpadx amount
+

Amount specifies how much padding to +leave on the left and right of the text. +Amount may be a list +of two values to specify padding for left and right separately; +it defaults to 6.

+
-textpady amount
+

Amount specifies how much padding to +leave on the top and bottom of the text. +Amount may be a list +of two values to specify padding for top and bottom separately; +it defaults to 0.

+
+
+

HEADER DESCRIPTION

+

Many of the commands for a treectrl take as an argument a description of which +header-rows to operate on. A header description is a properly-formed +tcl list of keywords and arguments. The first word of a header description must +be one of the following:

+
+
id
+

Specifies a unique header-row identifier, where id should be +the return value of a prior call of the header create widget command, +or 0 to specify the ever-present top header-row.

+
QUALIFIERS
+

Specifies a list of qualifiers. This gives the same result as all followed +by QUALIFIERS; i.e., every header-row is tested for a match.

+
tagExpr QUALIFIERS
+

TagExpr is a tag expression (see ITEM AND COLUMN TAGS) against +which every header-row's tags are tested for a match. +You may run into trouble if tagExpr looks like a header-row id +or other keyword; also, tagExpr must look like a single list element +since header-row descriptions are properly-formed lists. To be safe you may want to +use the tag qualifier followed by tagExpr.

+
+.t header dragconfigure {tag -funky} -draw yes
+
+
+
all QUALIFIERS
+

Matches every header-row which satisfies QUALIFIERS.

+
first QUALIFIERS
+

Indicates the top header-row of the treectrl, or the first header-row starting +from the top that satisfies QUALIFIERS.

+
end QUALIFIERS
+
+
last QUALIFIERS
+

Indicates the last header-row which satisfies QUALIFIERS.

+
+

The word QUALIFIERS above represents a series of zero or more of the +following terms that changes which header-row is chosen:

+
+
tag tagExpr
+

TagExpr is a tag expression (see ITEM AND COLUMN TAGS) against which +a header-row's tags are tested for a match.

+
visible
+

When this qualifier is given, only header-rows that are displayed are matched. +A header-row is displayed only if both the -showheader widget option and +-visible header-row option are true. Also, if only the tail column is +visible, then header-rows are not displayed.

+
!visible
+

When this qualifier is given, only header-rows that are *not* displayed are +matched.

+
+
+

COLUMNS

+

A treectrl widget is capable of displaying multiple columns next to each +other. +An item can be considered as a row, which reaches over all columns.

+

Columns in a treectrl may be specified in a number of ways. +See COLUMN DESCRIPTION below.

+

There is always one special column, the tail column, which fills +all space to the right of the last ordinary column. +This column has no unique ID; +it can only be specified by the keyword tail.

+

For compatibility with older versions of treectrl (which did not support more +than one row of column headers) any of the configuration options mentioned in +the HEADERS section, such as -arrow, -text, etc, +may be passed to the top header-row through the column configure +command and queried with the column cget command.

+

The following options are supported for columns:

+
+
-expand boolean
+

Indicates whether or not any extra horizontal space should be distributed +to this column. +This option has no effect if the -width option is set.

+
-gridleftcolor color
+
+
-gridrightcolor color
+

Specifies the color of the lines drawn down the left and right edges of the +column. These so-called "grid lines" are drawn over the elements of each item +style in the column and down into the whitespace region below any items. +The default value for each option is an empty string meaning no lines are drawn.

+
-itembackground colorList
+

Specifies a list of zero or more colors, which are used as +alternating background colors for items in this column. +See also the -backgroundmode widget option for more on this.

+
-itemjustify justification
+

This option determines how the item styles in this column are aligned +horizontally. +Must be one of left, center, or right. The default +value is an empty string (for compatibility with older versions), in which +case the column option -justify is used to align item styles in this +column.

+
-itemstyle style
+

Style is the name of a style that should be set in this column +for newly-created items.

+
-justify justification
+

This option determines how item styles in this column are aligned horizontally +unless overriden by the -itemjustify option for this column. +Must be one of left (the default), center, or right.

+

For compatibility with older versions of treectrl (which did not allow multiple +rows of column headers), changing the value of this option also changes the +-justify option of the column header in the top header-row.

+
-lock lock
+

This option allows a column to stick to the left or right edge of the window. +A locked column scrolls vertically but not horizontally. +Must be one of none (the default), left, or right.

+
-maxwidth size
+

Specifies the maximum size, in screen units, that will be permitted for this column. +If size is an empty string, then there is no limit on the maximum size of the column. +This option has no effect if the -width option is set.

+
-minwidth size
+

Specifies the minimum size, in screen units, that will be permitted for this column. +If size is an empty string, then the minimum size of the column is zero. +This option has no effect if the -width option is set.

+
-resize boolean
+

Specifies a boolean value that indicates whether the user should be allowed to +resize the column by dragging the edge of the column's header. Default is true.

+
-squeeze boolean
+

Specifies a boolean value that indicates whether or not the column should +shrink when the content width of the treectrl is less than the total needed width +of all visible columns. Defaults to false, which means the column will not get +smaller than its needed width. The column will not get smaller than the value +of its -minwidth option, if specified. This option has no effect if the +-width option is set.

+
-stepwidth size
+

Deprecated. Use the treectrl's -itemwidthmultiple option instead.

+
-tags tagList
+

TagList is a list of tag names that can be used to identify the column. +See also the column tag command.

+
-uniform group
+

When a non-empty value is supplied, this option places the column in a +uniform group with other columns that have the same value for +-uniform. The space for columns belonging to a uniform group is +allocated so that their sizes are always in strict proportion to their +-weight values. +This option is based on the grid geometry manager.

+
-visible boolean
+

Indicates whether or not the column should be displayed.

+
-weight integer
+

Sets the relative weight for apportioning any extra space among columns. +A weight of zero (0) indicates the column will not deviate from its requested +size. A column whose weight is two will grow at twice the rate as a column of +weight one when extra space is allocated to columns. +This option is based on the grid geometry manager.

+
-width size
+

Specifies a fixed width for the column. If this value is an empty string, +then the column width is calculated as the maximum of: +a) the width requested by items; +b) the width requested by the column's header; +and c) the column's -minwidth option. +This calculated width is also affected by the -expand, +-squeeze, -uniform and -weight options. In any case, +the calculated width will not be greater than the -maxwidth option, +if specified.

+
-widthhack boolean
+

Deprecated. Use the treectrl's -itemwidthequal option instead.

+
+
+

COLUMN DESCRIPTION

+

Many of the commands and options for a treectrl take as an argument a +description of which column to operate on. +See the EXAMPLES section for examples. +The initial part of a column description must begin with one of the following terms:

+
+
id
+

Specifies the unique column identifier, where id should be +the return value of a prior call of the column create widget command. +See also the -columnprefix option.

+
QUALIFIERS
+

Specifies a list of qualifiers. This gives the same result as all followed +by QUALIFIERS; i.e., every column is tested for a match.

+
tagExpr QUALIFIERS
+

TagExpr is a tag expression (see ITEM AND COLUMN TAGS) against which +every column's tags are tested for a match. +This keyword cannot be followed by any modifiers unless a single column is +matched. You may run into trouble if tagExpr looks like a column id +or other keyword; also, tagExpr must look like a single list element +since column descriptions are properly-formed lists. To be safe you may want to +use the tag qualifier followed by tagExpr.

+
all QUALIFIERS
+

Indicates every column, including the tail column if the command allows it, +which match QUALIFIERS.

+
first QUALIFIERS
+

Indicates the leftmost column of the treectrl which matches QUALIFIERS.

+
end QUALIFIERS
+
+
last QUALIFIERS
+

Indicates the rightmost column of the treectrl (but not the tail column) +which matches QUALIFIERS.

+
list columnDescs
+

ColumnDescs is a list (a single argument, i.e. "list {a b c}" not "list a b c") +of other column descriptions. +This keyword cannot be followed by any modifiers unless a single column is matched.

+
order n QUALIFIERS
+

Indicates the nth column in the list of columns as returned by the +column order command.

+
range first last QUALIFIERS
+

First and last specify a range of columns. +This keyword cannot be followed by any modifiers unless a single column is specified.

+
tail
+

Indicates the ever-present tail column of the treectrl.

+
tree
+

Indicates the column specified by the -treecolumn option of the treectrl.

+
+

The initial part of the column description (matching any of the values above) +may be followed by one or more modifiers. +A modifier changes the column used relative to +the description up to this point. +It may be specified in any of the following forms:

+
+
next QUALIFIERS
+

Use the column to the right matching QUALIFIERS.

+
prev QUALIFIERS
+

Use the column to the left matching QUALIFIERS.

+
span N QUALIFIERS
+

Starting with (and counting) the single column specified by the column +description so far, walk at most N columns rightwards, stopping if any +of the following conditions is met:

+
    +

  1. A column does not match QUALIFIERS.

    2. +

  2. A column's -lock option does not match the first column's -lock option.

    3. +
+
+

The word QUALIFIERS above represents a sequence of zero or more of the +following terms that changes which column is chosen:

+
+
tag tagExpr
+

TagExpr is a tag expression (see ITEM AND COLUMN TAGS) against which +a column's tags are tested for a match.

+
!tail
+

When this qualifier is given, the tail column is not matched.

+
visible
+

When this qualifier is given, only columns whose -visible option is +TRUE are considered.

+
!visible
+

When this qualifier is given, only columns whose -visible option is +FALSE are considered.

+
+
+

STATES

+

For every column header and every item a set of boolean states is managed. +These states play an integral role in the appearance of headers and items; +that role is described in detail in PER-STATE OPTIONS. +The set of states available to headers is separate from the set of states +available to items.

+
+
HEADER STATES
+

The following states are predefined for every column header:

+
+
active
+
+
normal
+
+
pressed
+

These states mirror the value of a column header's configuration option +-state. Exactly one of these states is set at any time in each +column header.

+
down
+
+
up
+

These states mirror the value of a column header's configuration option +-arrow. If the -arrow option is none, then neither +of these states is set.

+
background
+

This state is set for every header-row if the toplevel window containing the +treectrl is not the foreground active window. This state cannot be modified +by means of a widget command, but is maintained in reaction to the <Activate> +and <Deactivate> windowing system events.

+
focus
+

This state is set for every header-row if the treectrl widget currently has the +focus. It cannot be modified by means of a widget command, but is maintained +in reaction to the <FocusIn> and <FocusOut> windowing system events.

+
+
ITEM STATES
+

The following states are predefined for every item:

+
+
active
+

At all times this state is set for exactly one item. The active item is +used with keyboard navigation. +When the treectrl widget is created or when the active item is deleted, +the root item will become the active item. +This state can be modified by means of the widget command activate.

+
enabled
+

This state is set for every item when it is created. +Disabled items cannot be selected and are ignored by the default bindings +when navigating via the keyboard. +This state can be modified by means of the widget command item enabled.

+
focus
+

This state is set for every item +if the treectrl widget currently has the focus. +It cannot be modified by means of a widget command, +but is maintained in reaction to the <FocusIn> and <FocusOut> events.

+
open
+

If this state is switched on, +the descendants of the item are displayed +- the item is expanded. +If this state is switched off, +the descendants of the item are not displayed +- the item is collapsed. +For a new item this state is switched on by default. +This state can be modified by means of the widget commands +item expand, item collapse, or item toggle.

+
selected
+

This state is set for every item included in the selection. +It can be modified by means of the widget command selection.

+
+

By means of the state define widget command, +up to 27 additional states can be defined.

+
+
+

PER-STATE OPTIONS

+

The visual appearance of an item can change depending on the state the item +is in, such as being the active item, being included in the selection, being +collapsed, or some combination of those or other states. When a configuration +option is described as per-state, it means the option describes a +value which varies depending on the state of the item. If a per-state option is +specified as a single value, the value is used for all states. Otherwise +the per-state option must be specified as an even-numbered list. For example, +to use the font "Times 12 bold" in a text element regardless of the +item state you can write:

+
+$T element configure MyTextElement -font {{Times 12 bold}}
+
+

However, to use a different font when the item is selected you could write:

+
+$T element configure MyTextElement -font {{Courier 10} selected {Times 12 bold} {}}
+
+

In the example above, the -font option reads "value stateList value stateList". +If stateList is an empty list, the preceding value is used regardless +of the item state. A non-empty stateList specifies a list of states which must be +set for the item in order to use the preceding value. Each stateList can also +include state names preceded by a ! sign, indicating the state must *not* be +set for the item. For example:

+
+$T element configure MyRectElement -fill {blue {selected focus} gray {selected !focus}}
+
+

In the example above, the rect element is filled with blue when the treectrl +has the focus and the item is selected. If the treectrl does not have the focus, the +example specifies that gray should be used for selected items. Also note that if the +item is not selected, no color is specified for the -fill option.

+

Each value-stateList pair is checked in order from left to right. The value +associated with the first stateList that matches the current item state is +used. So stateLists should be listed from most-specific to least-specific.

+
+$T element configure MyRectElement -fill {gray {selected} blue {selected focus}}
+
+

Written this way, gray will always be used for selected items since +it appears first, and blue will never be used for selected items regardless +of the focus.

+

A value followed by an empty stateList should always be last since it will be +chosen regardless of the item's state.

+
+

ELEMENTS AND STYLES

+

Elements and styles are the core visual building blocks that +determine the appearance of items (and optionally column headers). +An element can be of type bitmap, border, header, image, +rect, text or window. One or more elements can be +assigned to a style which manages the layout of those elements. It may be +helpful to think of an element as a Tk widget and a style as a Tk geometry +manager such as grid, pack or place.

+

When an element is created by the element create command, that element is +referred to as a master element. Similarly, a style that is created by +style create is called a master style. When a master style is +assigned to a column of an item by the item style set command, a new +instance style is allocated +which refers back to the master style and its master elements. In this way, a +single master style may be shared by multiple columns of multiple items. If a +master element or master style is modified, those changes affect all the items +whose instance styles and elements refer to those masters.

+

Although you probably want the font and selection-rectangle colors to be shared by all items, +you most likely don't want the text to be the same for every column of every +item. The item element configure command can be used to override a +master element's configuration options for a specific column of an item. When you call +item element configure (or item text or item image), a +new instance element is allocated, if one wasn't already, and that instance +element's options will override the master element's.

+

All of the element configuration options described below are unspecified +by default, meaning that no value whatsoever has been given to the option. +It may seem strange to you that a boolean option would be unspecified +instead of simply "true" or "false". The reason for this is that when an +instance element used by an item has no value specified for an option, that +instance element refers to the master element for the value of that option. +This allows items which are displaying a certain element to be redisplayed +when the master element's options change. The benefits of this are that you +don't need to configure the font or text color for every item in a treectrl +individually, saving CPU cycles and memory.

+

You may be thinking that to change the color of a selection rectangle you +would call item element configure when an item was selected, but that +is not usually the case. It would be wasteful to allocate a new instance +element for a selection rectangle just because an item became selected. The +solution is to allow the appearance of the selection rectangle master element +to change based on the selected state of the item. This is described in +PER-STATE OPTIONS.

+

For each element type there is a section below describing the options +which can modify an element of that type.

+
+

BITMAP ELEMENT

+

An element of type bitmap can be used to display a bitmap in an item. +The following options are supported for bitmap elements:

+
+
-background color
+

Specifies as a per-state option +the color to use for each of the bitmap's '0' valued pixels. +If the value for a certain state is an empty string (the default), +the bitmap is drawn transparent.

+
-bitmap bitmap
+

Specifies as a per-state option +the bitmap to display in the element.

+
-draw boolean
+

Deprecated; use the style layout option -draw instead. +Specifies as a per-state option +whether to draw the element. If the value for a certain state is an empty +string (the default), it is treated as true and the element will be drawn.

+
-foreground color
+

Specifies as a per-state option +the color to use for each of the bitmap's '1' valued pixels. +If the value for a certain state is an empty string (the default), +the bitmap's foreground color is black.

+
+
+

BORDER ELEMENT

+

An element of type border can be used to display a 3D border in an item. +The following options are supported for border elements:

+
+
-background color
+

Specifies as a per-state option +the color to use for the background of the border. +If the value for a certain state is an empty string (the default), the +element will not be drawn.

+
-draw boolean
+

Deprecated; use the style layout option -draw instead. +Specifies as a per-state option +whether to draw the element. If the value for a certain state is an empty +string (the default), it is treated as true and the element will be drawn.

+
-filled boolean
+

Specifies whether the interior of the border should be filled with +the background color. If this option is unspecified (the default), +it it treated as false which means that only the edges of the +border will be drawn.

+
-height size
+

Specifies the height of the border. If this value is unspecified +(the default), the border will be exactly as tall as its display area as +determined by the style layout options.

+
-relief relief
+

Specifies as a per-state option the +relief of the border. If the value for a certain state is an empty string +(the default), it is treated as flat. +For acceptable values see the description of the +-relief option in the options manual page.

+
-thickness thickness
+

Specifies the thickness of the edges of the border.

+
-width size
+

Specifies the width of the border. If this value is unspecified +(the default), the border will be exactly as wide as its display area as +determined by the style layout options.

+
+
+

HEADER ELEMENT

+

An element of type header can be used to display a themed (or +non-themed) column header background and sort arrow. Header elements are +best used surrounding other elements via the style layout option -union, +so that the sort arrow can be displayed correctly.

+

Some of the options for this type of element get their default values from +the header state flags that are set in the column header in which +the element is displayed. In particular, the -arrow option gets its +default value by checking the up and down state flags, and +the -state option gets its default value by checking the active, +normal, and pressed state flags. If elements of this type are +displayed in an item instead of a column header, then this behavior isn't used +since those state flags aren't meaningful for items.

+

The following options are supported for header elements:

+
+
-arrow direction
+

Indicates whether or not a sort arrow should be drawn. Direction must +have one of the values none, up, or down. If +unspecified, the value defaults to none (but see the note above +regarding header states).

+
-arrowbitmap bitmap
+

Specifies as a per-state option the name of a +bitmap to use to draw the sort arrow if this element's -arrow option is not +none. +This option is ignored when drawing themed headers on Mac OS X.

+
-arrowgravity direction
+

Indicates onto which side the sort arrow should be packed, +if there is more space available for drawing the arrow than needed. +Direction must be either left or right. If unspecified, +the value defaults to left. +This option is ignored when drawing themed headers on Mac OS X.

+
-arrowimage image
+

Specifies as a per-state option the name of an +image to use to draw the sort arrow if this element's -arrow option is not +none. If an image is specified for a certain state, it overrides the +-arrowbitmap option. +This option is ignored when drawing themed headers on Mac OS X.

+
-arrowpadx amount
+

Amount specifies how much padding to leave on the left and right of the +sort arrow. Amount may be a list of two values to specify padding for +the left and right separately. If unspecified, the value defaults to 6. +Padding to the right of the sort arrow is ignored when drawing themed headers +on Mac OS X.

+
-arrowpady amount
+

Amount specifies how much padding to leave on the top and bottom of the +sort arrow. Amount may be a list of two values to specify padding for +the top and bottom separately. If unspecified, the value defaults to 0. +This option is ignored when drawing themed headers on Mac OS X.

+
-arrowside side
+

Indicates on which side of the element the sort arrow should be drawn. +Side must be either left or right. If unspecified, the +value defaults to right.

+
-background color
+

Specifies as a per-state option the color to +use for the non-themed background and 3D border. If unspecified, the value +defaults to either the Tk button widget's -background or -activebackground +color.

+
-borderwidth size
+

Specifies a non-negative value indicating the width of the non-themed 3D +border to draw around the inner edges of the element (if such a border is being +drawn; the -relief option determines this). +The value may have any of the forms acceptable to Tk_GetPixels. +If unspecified, the value defaults to 2.

+
-state state
+

Specifies one of three states for the element: normal, active, +or pressed. The active state is used when the mouse is over the header. +The pressed state is used when the mouse button is pressed in the header. +If unspecified, the value defaults to normal (but see the note above +regarding header states).

+
+
+

IMAGE ELEMENT

+

An element of type image can be used to display an image in an item. +The following options are supported for image elements:

+
+
-draw boolean
+

Deprecated; use the style layout option -draw instead. +Specifies as a per-state option +whether to draw the element. If the value for a certain state is an empty +string (the default), it is treated as true and the element will be drawn.

+
-height size
+

Specifies the requested height of the display area for this element. +If unspecified (the default), the element requests a height equal to the +height of the image, or zero if there is no image.

+
-image image
+

Specifies as a per-state option +the image to display in the element.

+
-tiled boolean
+

Specifies a boolean indicating whether or not the image should be tiled +horizontally and vertically within the display area for the element. +The default is false.

+
-width size
+

Specifies the requested width of the display area for this element. +If unspecified (the default), the element requests a width equal to the +width of the image, or zero if there is no image.

+
+
+

RECTANGLE ELEMENT

+

An element of type rect can be used to display a rectangle in an item. +The following options are supported for rectangle elements:

+
+
-draw boolean
+

Deprecated; use the style layout option -draw instead. +Specifies as a per-state option +whether to draw the element. If the value for a certain state is an empty +string (the default), it is treated as true and the element will be drawn.

+
-fill color
+

Specifies as a per-state option the color to +be used to fill the rectangle's area. +If the color for a certain state is an empty string (the default), then +the rectangle will not be filled (but the outline may still be drawn).

+
-height size
+

Specifies the height of the rectangle. If this value is unspecified +(the default), the rectangle will be exactly as tall as its display area as +determined by the style layout options.

+
-open open
+

Specifies as a per-state option +which edges of the rectangle should be left open. +This option may be used to get an incomplete drawing of the outline and rounded +corners, often to give the appearance of the rectangle extending over adjacent +columns or items. +Open is a string that contains zero or more of the characters +n, s, e or w. +Each letter refers to an edge (north, south, east, or west) on which the outline +and rounded corners will not be drawn. +The default is the empty string, which causes all rounded corners and the outline +to be drawn.

+
-outline color
+

Specifies as a per-state option the color to +be used to draw the outline of the rectangle. +If the color for a certain state is an empty string (the default), +then no outline is drawn for the rectangle.

+
-outlinewidth outlineWidth
+

Specifies the width of the outline to be drawn around the rectangle's region. +outlineWidth may be in any of the forms acceptable to Tk_GetPixels. +If this option is specified as an empty string (the default), then no outline +is drawn.

+
-rx radius
+
+
-ry radius
+

Specifies the x and y radius of each corner of a rounded rectangle +in any of the forms acceptable to Tk_GetPixels.

+
-showfocus boolean
+

Specifies a boolean value indicating whether +a "focus ring" should be drawn around the rectangle, +if the item containing the rectangle is the active item +and the treectrl widget currently has the focus. +If this option is specified as an empty string (the default), +then a focus rectangle is not drawn.

+
-width size
+

Specifies the width of the rectangle. If this value is unspecified +(the default), the rectangle will be exactly as wide as its display area as +determined by the style layout options.

+
+
+

TEXT ELEMENT

+

An element of type text can be used to display a text in an item. +The following options are supported for text elements:

+
+
-draw boolean
+

Deprecated; use the style layout option -draw instead. +Specifies as a per-state option +whether to draw the element. If the value for a certain state is an empty +string (the default), it is treated as true and the element will be drawn.

+
-data data
+

Specifies a value that together with the -datatype and -format +options will be displayed as text.

+
-datatype dataType
+

Specifies the type of information in the -data option. +Acceptable values are double, integer, long, +string, or time.

+
-elidepos position
+

Position specifies where to elide long lines of text. +Position must be one of start, middle or end. +When the width of the text displayed by this element is greater than the +display-width of the element, a portion of the text is replaced with "...". +This option has no effect on multi-line text, which is always elided at the end. +If this option is unspecified (the default), end is used. +See the -width option for a description of how the maximum line +length is determined.

+
-fill color
+

Specifies as a per-state option the +foreground color to use when displaying text.

+

In items, if the color for a certain state is an empty string (the default), +then the text will be displayed using the color specified by the treectrl's +-foreground option.

+

In headers, if the color for a certain state is an empty string, +then the text will be displayed using the system theme color on Gtk+; if that +color is not specified then the -headerforeground option is used.

+
-font font
+

Specifies as a per-state option the font to +use when displaying the text. +If the font for a certain state is an empty string, the text is displayed +using the font specified by the treectrl's -font option in items +or the -headerfont option in headers.

+
-format formatString
+

This option specifies the format string used to display the value of the -data option. +If -datatype is time, formatString should be +a valid format string for the Tcl clock command. +For all other -datatype values formatString should be +a valid format string for the Tcl format command. +If this value is unspecified the following defaults are used: +for -datatype double "%g", for -datatype integer "%d", for -datatype long "%ld", +for -datatype string "%s", and for -datatype time the default format string of the Tcl clock +command.

+
-justify how
+

Specifies how to justify the text when multiple lines are displayed. +How must be one of the values left, right, or center. +If this option is specified as an empty string (the default), left is used.

+
-lines lineCount
+

Specifies the maximum number of lines to display. +If more than lineCount lines would be displayed, the last line will +be truncated with an ellipsis at the right. +If this option is specified as zero or an empty string (the default), +there is no limit to the number of lines displayed.

+
-lmargin1 pixels
+

Pixels is a screen distance that specifies how much a line of text should be +indented. If a line of text wraps, this option only applies to the first line +on the display; the -lmargin2 option controls the indentation for +subsequent lines. +If this option is specified as zero or an empty string (the default), +then the line is not indented. +This option was based on the Tk Text widget tag option of the same name.

+
-lmargin2 pixels
+

Pixels is a screen distance that specifies how much a line of text should be +indented. If a line of text wraps, this option only applies to the second and +later display lines for a line of text. +If this option is specified as zero or an empty string (the default), +then the line is not indented. +This option was based on the Tk Text widget tag option of the same name.

+
-text string
+

String specifies a string to be displayed by the element. +String may contain newline characters in which case multiple lines of text +will be displayed. +If this option is specified, the -data, -datatype, +-format, and -textvariable options are ignored.

+
-textvariable varName
+

Specifies the name of a variable. The value of the variable is a string +to be displayed by the element; if the variable value changes then the element +will automatically update itself to display the new value. +If this option is specified, the -data, -datatype, +and -format options are ignored.

+
-underline charIndex
+

Specifies the integer index of a character to underline. +0 corresponds to the first character. +If charIndex is unspecified (the default), less than zero or greater +than the index of the last displayed character, the underline is not drawn.

+
-width size
+

Specifies the maximum line length in any of the forms acceptable to Tk_GetPixels. +For text to wrap lines the value of the -width +option must be less than the needed width of the text, or the display area +for this element must be less than the needed width of the text. +For the display area to be less than the needed width of the text, +one of the style layout options -maxwidth, -width or +-squeeze must be used.

+
-wrap mode
+

Mode specifies how to handle lines in the text that are longer than the +maximum line length. +Acceptable values are none, char or word. +If this option is unspecified (the default), word is used. +See the -width option for a description of how the maximum line +length is determined.

+
+
+

WINDOW ELEMENT

+

An element of type window can be used to display a Tk window in an item. +The following options are supported for window elements:

+
+
-clip boolean
+

Specifies whether the associated Tk window is a borderless frame which should +be used to clip its child window so it doesn't overlap the header, borders, or +other items or columns. When this option is true, the treectrl manages the +geometry of both the -window widget and its first child widget; in +this case the -window widget (which should be a borderless frame) is +kept sized and positioned so that it is never out-of-bounds.

+
-destroy boolean
+

Specifies whether the associated Tk window should be destroyed when the +element is deleted. The element is deleted when the item containing the +element is deleted, when the column containing the element is deleted, +or when the style assigned to the item's column is changed. If this option +is unspecified (the default), it is treated as false and the Tk window +will not be destroyed.

+
-draw boolean
+

Deprecated; use the style layout option -draw instead. +Specifies as a per-state option +whether to draw the element. If the value for a certain state is an empty +string (the default), it is treated as true and the element will be drawn.

+
-window pathName
+

Specifies the window to associate with this element. The window specified by +pathName must either be a child of the treectrl widget or a child of +some ancestor of the treectrl widget. PathName may not refer to a +top-level window. This option cannot be specified by +the element create or element configure commands, only by the +item element configure command; i.e., the element must be associated +with a particular item.

+
+
+

ITEM DESCRIPTION

+

Many of the commands for a treectrl take as an argument a +description of which items to operate on. An item description is a properly-formed +tcl list of keywords and arguments. +The first word of an item description must be one of the following:

+
+
id
+

Specifies the unique item identifier, where id should be +the return value of a prior call of the item create widget command, +or 0 to specify the ever-present root item. See also the +-itemprefix option.

+
QUALIFIERS
+

Specifies a list of qualifiers. This gives the same result as all followed +by QUALIFIERS; i.e., every item is tested for a match.

+
tagExpr QUALIFIERS
+

TagExpr is a tag expression (see ITEM AND COLUMN TAGS) against which +every item's tags are tested for a match. +This keyword cannot be followed by any modifiers unless a single item is +matched. You may run into trouble if tagExpr looks like an item id +or other keyword; also, tagExpr must look like a single list element +since item descriptions are properly-formed lists. To be safe you may want to +use the tag qualifier followed by tagExpr.

+
active
+

Indicates the item that is currently active, i.e. normally +the item specified as argument of the last successful activate +widget command, or the root item if no such call happened yet.

+
anchor
+

Indicates the anchor item of the selection, i.e. normally +the item specified as argument of the last successful selection anchor +widget command, or the root item if no such call happened yet.

+
all QUALIFIERS
+

Indicates every item including orphans which match QUALIFIERS. +This keyword cannot be followed by any modifiers unless a single item is matched.

+
first QUALIFIERS
+

Indicates the first item of the treectrl (the root item), +or the first item matching QUALIFIERS.

+
end QUALIFIERS
+
+
last QUALIFIERS
+

Indicates the last item which matches QUALIFIERS.

+
list itemDescs
+

ItemDescs is a list (a single argument, i.e. "list {a b c}" not "list a b c") +of other item descriptions. +This keyword cannot be followed by any modifiers unless a single item is matched.

+
nearest x y
+

Indicates the item nearest to the point given by x and y.

+
rnc row column
+

Indicates the item in the given row and column. +The row and column corresponds to +the on-screen arrangement of items as determined by the -orient and -wrap +options. +You can memorize rnc as an abbreviation of "row 'n' column".

+
range first last QUALIFIERS
+

First and last specify a range of items. +This keyword cannot be followed by any modifiers unless a single item is matched.

+
root
+

Indicates the root item of the treectrl.

+
+

The initial part of the item description (matching any of the values above) +may be followed by one or more modifiers. +A modifier changes the item used relative to +the description up to this point. +It may be specified in any of the following forms:

+
+
above
+

Use the item one row above in this column.

+
ancestors QUALIFIERS
+

Use the ancestors of the item (like item ancestors but QUALIFIERS +may change which ancestors match). +This keyword cannot be followed by any modifiers.

+
below
+

Use the item one row below in this column.

+
bottom
+

Use the item in the last row of this column.

+
child n QUALIFIERS
+

Use the nth child of the item.

+
children QUALIFIERS
+

Use the children of the item (like item children but QUALIFIERS +may change which children match). +This keyword cannot be followed by any modifiers.

+
descendants QUALIFIERS
+

Use the descendants of the item (like item descendants but QUALIFIERS +may change which descendants match). +This keyword cannot be followed by any modifiers.

+
firstchild QUALIFIERS
+

Use the first child of the item.

+
lastchild QUALIFIERS
+

Use the last child of the item.

+
left
+

Use the item one column to the left in the same row.

+
leftmost
+

Use the item of the first column in the same row.

+
next QUALIFIERS
+

Use the next item, which is the first item from the +following list: the first child, the next sibling or the next sibling of +the nearest ancestor which has one.

+
nextsibling QUALIFIERS
+

Use the next sibling of the item.

+
parent
+

Use the parent of the item.

+
prev QUALIFIERS
+

Use the last child of the previous sibling, +or the parent if there is no previous sibling.

+
prevsibling QUALIFIERS
+

Use the previous sibling of the item.

+
right
+

Use the item one column to the right in the same row.

+
rightmost
+

Use the item of the last column in the same row.

+
sibling n QUALIFIERS
+

Use the nth child of the item's parent.

+
top
+

Use the item in the first row of this column.

+
+

The word QUALIFIERS above represents a series of zero or more of the +following terms that changes which item is chosen:

+
+
depth depth
+

Matches items whose depth (as returned by the depth command) is equal to +depth.

+
state stateList
+

StateList is a list of item state names (static and dynamic, see STATES). +Only items that have the given states set (or unset if the '!' prefix is used) +are considered.

+
tag tagExpr
+

TagExpr is a tag expression (see ITEM AND COLUMN TAGS) against which +an item's tags are tested for a match.

+
visible
+

When this qualifier is given, only items that are displayed are considered.

+
!visible
+

When this qualifier is given, only items that are *not* displayed are considered.

+
+

To get the first item in the list that is enabled:

+
+$T item id "first state enabled"
+
+

To get the ancestors that are not open of the last item in the list:

+
+$T item id "last ancestors state !open"
+
+

To get the visible descendants of the root item:

+
+$T item id "root descendants visible"
+
+

To get the every hidden item with tag "a" or "b":

+
+$T item id "all !visible tag a||b"
+$T item id "!visible tag a||b"
+$T item id "tag a||b !visible"
+$T item id "a||b !visible"
+
+
+

EVENTS AND SCRIPT SUBSTITUTIONS

+

The script argument to notify bind is a Tcl script, which will be +evaluated whenever the given event is generated. Script will be executed +in the same interpreter that the notify bind command was executed in, +and it will run at global level (only global variables will be accessible). +If script contains any % characters, then the script will not be +evaluated directly. Instead, a new script will be generated by replacing each +%, and the character following it, with information from the current +event. Unlike the regular Tk bind mechanism, each event generated by +a treectrl widget has its own set of %-substitutions.

+

The following %-substitutions are valid for all static events:

+
+
%%
+

Replaced with a single %

+
%d
+

The detail name

+
%e
+

The event name

+
%P
+

The pattern, either <event> or <event-detail>

+
%W
+

The object argument to the notify bind command

+
%T
+

The treectrl widget which generated the event

+
%?
+

A list of the format {char value char value ...} for each +%-substitution character and the value it is replaced by

+
+

The following events may be generated by a treectrl widget:

+
+
<ActiveItem>
+

Generated whenever the active item changes.

+
+
%c
+

The current active item

+
%p
+

The previous active item

+
+
<Collapse-before>
+

Generated before an item is collapsed.

+
+
%I
+

The item id

+
+
<Collapse-after>
+

Generated after an item is collapsed.

+
+
%I
+

The item id

+
+
<Expand-before>
+

Generated before an item is expanded. This event is useful if you want to add +child items to the item just before the item is expanded.

+
+
%I
+

The item id

+
+
<Expand-after>
+

Generated after an item is expanded.

+
+
%I
+

The item id

+
+
<ItemDelete>
+

Generated when items are about to be deleted by the item delete command.

+
+
%i
+

List of items ids being deleted.

+
+
<ItemVisibility>
+

Generated when items become visible on screen and when items are no longer visible on screen. +This event is useful if you have a very large number of items and want to assign +styles only when items are actually going to be displayed.

+
+
%h
+

List of items ids which are no longer visible.

+
%v
+

List of items ids which are now visible.

+
+
<Scroll-x>
+

Generated whenever the view in the treectrl changes in such a way that a +horizontal scrollbar should be redisplayed.

+
+
%l
+

Same as the first fraction appended to -xscrollcommand. Think lower.

+
%u
+

Same as the second fraction appended to -xscrollcommand. Think upper.

+
+
<Scroll-y>
+

Generated whenever the view in the treectrl changes in such a way that a +vertical scrollbar should be redisplayed.

+
+
%l
+

Same as the first fraction appended to -yscrollcommand. Think lower.

+
%u
+

Same as the second fraction appended to -yscrollcommand. Think upper.

+
+
<Selection>
+

Generated whenever the selection changes. This event gives information about +how the selection changed.

+
+
%c
+

Same as the selection count widget command

+
%D
+

List of newly-deselected item ids

+
%S
+

List of newly-selected item ids

+
+
+
+

DYNAMIC EVENTS

+

In addition to the pre-defined static events such as <ActiveItem> +and <Selection>, new dynamic events can be created by using the +notify install command.

+

The library scripts provide an example +of using a dynamic event called <Header-invoke>, which is generated when +the mouse button is clicked and released over a column header.

+
+# Example application code
+treectrl .t
+.t notify install <Header-invoke>
+.t notify bind MyTag <Header-invoke> {
+	puts "column header %C clicked in header-row %H in treectrl %T"
+}
+# Library code in treectrl.tcl
+proc ::TreeCtrl::Release1 {w x y} {
+	...
+	$w notify generate <Header-invoke> [list H $Priv(header) C $Priv(column)] \
+		[list ::TreeCtrl::PercentsCmd $w]
+	...
+}
+
+

In the example above, a new treectrl widget is created and the <Header-invoke> +event is installed. A script is bound to the event with notify bind +which will print out the column ID, header ID and widget name to the console. +In a real application, any script bound to <Header-invoke> would be used to +sort the list based on the column header that was clicked.

+

Note there is no percentsCommand argument to notify install; +instead, the call to notify generate specifies the %-substitution +command. +The charMap argument to notify generate +provides a list of %-substitution characters and values which is used by +::TreeCtrl::PercentsCmd. In the example, any %C in any script bound to the +<Header-invoke> event would be replaced by the value of $Priv(column), and +%H would be replaced by $Priv(header). The library procedure +::TreeCtrl::PercentsCmd also supports the same common %-substitution +characters as the built-in static events, such as %T, %P, %? etc.

+

The following dynamic events may be generated by the library scripts:

+
+
<ColumnDrag-begin>
+

This event is generated just after the user begins dragging a column header. +At the time this event is generated, the header dragconfigure option +-imagecolumn is set to the unique ID of the column being dragged, the +-imageoffset option is set to the horizontal distance the mouse +pointer has moved, and the -imagespan option is set to the span of +the column header that was initially clicked.

+
<ColumnDrag-indicator>
+

This event is generated each time a new place to drop the dragged +column header is found. At the time this event is generated, the +header dragconfigure option -indicatorcolumn is set to the +unique ID of the column before or after which the dragged column will be +dropped, and the -indicatorspan option is set to the span of the +column header for this newly-chosen indicator column.

+
<ColumnDrag-receive>
+

This event is generated when the user has successfully dragged and dropped a +column header to a new position. The library scripts do not actually move the +dragged column. You must bind a script to this event to move the column. +See EXAMPLES.

+
<ColumnDrag-end>
+

This event is generated after the user finally releases the left mouse button +while dragging a column header. This event is generated after all the other +<ColumnDrag> events even when the column wasn't dragged to a new location +(i.e., even when no <ColumnDrag-receive> event was generated).

+
+
%H
+

The header-row that contains the column header.

+
%C
+

The column whose header is dragged within the header-row.

+
%b
+

The column to move the dragged column(s) before. Valid for +<ColumnDrag-receive> only.

+
+
<Drag-begin>
+
+
<Drag-receive>
+
+
<Drag-end>
+

Generated whenever the user drag-and-drops a file into a directory. This +event is generated by the filelist-bindings.tcl library code, which is not +used by default. See the "Explorer" demos.

+
+
%I
+

The item that the user dropped the dragged items on.

+
%l
+

(lowercase L) The list of dragged items.

+
+
<Edit-begin>
+
+
<Edit-accept>
+
+
<Edit-end>
+

The filelist-bindings.tcl code will display a text-editing window if the user +clicks on a selected file/folder name. See the "Explorer" demos.

+
+
%I
+

The item containing the edited text element.

+
%C
+

The column containing the edited text element.

+
%E
+

The name of the edited text element.

+
%t
+

The edited text.

+
+
<Header-invoke>
+

Generated whenever the user clicks and releases the left mouse button +in a column header if the column header's -button option is true. You can bind a +script to this event to sort the list.

+
+
%H
+

The header-row that contains the column header.

+
%C
+

The column whose header was clicked.

+
+
<Header-state>
+

Generated when the column header option -state is changed by the +library scripts during Motion and Button events.

+
+
%H
+

The header-row that displays the column header.

+
%C
+

The column within the header-row whose header option -state changed.

+
%s
+

The new value of the column header option -state.

+
+
+
+

DEFAULT BINDINGS

+

Tk automatically creates class bindings for treectrl widgets that give them +the following default behavior.

+
    +

  1. Clicking mouse button 1 over an item positions the active cursor +on the item, sets the input focus to this widget, +and resets the selection of the widget to this item, if it is not +already in the selection.

    2. +

  2. Clicking mouse button 1 with the Control key down will reposition the +active cursor and add the item to the selection +without ever removing any items from the selection.

    3. +

  3. If the mouse is dragged out of the widget +while button 1 is pressed, the treectrl will automatically scroll to +make more items visible (if there are more items off-screen on the side +where the mouse left the window).

    4. +

  4. The Left and Right keys move the active cursor one item to the left or right; +for an hierarchical tree with vertical orientation nothing will happen, +since it has no two items in the same row. +The selection is set to include only the active item. +If Left or Right is typed with the Shift key down, then the active +cursor moves and the selection is extended to include the new item.

    5. +

  5. The Up and Down keys move the active cursor one item up or down. +The selection is set to include only the active item. +If Up or Down is typed with the Shift key down, then the active +cursor moves and the selection is extended to include the new item.

    6. +

  6. The Next and Prior keys move the active cursor forward or backwards +by one screenful, without affecting the selection.

    7. +

  7. Control-Next and Control-Prior scroll the view right or left by one page +without moving the active cursor or affecting the selection. +Control-Left and Control-Right behave the same.

    8. +

  8. The Home and End keys scroll to the left or right end of the widget +without moving the active cursor or affecting the selection.

    9. +

  9. The Control-Home and Control-End keys scroll to the top or bottom +of the widget, they also activate and select the first or last item. +If also the Shift key is down, then the active +cursor moves and the selection is extended to include the new item.

    10. +

  10. The Space and Select keys set the selection to the active item.

    11. +

  11. Control-/ selects the entire contents of the widget.

    12. +

  12. Control-\\ clears any selection in the widget.

    13. +

  13. The + and - keys expand or collapse the active item, +the Return key toggles the active item.

    14. +

  14. The mousewheel scrolls the view of the widget four lines up or down +depending on the direction, the wheel was turned. +The active cursor or the selection is not affected.

    15. +
+
+

GRADIENTS

+

Color gradients are an easy way to give your lists a more modern appearance. +Since Tk provides no support for drawing gradients, the TkPath extension was +used as a guide when implementing gradients in TkTreeCtrl. The current +implementation has some limitations, however:

+
    +

  1. Only linear gradients are supported.

    2. +

  2. Gradients can only be painted left-to-right or top-to-bottom, not at +arbitrary angles.

    3. +

  3. Gradients look bad on low-color displays. Before using gradients, you should +check that the display's color depth is at least 15 or 16 by calling the +winfo depth command.

    4. +

  4. Gradients are fully opaque when XFillRectangle() is used to draw them (see below). +This means the opacity value of each color stop is ignored. Keep that +in mind if your application is cross-platform.

    5. +

  5. Rounded rectangles cannot be filled or outlined with a gradient when XFillRectangle() +is used to draw gradients (see below). Instead, the rounded rectangle is painted +with the gradient's first -stops color.

    6. +
+

Gradients may be used in the following places:

+
    +

  1. The -gridleftcolor and -gridrightcolor options of columns.

    2. +

  2. The -itembackground option of columns.

    3. +

  3. The -fill and -outline options of rect elements.

    4. +

  4. The -fill and -outline options of the marquee configure command.

    5. +
+

On Microsoft Windows, GDI+ is used where it is available (gdiplus.dll is +dynamically loaded at run-time). +On Mac OS X, CoreGraphics is used to draw gradients. +With the Gtk+ build of treectrl, libcairo is used to draw gradients. +When native gradient support is available, all the talk below +about -steps can safely be ignored.

+

When no native support for gradients is available, gradients +are drawn simply by filling sub-rectangles using XFillRectangle(). The number +of sub-rectangles drawn and number of colors that make up the displayed gradient +are controlled by the gradient's -steps and -stops options. +The number of sub-rectangles is equal to the length of the -stops +option multiplied by the value of the -steps option. For example:

+
+$T gradient create myGradient -stops {{0 white} {1 gray}} -steps 8
+
+

This gradient will be drawn with 2x8=16 sub-rectangles of color. +The higher the -steps value, the smoother the color transitions +will be, and the slower the gradient will be to draw. +For the best appearance, make the number of sub-rectangles drawn less than or equal +to the height or width of the gradient being drawn. So if you have a rect element +18 pixels tall, use a vertical gradient that has steps X stops=18. Avoid using +gradients with steps X stops greater than the height or width of the rectangle +being drawn, because then colors will overlap.

+
+

GRADIENT COORDINATES

+

By default, a gradient brush is exactly the same size as whatever rectangle +is being painted. For example, if a column's -itembackground option +specifies a gradient name, then the background of an item is painted with all +the colors of the gradient. So a vertical gradient from blue to green will +start blue at the top and end with green at the bottom of every item.

+

By specifying any of the -bottom, -left, -right or +-top gradient options the size of the gradient brush does not need +to match that of the rectangle being painted. These options can be used to +make a gradient appear to span across the entire width or height of the treectrl +window, or across the entire canvas, for example.

+

There is no point specifying -left or -right if the gradient +is vertical, since the gradient's colors are constant horizontally, so changing +the horizontal size of the brush won't change the appearance of the gradient. +The same reasoning applies for the -top and -bottom options +for a horizontal gradient.

+
+package require treectrl
+set T [treectrl .t -itemheight 20 -showheader no]
+$T gradient create G1 -orient vertical -top {0.0 canvas} -bottom {1.0 canvas} \
+	-stops {{0.0 blue} {0.5 green} {1.0 red}} -steps 25
+$T column create -expand yes -itembackground G1
+pack $T -expand yes -fill both
+
+
+

EXAMPLES

+

Get the unique identifier for the leftmost visible column:

+
+set id [$T column index "first visible"]
+
+

Delete the leftmost column:

+
+$T column delete "order 0"
+
+

Take the visible column that is to the left of the last column, and move that +column in front of the tail column:

+
+$T column move "last prev visible" tail
+
+

Get the unique identifier for the first visible item:

+
+set id [$T item index "first visible"]
+
+

Delete the parent of the item that is under the point x,y:

+
+$T item delete "nearest $x $y parent"
+
+

Add the 10th child of the second child of the root item to the selection:

+
+$T selection add "root firstchild nextsibling child 10"
+
+

Move a column that the user drag-and-dropped:

+
+$T header dragconfigure -enable yes
+$T notify install <ColumnDrag-receive>
+$T notify bind MyTag <ColumnDrag-receive> {
+	%T column move %C %b
+}
+
+
+

See Also

+

bind(n), bitmap(n), image(n), listbox(n), options(n)

+
+

Keywords

+

tree, widget

+
+
diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/treectrl2.5.1/treectrl.tcl b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/treectrl.tcl similarity index 96% rename from src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/treectrl2.5.1/treectrl.tcl rename to src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/treectrl.tcl index 6a30cca7..bb93e19c 100644 --- a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/treectrl2.5.1/treectrl.tcl +++ b/src/vfs/punk9win.vfs/lib_tcl9/treectrl2.5.2/treectrl.tcl @@ -1,1978 +1,1978 @@ -# Copyright (c) 2002-2011 Tim Baker - -bind TreeCtrl { - TreeCtrl::CursorCheck %W %x %y - TreeCtrl::MotionInHeader %W %x %y - TreeCtrl::MotionInButtons %W %x %y -} -bind TreeCtrl { - TreeCtrl::CursorCancel %W - TreeCtrl::MotionInHeader %W - TreeCtrl::MotionInButtons %W -} -bind TreeCtrl { - TreeCtrl::ButtonPress1 %W %x %y -} -bind TreeCtrl { - TreeCtrl::DoubleButton1 %W %x %y -} -bind TreeCtrl { - TreeCtrl::Motion1 %W %x %y -} -bind TreeCtrl { - TreeCtrl::Release1 %W %x %y -} -bind TreeCtrl { - set TreeCtrl::Priv(buttonMode) normal - TreeCtrl::BeginExtend %W [%W item id {nearest %x %y}] -} -# Command-click should provide a discontinuous selection on OSX -switch -- [tk windowingsystem] { - "aqua" { set modifier Command } - default { set modifier Control } -} -bind TreeCtrl <$modifier-ButtonPress-1> { - set TreeCtrl::Priv(buttonMode) normal - TreeCtrl::BeginToggle %W [%W item id {nearest %x %y}] -} -bind TreeCtrl { - TreeCtrl::Leave1 %W %x %y -} -bind TreeCtrl { - TreeCtrl::Enter1 %W %x %y -} - -bind TreeCtrl { - TreeCtrl::SetActiveItem %W [TreeCtrl::UpDown %W active -1] -} -bind TreeCtrl { - TreeCtrl::Extend %W above -} -bind TreeCtrl { - TreeCtrl::SetActiveItem %W [TreeCtrl::UpDown %W active 1] -} -bind TreeCtrl { - TreeCtrl::Extend %W below -} -bind TreeCtrl { - if {![TreeCtrl::Has2DLayout %W]} { - %W item collapse [%W item id active] - } else { - TreeCtrl::SetActiveItem %W [TreeCtrl::LeftRight %W active -1] - } -} -bind TreeCtrl { - TreeCtrl::Extend %W left -} -bind TreeCtrl { - %W xview scroll -1 pages -} -bind TreeCtrl { - if {![TreeCtrl::Has2DLayout %W]} { - %W item expand [%W item id active] - } else { - TreeCtrl::SetActiveItem %W [TreeCtrl::LeftRight %W active 1] - } -} -bind TreeCtrl { - TreeCtrl::Extend %W right -} -bind TreeCtrl { - %W xview scroll 1 pages -} -bind TreeCtrl { - %W yview scroll -1 pages - if {[%W item id {nearest 0 0}] ne ""} { - %W activate {nearest 0 0} - } -} -bind TreeCtrl { - %W yview scroll 1 pages - if {[%W item id {nearest 0 0}] ne ""} { - %W activate {nearest 0 0} - } -} -bind TreeCtrl { - %W xview scroll -1 pages -} -bind TreeCtrl { - %W xview scroll 1 pages -} -bind TreeCtrl { - %W xview moveto 0 -} -bind TreeCtrl { - %W xview moveto 1 -} -bind TreeCtrl { - TreeCtrl::SetActiveItem %W [%W item id {first visible state enabled}] -} -bind TreeCtrl { - TreeCtrl::DataExtend %W [%W item id {first visible state enabled}] -} -bind TreeCtrl { - TreeCtrl::SetActiveItem %W [%W item id {last visible state enabled}] -} -bind TreeCtrl { - TreeCtrl::DataExtend %W [%W item id {last visible state enabled}] -} -bind TreeCtrl <> { - if {[string equal [selection own -displayof %W] "%W"]} { - clipboard clear -displayof %W - clipboard append -displayof %W [selection get -displayof %W] - } -} -bind TreeCtrl { - TreeCtrl::BeginSelect %W [%W item id active] -} -bind TreeCtrl { - TreeCtrl::BeginSelect %W [%W item id active] -} -bind TreeCtrl { - TreeCtrl::BeginExtend %W [%W item id active] -} -bind TreeCtrl { - TreeCtrl::BeginExtend %W [%W item id active] -} -bind TreeCtrl { - TreeCtrl::Cancel %W -} -bind TreeCtrl { - TreeCtrl::SelectAll %W -} -bind TreeCtrl { - if {[string compare [%W cget -selectmode] "browse"]} { - %W selection clear - } -} - -bind TreeCtrl { - %W item expand [%W item id active] -} -bind TreeCtrl { - %W item collapse [%W item id active] -} -bind TreeCtrl { - %W item toggle [%W item id active] -} - - -# Additional Tk bindings that aren't part of the Motif look and feel: - -bind TreeCtrl { - focus %W - TreeCtrl::ScanMark %W %x %y -} -bind TreeCtrl { - TreeCtrl::ScanDrag %W %x %y -} - -if {$tcl_platform(platform) eq "windows"} { - bind TreeCtrl { - TreeCtrl::ScanMark %W %x %y - } - bind TreeCtrl { - TreeCtrl::ScanDrag %W %x %y - } -} -if {[string equal [tk windowingsystem] "aqua"]} { - # Middle mouse on Mac OSX - bind TreeCtrl { - TreeCtrl::ScanMark %W %x %y - } - bind TreeCtrl { - TreeCtrl::ScanDrag %W %x %y - } -} - -# MouseWheel -if {[string equal "x11" [tk windowingsystem]]} { - # Support for mousewheels on Linux/Unix commonly comes through mapping - # the wheel to the extended buttons. If you have a mousewheel, find - # Linux configuration info at: - # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ - - # with recent Tk, use the binding of ttk::treeview - bind TreeCtrl [bind Treeview ] - bind TreeCtrl [bind Treeview ] - - bind TreeCtrl <4> { - if {!$tk_strictMotif} { - %W yview scroll -5 units - } - } - bind TreeCtrl { - if {!$tk_strictMotif} { - %W xview scroll -5 units - } - } - bind TreeCtrl <5> { - if {!$tk_strictMotif} { - %W yview scroll 5 units - } - } - bind TreeCtrl { - if {!$tk_strictMotif} { - %W xview scroll 5 units - } - } -} elseif {[string equal [tk windowingsystem] "aqua"]} { - bind TreeCtrl { - %W yview scroll [expr {- (%D)}] units - } - bind TreeCtrl { - %W yview scroll [expr {-10 * (%D)}] units - } - bind TreeCtrl { - %W xview scroll [expr {- (%D)}] units - } - bind TreeCtrl { - %W xview scroll [expr {-10 * (%D)}] units - } -} else { - bind TreeCtrl { - %W yview scroll [expr {- (%D / 120) * 4}] units - } - bind TreeCtrl { - %W xview scroll [expr {- (%D / 120) * 4}] units - } -} - -namespace eval ::TreeCtrl { - variable Priv - array set Priv { - prev {} - } - - if {[info procs ::lassign] eq ""} { - proc lassign {values args} { - uplevel 1 [list foreach $args [linsert $values end {}] break] - lrange $values [llength $args] end - } - } -} - -# Retrieve filelist bindings from this dir -source [file join [file dirname [info script]] filelist-bindings.tcl] - -# ::TreeCtrl::ColumnCanResizeLeft -- -# -# Return 1 if the given column should be resized by the left edge. -# -# Arguments: -# w The treectrl widget. -# column The column. - -proc ::TreeCtrl::ColumnCanResizeLeft {w column} { - if {[$w column cget $column -lock] eq "right"} { - return 1 - } - return 0 -} - -# ::TreeCtrl::ColumnCanMoveHere -- -# -# Return 1 if the given column can be moved before another. -# -# Arguments: -# w The treectrl widget. -# column The column. -# before The column to place 'column' before. - -proc ::TreeCtrl::ColumnCanMoveHere {w column before} { - if {[$w column compare $column == $before] || - ([$w column order $column] == [$w column order $before] - 1)} { - return 0 - } - set lock [$w column cget $column -lock] - return [expr {[$w column compare $before >= "first lock $lock"] && - [$w column compare $before <= "last lock $lock next"]}] -} - -# ::TreeCtrl::ColumnDragFindBefore -- -# -# This is called when dragging a column header. The result is 1 if the given -# coordinates are near a column header before which the dragged column can -# be moved. -# -# Arguments: -# w The treectrl widget. -# x Window x-coord. -# y Window y-coord. -# dragColumn The column being dragged. -# indColumn_ Out: what to set -indicatorcolumn to. -# indSide_ Out: what to set -indicatorside to. - -proc ::TreeCtrl::ColumnDragFindBefore {w x y dragColumn indColumn_ indSide_} { - upvar $indColumn_ indColumn - upvar $indSide_ indSide - - set lock [$w column cget $dragColumn -lock] - scan [$w bbox header.$lock] "%d %d %d %d" minX y1 maxX y2 - if {$x < $minX} { - set x $minX - } - if {$x >= $maxX} { - set x [expr {$maxX - 1}] - } - $w identify -array id $x $y - if {$id(where) ne "header"} { - return 0 - } - set indColumn $id(column) - if {[$w column compare $indColumn == $dragColumn]} { - return 0 - } - - # The given $x is either the left edge or the right edge of the column - # header that is being dragged depending on which direction the user - # is dragging the column. - # When dragging to the left, the indicator column is chosen to be the - # leftmost column whose mid-way point is greater than the left edge of the - # dragged header. - # When dragging to the right, the indicator column is chosen to be the - # rightmost column whose mid-way point is less than the right edge of the - # dragged header. - if {[$w column compare $indColumn != "tail"]} { - variable Priv - scan [$w header bbox $Priv(header) $indColumn] "%d %d %d %d" x1 y1 x2 y2 - # Hack - ignore canvaspadx - if {[$w column cget $indColumn -lock] eq "none" && - [$w column compare $indColumn == "first visible lock none"]} { - incr x1 [lindex [$w cget -canvaspadx] 0] - } - if {[$w column compare $dragColumn < $indColumn]} { - if {$x < $x1 + ($x2 - $x1) / 2} { - set indColumn [$w column id "$indColumn prev visible"] - set indColumn [GetSpanStartColumn $w $Priv(header) $indColumn] - } - } else { - if {$x > $x1 + ($x2 - $x1) / 2} { - # Find the column at the start of the next visible span - set starts [GetSpanStarts $w $Priv(header)] - for {set i [$w column order $indColumn]} {true} {incr i} { - if {[$w column compare [lindex $starts $i] > $indColumn]} break - } - set indColumn [lindex $starts $i] - } - } - } - - set before $indColumn - set prev [$w column id "$dragColumn prev visible"] - set next [$w column id "$dragColumn next visible"] - if {[$w column compare $indColumn == "tail"]} { - set indSide left - set indColumn [$w column id "last lock none visible"] - set indSide right - } elseif {$prev ne "" && [$w column compare $prev == $indColumn]} { - set indSide left - } elseif {$next ne "" && [$w column compare $next == $indColumn]} { - set before [$w column id "$indColumn next visible"] - set indSide right - } else { - scan [$w column bbox $indColumn] "%d %d %d %d" x1 y1 x2 y2 - if {$x < $x1 + ($x2 - $x1) / 2} { - set indSide left - } else { - set before [$w column id "$indColumn next visible"] - set indSide right - } - } - if {$before eq "" || [$w column compare $before > "last lock $lock next"]} { - set before [$w column id "last lock $lock next"] - } - return [ColumnCanMoveHere $w $dragColumn $before] -} - -# ::TreeCtrl::ListElementWindows -- -# -# Return a list of Tk windows in window elements in a column header. -# -# Arguments: -# T The treectrl widget. -# H Header id -# C Column id - -proc ::TreeCtrl::ListElementWindows {T H C} { - set S [$T header style set $H $C] - if {$S eq ""} return - set result {} - foreach E [$T header style elements $H $C] { - if {[$T element type $E] eq "window"} { - set window [$T header element cget $H $C $E -window] - if {$window ne ""} { - lappend result $window - } - } - } - return $result -} - -# ::TreeCtrl::ColumnDragRestackWindows -- -# -# Restack windows in window elements so that windows in dragged headers -# are above all other windows in undragged headers. -# -# Arguments: -# T The treectrl widget. - -proc ::TreeCtrl::ColumnDragRestackWindows {T} { - variable Priv - set C [$T header dragcget -imagecolumn] - set lock [$T column cget $C -lock] - set span [$T header dragcget -imagespan] - set last [$T column id [list $C span $span]] - set dragged [$T column id [list range $C $last]] - foreach H [$T header id all] { - set prev "" - set lowest "" - foreach C $dragged { - foreach win [ListElementWindows $T $H $C] { - if {$prev eq ""} { - set lowest $win - } else { - raise $win $prev - } - set prev $win - } - } - if {$lowest eq ""} continue - foreach C [$T column id "lock $lock !tail"] { - if {[lsearch -exact $dragged $C] != -1} continue - foreach win [ListElementWindows $T $H $C] { - lower $win $lowest - } - } - } - return -} - -# ::TreeCtrl::CursorAction -- -# -# If the given point is at the left or right edge of a resizable column -# header, the result is "action header-resize header H column C". -# If the given point is in a header with -button=TRUE, the result is -# "action header-button header H column C". -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::CursorAction {w x y var_} { - upvar $var_ var - variable Priv - $w identify -array id $x $y - - set var(action) "" - if {$id(where) eq "header"} { - set var(header) $id(header) - set column $id(column) - set side $id(side) - if {$side eq ""} { - if {[scan [$w bbox header.left] "%d %d %d %d" x1 y1 x2 y2] == 4} { - if {$x < $x2 + 4 && $x >= $x2} { - set column [$w column id "last visible lock left"] - set side right - } - } - if {[scan [$w bbox header.right] "%d %d %d %d" x1 y1 x2 y2] == 4} { - if {$x >= $x1 - 4 && $x < $x1} { - set column [$w column id "first visible lock right"] - set side left - } - } - } - if {$side eq "left"} { - if {[ColumnCanResizeLeft $w $column]} { - if {[$w column cget $column -resize]} { - array set var [list action "header-resize" column $column] - return - } - } else { - # Resize the previous column - if {[$w column compare $column == tail]} { - set prev [$w column id "last visible lock none"] - if {$prev eq ""} { - set prev [$w column id "last visible lock left"] - } - } else { - set prev [$w column id "$column prev visible"] - } - if {$prev ne "" && [$w column cget $prev -resize]} { - array set var [list action "header-resize" column $prev] - return - } - } - } elseif {$side eq "right"} { - # Get the last visible column in the span - set span [$w header span $id(header) $column] - set last [$w column id "$column span $span"] - set columns [$w column id [list range $column $last visible]] - set column2 [lindex $columns end] - if {[ColumnCanResizeLeft $w $column2]} { - # Resize the next column - set next [$w column id "$column2 next visible !tail"] - if {$next ne "" && [$w column cget $next -resize]} { - array set var [list action "header-resize" column $next] - return - } - } else { - if {[$w column cget $column2 -resize]} { - array set var [list action "header-resize" column $column2] - return - } - } - } - if {[$w column compare $column == "tail"]} { - # Can't -resize or -button the tail column - } elseif {[$w header cget $id(header) $column -button]} { - array set var [list action "header-button" column $column] - return - } - } - return -} - -# ::TreeCtrl::CursorCheck -- -# -# Sees if the given pointer coordinates are near the edge of a resizable -# column in the header. If so and the treectrl's cursor is not already -# set to sb_h_double_arrow, then the current cursor is saved and changed -# to sb_h_double_arrow, and an [after] callback to CursorCheckAux is -# scheduled. -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::CursorCheck {w x y} { - variable Priv - CursorAction $w $x $y action - # If we are in the middle of resizing a column, don't cancel the cursor - if {[info exists Priv(buttonMode)] && $Priv(buttonMode) eq "resize"} { - array set action {action "header-resize" header XXX column XXX} - } - if {$action(action) ne "header-resize"} { - CursorCancel $w - return - } - set cursor sb_h_double_arrow - if {$cursor ne [$w cget -cursor]} { - if {![info exists Priv(cursor,$w)]} { - set Priv(cursor,$w) [$w cget -cursor] - } - $w configure -cursor $cursor - } - if {[info exists Priv(cursor,afterId,$w)]} { - after cancel $Priv(cursor,afterId,$w) - } - set Priv(cursor,afterId,$w) [after 150 [list TreeCtrl::CursorCheckAux $w]] - return -} - -# ::TreeCtrl::CursorCheckAux -- -# -# Get's the location of the pointer and calls CursorCheck if the treectrl's -# cursor was previously set to sb_h_double_arrow. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::CursorCheckAux {w} { - variable Priv - if {![winfo exists $w]} return - set x [winfo pointerx $w] - set y [winfo pointery $w] - if {[info exists Priv(cursor,$w)]} { - set x [expr {$x - [winfo rootx $w]}] - set y [expr {$y - [winfo rooty $w]}] - CursorCheck $w $x $y - } - return -} - -# ::TreeCtrl::CursorCancel -- -# -# Restores the treectrl's cursor if it was changed to sb_h_double_arrow. -# Cancels any pending [after] callback to CursorCheckAux. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::CursorCancel {w} { - variable Priv - if {[info exists Priv(cursor,$w)]} { - $w configure -cursor $Priv(cursor,$w) - unset Priv(cursor,$w) - } - if {[info exists Priv(cursor,afterId,$w)]} { - after cancel $Priv(cursor,afterId,$w) - unset Priv(cursor,afterId,$w) - } - return -} - -# ::TreeCtrl::GetSpanStarts -- -# -# This procedure returns a list of column ids, one per tree column. -# Each column id indicates the column at the start of a span. -# -# Arguments: -# T The treectrl widget. -# H Header id - -proc ::TreeCtrl::GetSpanStarts {T H} { - set columns [list] - set spans [$T header span $H] - if {[lindex [lsort -integer $spans] end] eq 1} { - return [$T column list] - } - for {set index 0} {$index < [$T column count]} {} { - set Cspan [$T column id "order $index"] - set span [lindex $spans $index] - if {![$T column cget $Cspan -visible]} { - set span 1 - } - while {$span > 0 && $index < [$T column count]} { - if {[$T column cget "order $index" -lock] ne [$T column cget $Cspan -lock]} break - lappend columns $Cspan - incr span -1 - incr index - } - } - return $columns -} - -# ::TreeCtrl::GetSpanStartColumn -- -# -# This procedure returns the column at the start of a span which covers the -# given column. -# -# Arguments: -# T The treectrl widget. -# H Header id -# C Column id - -proc ::TreeCtrl::GetSpanStartColumn {T H C} { - set columns [GetSpanStarts $T $H] - return [lindex $columns [$T column order $C]] -} - -# ::TreeCtrl::SetHeaderState -- -# -# This procedure sets the state of a header-column and remembers that -# header-column. If a different header-column is passed later the previous -# header-column's state is set to 'normal'. -# -# Arguments: -# T The treectrl widget. -# H Header id -# C Column id -# state active|normal|pressed - -proc ::TreeCtrl::SetHeaderState {T H C state} { - variable Priv - if {[info exists Priv(inheader,$T)]} { - lassign $Priv(inheader,$T) Hprev Cprev - } else { - if {$H eq "" || $C eq ""} return - set Hprev [set Cprev ""] - } - if {$H ne $Hprev || $C ne $Cprev} { - if {$Hprev ne "" && [$T header id $Hprev] ne ""} { - if {$Cprev ne "" && [$T column id $Cprev] ne ""} { - $T header configure $Hprev $Cprev -state normal - TryEvent $T Header state [list H $Hprev C $Cprev s normal] - } - } - } - if {$H eq "" || $C eq ""} { - unset Priv(inheader,$T) - } else { - $T header configure $H $C -state $state - TryEvent $T Header state [list H $H C $C s $state] - set Priv(inheader,$T) [list $H $C] - } - return -} - -# ::TreeCtrl::ClearHeaderState -- -# -# If a header-column's state was previously set via SetHeaderState then -# that column's state is set to normal and the header-column is forgotten. -# -# Arguments: -# T The treectrl widget. -# H Header id -# C Column id -# state active|normal|pressed - -proc ::TreeCtrl::ClearHeaderState {T} { - SetHeaderState $T "" "" "" - return -} - -# ::TreeCtrl::MotionInHeader -- -# -# This procedure updates the active/normal states of column headers as the -# mouse pointer moves in and out of them. Typically this results in visual -# feedback by changing the appearance of the headers. -# -# Arguments: -# w The treectrl widget. -# args x y coords if the pointer is in the window, or an empty list. - -proc ::TreeCtrl::MotionInHeader {w args} { - variable Priv - if {[llength $args]} { - set x [lindex $args 0] - set y [lindex $args 1] - CursorAction $w $x $y action - } else { - array set action {action ""} - } - if {[info exists Priv(inheader,$w)]} { - lassign $Priv(inheader,$w) headerPrev columnPrev - } else { - set headerPrev [set columnPrev ""] - } - set header "" - set column "" - if {$action(action) eq "header-button"} { - set header $action(header) - set column $action(column) - } elseif {$action(action) eq "header-resize"} { - set header $action(header) - set column [GetSpanStartColumn $w $header $action(column)] - } - if {$header ne $headerPrev || $column ne $columnPrev} { - if {$column ne ""} { - SetHeaderState $w $header $column active - } else { - ClearHeaderState $w - } - } - return -} - -# ::TreeCtrl::MotionInButtons -- -# -# This procedure updates the active/normal states of item buttons. -# Typically this results in visual feedback by changing the appearance -# of the buttons. -# -# Arguments: -# T The treectrl widget. -# args x y coords if the pointer is in the window, or an empty list. - -proc ::TreeCtrl::MotionInButtons {T args} { - variable Priv - set button "" - if {[llength $args]} { - set x [lindex $args 0] - set y [lindex $args 1] - $T identify -array id $x $y - if {$id(where) eq "item" && $id(button)} { - set button $id(item) - } - } - if {[info exists Priv(inbutton,$T)]} { - set prevButton $Priv(inbutton,$T) - } else { - set prevButton "" - } - if {$button ne $prevButton} { - if {$prevButton ne ""} { - if {[$T item id $prevButton] ne ""} { - $T item buttonstate $prevButton normal - } - } - if {$button ne ""} { - $T item buttonstate $button active - set Priv(inbutton,$T) $button - } else { - unset Priv(inbutton,$T) - } - } - if {[$T notify bind TreeCtrlButtonNotifyScroll] eq ""} { - $T notify bind TreeCtrlButtonNotifyScroll { - TreeCtrl::ButtonNotifyScroll %T - } - } - return -} - -# ::TreeCtrl::ButtonNotifyScroll -- -# -# Called when a event occurs and a button is in the active state. -# Finds the mouse pointer coords and calls MotionInButtons to update the -# state of affected buttons. -# -# Arguments: -# T The treectrl widget. - -proc ::TreeCtrl::ButtonNotifyScroll {T} { - set x [expr {[winfo pointerx $T] - [winfo rootx $T]}] - set y [expr {[winfo pointery $T] - [winfo rooty $T]}] - MotionInButtons $T $x $y - return -} - -# ::TreeCtrl::ButtonPress1 -- -# -# Handle event. -# -# Arguments: -# w The treectrl widget. -# x Window x coord. -# y Window y coord. - -proc ::TreeCtrl::ButtonPress1 {w x y} { - variable Priv - focus $w - - $w identify -array id $x $y - if {$id(where) eq ""} { - return - } - - if {$id(where) eq "item"} { - set item $id(item) - if {$id(button)} { - if {[$w cget -buttontracking]} { - $w item buttonstate $item pressed - set Priv(buttonMode) buttonTracking - set Priv(buttontrack,item) $item - } else { - $w item toggle $item -animate - } - return - } elseif {$id(line) ne ""} { - $w item toggle $id(line) - return - } - } - set Priv(buttonMode) "" - if {$id(where) eq "header"} { - CursorAction $w $x $y action - if {$action(action) eq "header-resize"} { - set column $action(column) - set Priv(buttonMode) resize - set Priv(header) $action(header) - set Priv(column) $column - set Priv(x) $x - set Priv(y) $y - set Priv(width) [$w column width $column] - return - } - set column $id(column) - if {$action(action) eq "header-button"} { - set Priv(buttonMode) header - SetHeaderState $w $action(header) $column pressed - } else { - if {[$w column compare $column == "tail"]} return - if {![$w header dragcget -enable]} return - if {![$w header dragcget $action(header) -enable]} return - set Priv(buttonMode) dragColumnWait - } - set Priv(header) $action(header) - set Priv(column) $column - set Priv(columnDrag,x) $x - set Priv(columnDrag,y) $y - return - } - set item $id(item) - if {![$w item enabled $item]} { - return - } - - # If the initial mouse-click is in a locked column, restrict scrolling - # to the vertical. - set count [scan [$w contentbox] "%d %d %d %d" x1 y1 x2 y2] - if {$count != -1 && $x >= $x1 && $x < $x2} { - set Priv(autoscan,direction,$w) xy - } else { - set Priv(autoscan,direction,$w) y - } - - set Priv(buttonMode) normal - BeginSelect $w $item - return -} - -# ::TreeCtrl::DoubleButtonPress1 -- -# -# Handle event. -# -# Arguments: -# w The treectrl widget. -# x Window x coord. -# y Window y coord. - -proc ::TreeCtrl::DoubleButton1 {w x y} { - - $w identify -array id $x $y - if {$id(where) eq ""} { - return - } - if {$id(where) eq "item"} { - if {$id(button)} { - if {[$w cget -buttontracking]} { - # There is no so just toggle it - $w item toggle $id(item) -animate - } else { - $w item toggle $id(item) -animate - } - return - } elseif {$id(line) ne ""} { - $w item toggle $id(line) - return - } - } - if {$id(where) eq "header"} { - CursorAction $w $x $y action - # Double-click between columns to set default column width - if {$action(action) eq "header-resize"} { - set column $action(column) - $w column configure $column -width "" - CursorCheck $w $x $y - MotionInHeader $w $x $y - } else { - ButtonPress1 $w $x $y - } - } - return -} - -# ::TreeCtrl::Motion1 -- -# -# Handle event. -# -# Arguments: -# w The treectrl widget. -# x Window x coord. -# y Window y coord. - -proc ::TreeCtrl::Motion1 {w x y} { - variable Priv - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - header { - $w identify -array id $x $y - if {$id(where) ne "header" || - $id(header) ne $Priv(header) || - $id(column) ne $Priv(column)} { - if {[$w header cget $Priv(header) $Priv(column) -state] eq "pressed"} { - ClearHeaderState $w - } - } else { - if {[$w header cget $Priv(header) $Priv(column) -state] ne "pressed"} { - SetHeaderState $w $Priv(header) $Priv(column) pressed - } - if {[$w header dragcget -enable] && - [$w header dragcget $Priv(header) -enable] && - (abs($Priv(columnDrag,x) - $x) > 4)} { - set Priv(columnDrag,x) $x - $w header dragconfigure \ - -imagecolumn $Priv(column) \ - -imageoffset [expr {$x - $Priv(columnDrag,x)}] \ - -imagespan [$w header span $Priv(header) $Priv(column)] - ColumnDragRestackWindows $w - set Priv(buttonMode) dragColumn - TryEvent $w ColumnDrag begin [list H $Priv(header) C $Priv(column)] - # Allow binding scripts to cancel the drag - if {[$w header dragcget -imagecolumn] eq ""} { - set Priv(buttonMode) header - } - } - } - } - buttonTracking { - $w identify -array id $x $y - set itemTrack $Priv(buttontrack,item) - set exists [expr {[$w item id $itemTrack] ne ""}] - set mouseover 0 - if {$id(where) eq "item" && $id(button)} { - if {$exists && [$w item compare $itemTrack == $id(item)]} { - set mouseover 1 - } - } - if {$mouseover} { - $w item buttonstate $itemTrack pressed - } elseif {$exists} { - $w item buttonstate $itemTrack normal - } - } - dragColumnWait { - if {(abs($Priv(columnDrag,x) - $x) > 4)} { - set Priv(columnDrag,x) $x - $w header dragconfigure \ - -imagecolumn $Priv(column) \ - -imageoffset [expr {$x - $Priv(columnDrag,x)}] \ - -imagespan [$w header span $Priv(header) $Priv(column)] - ColumnDragRestackWindows $w - set Priv(buttonMode) dragColumn - TryEvent $w ColumnDrag begin [list H $Priv(header) C $Priv(column)] - # Allow binding scripts to cancel the drag - if {[$w header dragcget -imagecolumn] eq ""} { - unset Priv(buttonMode) - } - } - } - dragColumn { - scan [$w bbox header] "%d %d %d %d" x1 y1 x2 y2 - if {$y < $y1 - 30 || $y >= $y2 + 30} { - set inside 0 - } else { - set inside 1 - } - if {$inside && ([$w header dragcget -imagecolumn] eq "")} { - $w header dragconfigure -imagecolumn $Priv(column) - } elseif {!$inside && ([$w header dragcget -imagecolumn] ne "")} { - $w header dragconfigure -imagecolumn "" -indicatorcolumn "" - } - if {$inside} { - set offset [expr {$x - $Priv(columnDrag,x)}] - $w header dragconfigure -imageoffset $offset - - # When dragging to the left, use the left edge of the dragged - # header to choose the -indicatorcolumn. When dragging to the - # right, use the right edge. - scan [$w header bbox $Priv(header) $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 - if {$offset > 0} { - set xEdge [expr {$offset + $x2}] - } else { - set xEdge [expr {$offset + $x1}] - } - - if {[ColumnDragFindBefore $w $xEdge $Priv(columnDrag,y) $Priv(column) indColumn indSide]} { - set prevIndColumn [$w header dragcget -indicatorcolumn] - $w header dragconfigure \ - -indicatorcolumn $indColumn \ - -indicatorside $indSide \ - -indicatorspan [$w header span $Priv(header) $indColumn] - if {$indColumn != $prevIndColumn} { - TryEvent $w ColumnDrag indicator [list H $Priv(header) C $indColumn] - } - } else { - $w header dragconfigure -indicatorcolumn "" - } - } - if {[$w column cget $Priv(column) -lock] eq "none"} { - ColumnDragScrollCheck $w $x $y - } - } - normal { - set Priv(x) $x - set Priv(y) $y - SelectionMotion $w [$w item id [list nearest $x $y]] - set Priv(autoscan,command,$w) {SelectionMotion %T [%T item id "nearest %x %y"]} - AutoScanCheck $w $x $y - } - resize { - if {[ColumnCanResizeLeft $w $Priv(column)]} { - set width [expr {$Priv(width) + $Priv(x) - $x}] - } else { - set width [expr {$Priv(width) + $x - $Priv(x)}] - } - set minWidth [$w column cget $Priv(column) -minwidth] - set maxWidth [$w column cget $Priv(column) -maxwidth] - if {$minWidth eq ""} { - set minWidth 0 - } - if {$width < $minWidth} { - set width $minWidth - } - if {($maxWidth ne "") && ($width > $maxWidth)} { - set width $maxWidth - } - if {$width == 0} { - incr width - } - switch -- [$w cget -columnresizemode] { - proxy { - scan [$w column bbox $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 - if {[ColumnCanResizeLeft $w $Priv(column)]} { - # Use "ne" because -columnproxy could be "" - if {$x2 - $width ne [$w cget -columnproxy]} { - $w configure -columnproxy [expr {$x2 - $width}] - } - } else { - if {($x1 + $width - 1) ne [$w cget -columnproxy]} { - $w configure -columnproxy [expr {$x1 + $width - 1}] - } - } - } - realtime { - if {[$w column cget $Priv(column) -width] != $width} { - $w column configure $Priv(column) -width $width - } - } - } - } - } - return -} - -# ::TreeCtrl::Leave1 -- -# -# Handle event. -# -# Arguments: -# w The treectrl widget. -# x Window x coord. -# y Window y coord. - -proc ::TreeCtrl::Leave1 {w x y} { - variable Priv - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - header { - if {[$w header cget $Priv(header) $Priv(column) -state] eq "pressed"} { - ClearHeaderState $w - } - } - } - return -} - -# ::TreeCtrl::Enter1 -- -# -# Handle event. -# -# Arguments: -# w The treectrl widget. -# x Window x coord. -# y Window y coord. - -proc ::TreeCtrl::Enter1 {w x y} { - variable Priv - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - default {} - } - return -} - -# ::TreeCtrl::Release1 -- -# -# Handle event. -# -# Arguments: -# w The treectrl widget. -# x Window x coord. -# y Window y coord. - -proc ::TreeCtrl::Release1 {w x y} { - variable Priv - if {![info exists Priv(buttonMode)]} return - switch $Priv(buttonMode) { - header { - if {[$w header cget $Priv(header) $Priv(column) -state] eq "pressed"} { - SetHeaderState $w $Priv(header) $Priv(column) active - TryEvent $w Header invoke [list H $Priv(header) C $Priv(column)] - } - CursorCheck $w $x $y - MotionInHeader $w $x $y - } - buttonTracking { - $w identify -array id $x $y - set itemTrack $Priv(buttontrack,item) - set exists [expr {[$w item id $itemTrack] ne ""}] - if {$id(where) eq "item" && $id(button)} { - if {$exists && [$w item compare $itemTrack == $id(item)]} { - $w item buttonstate $id(item) active - $w item toggle $itemTrack -animate - } - } - } - dragColumn { - AutoScanCancel $w - ClearHeaderState $w - if {[$w header dragcget -imagecolumn] ne ""} { - set visible 1 - } else { - set visible 0 - } - set column [$w header dragcget -indicatorcolumn] - $w header dragconfigure -imagecolumn "" -indicatorcolumn "" - if {$visible && ($column ne "")} { - # If dragging to the right, drop after the last column in the - # span of the indicator column. - if {[$w column order $Priv(column)] < [$w column order $column]} { - set span [$w header dragcget -indicatorspan] - set column [$w column id "$column span $span next"] - } - set lock [$w column cget $Priv(column) -lock] - if {$column eq "" || [$w column compare $column > "last lock $lock next"]} { - set column [$w column id "last lock $lock next"] - } - TryEvent $w ColumnDrag receive [list H $Priv(header) C $Priv(column) b $column] - } - CursorCheck $w $x $y - MotionInHeader $w $x $y - TryEvent $w ColumnDrag end [list H $Priv(header) C $Priv(column)] - } - normal { - AutoScanCancel $w - set nearest [$w item id [list nearest $x $y]] - if {$nearest ne ""} { - $w activate $nearest - } -set Priv(prev) "" - } - resize { - if {[$w cget -columnproxy] ne ""} { - scan [$w column bbox $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 - if {[ColumnCanResizeLeft $w $Priv(column)]} { - set width [expr {$x2 - [$w cget -columnproxy]}] - } else { - set width [expr {[$w cget -columnproxy] - $x1 + 1}] - } - $w configure -columnproxy {} - $w column configure $Priv(column) -width $width - } - # Clear buttonMode early so CursorCheck doesn't exit - unset Priv(buttonMode) - CursorCheck $w $x $y - MotionInHeader $w $x $y - return - } - } - unset Priv(buttonMode) - return -} - -# ::TreeCtrl::BeginSelect -- -# -# This procedure is typically invoked on button-1 presses. It begins -# the process of making a selection in the treectrl. Its exact behavior -# depends on the selection mode currently in effect for the treectrl. -# -# Arguments: -# w The treectrl widget. -# item The item for the selection operation (typically the -# one under the pointer). - -proc ::TreeCtrl::BeginSelect {w item} { - variable Priv - if {$item eq ""} return - if {[string equal [$w cget -selectmode] "multiple"]} { - if {[$w selection includes $item]} { - $w selection clear $item - } else { - $w selection add $item - } - } else { - $w selection anchor $item - $w selection modify $item all - set Priv(selection) {} - set Priv(prev) $item - } - return -} - -# ::TreeCtrl::SelectionMotion -- -# -# This procedure is called to process mouse motion events while -# button 1 is down. It may move or extend the selection, depending -# on the treectrl's selection mode. -# -# Arguments: -# w The treectrl widget. -# item- The item under the pointer. - -proc ::TreeCtrl::SelectionMotion {w item} { - variable Priv - - if {$item eq ""} return - set item [$w item id $item] - if {$item eq $Priv(prev)} return - if {![$w item enabled $item]} return - - switch [$w cget -selectmode] { - browse { - $w selection modify $item all - set Priv(prev) $item - } - extended { - set i $Priv(prev) - set select {} - set deselect {} - if {$i eq ""} { - set i $item - lappend select $item - set hack [$w item compare $item == anchor] - } else { - set hack 0 - } - if {[$w selection includes anchor] || $hack} { - set deselect [concat $deselect [$w item range $i $item]] - set select [concat $select [$w item range anchor $item]] - } else { - set deselect [concat $deselect [$w item range $i $item]] - set deselect [concat $deselect [$w item range anchor $item]] - } - if {![info exists Priv(selection)]} { - set Priv(selection) [$w selection get] - } - while {[$w item compare $i < $item] && [$w item compare $i < anchor]} { - if {[lsearch $Priv(selection) $i] >= 0} { - lappend select $i - } - set i [$w item id "$i next visible"] - } - while {[$w item compare $i > $item] && [$w item compare $i > anchor]} { - if {[lsearch $Priv(selection) $i] >= 0} { - lappend select $i - } - set i [$w item id "$i prev visible"] - } - set Priv(prev) $item - $w selection modify $select $deselect - } - } - return -} - -# ::TreeCtrl::BeginExtend -- -# -# This procedure is typically invoked on shift-button-1 presses. It -# begins the process of extending a selection in the treectrl. Its -# exact behavior depends on the selection mode currently in effect -# for the treectrl. -# -# Arguments: -# w The treectrl widget. -# item- The item for the selection operation (typically the -# one under the pointer). - -proc ::TreeCtrl::BeginExtend {w item} { - if {[string equal [$w cget -selectmode] "extended"]} { - if {[$w selection includes anchor]} { - SelectionMotion $w $item - } else { - # No selection yet; simulate the begin-select operation. - BeginSelect $w $item - } - } - return -} - -# ::TreeCtrl::BeginToggle -- -# -# This procedure is typically invoked on control-button-1 presses. It -# begins the process of toggling a selection in the treectrl. Its -# exact behavior depends on the selection mode currently in effect -# for the treectrl. -# -# Arguments: -# w The treectrl widget. -# item The item for the selection operation (typically the -# one under the pointer). - -proc ::TreeCtrl::BeginToggle {w item} { - variable Priv - if {$item eq ""} return - if {[string equal [$w cget -selectmode] "extended"]} { - set Priv(selection) [$w selection get] - set Priv(prev) $item - $w selection anchor $item - if {[$w selection includes $item]} { - $w selection clear $item - } else { - $w selection add $item - } - } - return -} - -# ::TreeCtrl::AutoScanCheck -- -# -# Sees if the given pointer coords are outside the content area of the -# treectrl (ie, not including borders or column headers) or within -# -scrollmargin distance of the edges of the content area. If so and -# auto-scanning is not already in progress, then the window is scrolled -# and an [after] callback to AutoScanCheckAux is scheduled. -# -# Arguments: -# w The treectrl widget. -# x Window x coord. -# y Window y coord. - -proc ::TreeCtrl::AutoScanCheck {w x y} { - variable Priv - # Could have clicked in locked column - if {[scan [$w contentbox] "%d %d %d %d" x1 y1 x2 y2] == -1} { - if {[scan [$w bbox left] "%d %d %d %d" x1 y1 x2 y2] == -1} { - scan [$w bbox right] "%d %d %d %d" x1 y1 x2 y2 - } - } - set margin [winfo pixels $w [$w cget -scrollmargin]] - if {![info exists Priv(autoscan,direction,$w)]} { - set Priv(autoscan,direction,$w) xy - } - set scrollX [string match *x* $Priv(autoscan,direction,$w)] - set scrollY [string match *y* $Priv(autoscan,direction,$w)] - if {($scrollX && (($x < $x1 + $margin) || ($x >= $x2 - $margin))) || - ($scrollY && (($y < $y1 + $margin) || ($y >= $y2 - $margin)))} { - if {[info exists Priv(autoscan,afterId,$w)]} return - if {$scrollY && $y >= $y2 - $margin} { - $w yview scroll 1 units - set delay [$w cget -yscrolldelay] - } elseif {$scrollY && $y < $y1 + $margin} { - $w yview scroll -1 units - set delay [$w cget -yscrolldelay] - } elseif {$scrollX && $x >= $x2 - $margin} { - $w xview scroll 1 units - set delay [$w cget -xscrolldelay] - } elseif {$scrollX && $x < $x1 + $margin} { - $w xview scroll -1 units - set delay [$w cget -xscrolldelay] - } - set count [scan $delay "%d %d" d1 d2] - if {[info exists Priv(autoscan,scanning,$w)]} { - if {$count == 2} { - set delay $d2 - } - } else { - if {$count == 2} { - set delay $d1 - } - set Priv(autoscan,scanning,$w) 1 - } - if {$Priv(autoscan,command,$w) ne ""} { - set command [string map [list %T $w %x $x %y $y] $Priv(autoscan,command,$w)] - eval $command - } - set Priv(autoscan,afterId,$w) [after $delay [list TreeCtrl::AutoScanCheckAux $w]] - return - } - AutoScanCancel $w - return -} - -# ::TreeCtrl::AutoScanCheckAux -- -# -# Gets the location of the pointer and calls AutoScanCheck. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::AutoScanCheckAux {w} { - variable Priv - if {![winfo exists $w]} return - # Not quite sure how this can happen - if {![info exists Priv(autoscan,afterId,$w)]} return - unset Priv(autoscan,afterId,$w) - set x [winfo pointerx $w] - set y [winfo pointery $w] - set x [expr {$x - [winfo rootx $w]}] - set y [expr {$y - [winfo rooty $w]}] - AutoScanCheck $w $x $y - return -} - -# ::TreeCtrl::AutoScanCancel -- -# -# Cancels any pending [after] callback to AutoScanCheckAux. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::AutoScanCancel {w} { - variable Priv - if {[info exists Priv(autoscan,afterId,$w)]} { - after cancel $Priv(autoscan,afterId,$w) - unset Priv(autoscan,afterId,$w) - } - unset -nocomplain Priv(autoscan,scanning,$w) - return -} - -# ::TreeCtrl::ColumnDragScrollCheck -- -# -# Sees if the given pointer coords are outside the left or right edges of -# the content area of the treectrl (ie, not including borders). If so and -# auto-scanning is not already in progress, then the window is scrolled -# horizontally and the column drag-image is repositioned, and an [after] -# callback to ColumnDragScrollCheckAux is scheduled. -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::ColumnDragScrollCheck {w x y} { - variable Priv - - # When dragging to the left, use the left edge of the dragged - # header to choose the -indicatorcolumn. When dragging to the - # right, use the right edge. - scan [$w header bbox $Priv(header) $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 - set offset [$w header dragcget -imageoffset] - if {$offset > 0} { - set xEdge [expr {$offset + $x2}] - } else { - set xEdge [expr {$offset + $x1}] - } - - scan [$w bbox header.none] "%d %d %d %d" x1 y1 x2 y2 - - if {($x < $x1) || ($x >= $x2)} { - if {![info exists Priv(autoscan,afterId,$w)]} { - set bbox1 [$w column bbox $Priv(column)] - if {$xEdge >= $x2} { - $w xview scroll 1 units - } else { - $w xview scroll -1 units - } - set bbox2 [$w column bbox $Priv(column)] - if {[lindex $bbox1 0] != [lindex $bbox2 0]} { - incr Priv(columnDrag,x) [expr {[lindex $bbox2 0] - [lindex $bbox1 0]}] - $w header dragconfigure -imageoffset [expr {$x - $Priv(columnDrag,x)}] - - if {[ColumnDragFindBefore $w $xEdge $Priv(columnDrag,y) $Priv(column) indColumn indSide]} { - $w header dragconfigure -indicatorcolumn $indColumn \ - -indicatorside $indSide - } else { - $w header dragconfigure -indicatorcolumn "" - } - } - set Priv(autoscan,afterId,$w) [after 50 [list TreeCtrl::ColumnDragScrollCheckAux $w]] - } - return - } - AutoScanCancel $w - return -} - -# ::TreeCtrl::ColumnDragScrollCheckAux -- -# -# Gets the location of the pointer and calls ColumnDragScrollCheck. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::ColumnDragScrollCheckAux {w} { - variable Priv - if {![winfo exists $w]} return - # Not quite sure how this can happen - if {![info exists Priv(autoscan,afterId,$w)]} return - unset Priv(autoscan,afterId,$w) - set x [winfo pointerx $w] - set y [winfo pointery $w] - set x [expr {$x - [winfo rootx $w]}] - set y [expr {$y - [winfo rooty $w]}] - ColumnDragScrollCheck $w $x $y - return -} - -# ::TreeCtrl::Has2DLayout -- -# -# Determine if items are displayed in a 2-dimensional arrangement. -# This is used by the and bindings. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::Has2DLayout {T} { - if {[$T cget -orient] ne "vertical" || [$T cget -wrap] ne ""} { - return 1 - } - set item [$T item id "last visible"] - if {$item ne ""} { - lassign [$T item rnc $item] row column - if {$column > 0} { - return 1 - } - } - return 0 -} - -# ::TreeCtrl::UpDown -- -# -# Returns the id of an item above or below the given item that the active -# item could be set to. If the given item isn't visible, the first visible -# enabled item is returned. An attempt is made to choose an item in the -# same column over repeat calls; this gives a better result if some rows -# have less items than others. Only enabled items are considered. -# -# Arguments: -# w The treectrl widget. -# item Item to move from, typically the active item. -# n +1 to move down, -1 to move up. - -proc ::TreeCtrl::UpDown {w item n} { - variable Priv - set rnc [$w item rnc $item] - if {$rnc eq ""} { - return [$w item id {first visible state enabled}] - } - scan $rnc "%d %d" row col - set Priv(keyNav,row,$w) [expr {$row + $n}] - if {![info exists Priv(keyNav,rnc,$w)] || $rnc ne $Priv(keyNav,rnc,$w)} { - set Priv(keyNav,col,$w) $col - } - set item2 [$w item id "rnc $Priv(keyNav,row,$w) $Priv(keyNav,col,$w)"] - if {[$w item compare $item == $item2]} { - set Priv(keyNav,row,$w) $row - if {![$w item enabled $item2]} { - return "" - } - } else { - set Priv(keyNav,rnc,$w) [$w item rnc $item2] - if {![$w item enabled $item2]} { - return [UpDown $w $item2 $n] - } - } - return $item2 -} - -# ::TreeCtrl::LeftRight -- -# -# Returns the id of an item left or right of the given item that the active -# item could be set to. If the given item isn't visible, the first visible -# enabled item is returned. An attempt is made to choose an item in the -# same row over repeat calls; this gives a better result if some columns -# have less items than others. Only enabled items are considered. -# -# Arguments: -# w The treectrl widget. -# item Item to move from, typically the active item. -# n +1 to move right, -1 to move left. - -proc ::TreeCtrl::LeftRight {w item n} { - variable Priv - set rnc [$w item rnc $item] - if {$rnc eq ""} { - return [$w item id {first visible state enabled}] - } - scan $rnc "%d %d" row col - set Priv(keyNav,col,$w) [expr {$col + $n}] - if {![info exists Priv(keyNav,rnc,$w)] || $rnc ne $Priv(keyNav,rnc,$w)} { - set Priv(keyNav,row,$w) $row - } - set item2 [$w item id "rnc $Priv(keyNav,row,$w) $Priv(keyNav,col,$w)"] - if {[$w item compare $item == $item2]} { - set Priv(keyNav,col,$w) $col - if {![$w item enabled $item2]} { - return "" - } - } else { - set Priv(keyNav,rnc,$w) [$w item rnc $item2] - if {![$w item enabled $item2]} { - return [LeftRight $w $item2 $n] - } - } - return $item2 -} - -# ::TreeCtrl::SetActiveItem -- -# -# Sets the active item, scrolls it into view, and makes it the only selected -# item. If -selectmode is extended, makes the active item the anchor of any -# future extended selection. -# -# Arguments: -# w The treectrl widget. -# item The new active item, or "". - -proc ::TreeCtrl::SetActiveItem {w item} { - if {$item eq ""} return - $w activate $item - $w see active - $w selection modify active all - switch [$w cget -selectmode] { - extended { - $w selection anchor active - set Priv(prev) [$w item id active] - set Priv(selection) {} - } - } - return -} - -# ::TreeCtrl::Extend -- -# -# Does nothing unless we're in extended selection mode; in this -# case it moves the location cursor (active item) up, down, left or -# right, and extends the selection to that point. -# -# Arguments: -# w The treectrl widget. -# dir up, down, left or right - -proc ::TreeCtrl::Extend {w dir} { - variable Priv - if {[string compare [$w cget -selectmode] "extended"]} { - return - } - if {![info exists Priv(selection)]} { - $w selection add active - set Priv(selection) [$w selection get] - } - switch -- $dir { - above { set item [UpDown $w active -1] } - below { set item [UpDown $w active 1] } - left { set item [LeftRight $w active -1] } - right { set item [LeftRight $w active 1] } - } - if {$item eq ""} return - $w activate $item - $w see active - SelectionMotion $w [$w item id active] - return -} - -# ::TreeCtrl::DataExtend -# -# This procedure is called for key-presses such as Shift-KEndData. -# If the selection mode isn't multiple or extended then it does nothing. -# Otherwise it moves the active item and, if we're in -# extended mode, extends the selection to that point. -# -# Arguments: -# w The treectrl widget. -# item Item to become new active item. - -proc ::TreeCtrl::DataExtend {w item} { - if {$item eq ""} return - set mode [$w cget -selectmode] - if {[string equal $mode "extended"]} { - $w activate $item - $w see $item - if {[$w selection includes anchor]} { - SelectionMotion $w $item - } - } elseif {[string equal $mode "multiple"]} { - $w activate $item - $w see $item - } - return -} - -# ::TreeCtrl::Cancel -# -# This procedure is invoked to cancel an extended selection in -# progress. If there is an extended selection in progress, it -# restores all of the items between the active one and the anchor -# to their previous selection state. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::Cancel w { - variable Priv - if {[string compare [$w cget -selectmode] "extended"]} { - return - } - set first [$w item id anchor] - set last $Priv(prev) - if {[string equal $last ""] || [string equal [$w item id $last] ""]} { - # Not actually doing any selection right now - return - } - if {[$w item compare $first > $last]} { - set tmp $first - set first $last - set last $tmp - } - set select {} - set deselect {} - foreach item [$w item id "range $first $last visible"] { - if {[lsearch $Priv(selection) $item] == -1} { - lappend deselect $item - } else { - lappend select $item - } - } - $w selection modify $select $deselect - return -} - -# ::TreeCtrl::SelectAll -# -# This procedure is invoked to handle the "select all" operation. -# For single and browse mode, it just selects the active item. -# Otherwise it selects everything in the widget. -# -# Arguments: -# w The treectrl widget. - -proc ::TreeCtrl::SelectAll w { - set mode [$w cget -selectmode] - if {[string equal $mode "single"] || [string equal $mode "browse"]} { - $w selection modify active all - } else { - $w selection add all - } - return -} - -# ::TreeCtrl::MarqueeBegin -- -# -# Shows the selection rectangle at the given coords. -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::MarqueeBegin {w x y} { - set x [$w canvasx $x] - set y [$w canvasy $y] - $w marquee coords $x $y $x $y - $w marquee configure -visible yes - return -} - -# ::TreeCtrl::MarqueeUpdate -- -# -# Resizes the selection rectangle. -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::MarqueeUpdate {w x y} { - set x [$w canvasx $x] - set y [$w canvasy $y] - $w marquee corner $x $y - return -} - -# ::TreeCtrl::MarqueeEnd -- -# -# Hides the selection rectangle. -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::MarqueeEnd {w x y} { - $w marquee configure -visible no - return -} - -# ::TreeCtrl::ScanMark -- -# -# Marks the start of a possible scan drag operation. -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::ScanMark {w x y} { - variable Priv - $w scan mark $x $y - set Priv(x) $x - set Priv(y) $y - set Priv(mouseMoved) 0 - return -} - -# ::TreeCtrl::ScanDrag -- -# -# Performs a scan drag if the mouse moved. -# -# Arguments: -# w The treectrl widget. -# x Window coord of pointer. -# y Window coord of pointer. - -proc ::TreeCtrl::ScanDrag {w x y} { - variable Priv - if {![info exists Priv(x)]} { set Priv(x) $x } - if {![info exists Priv(y)]} { set Priv(y) $y } - if {($x != $Priv(x)) || ($y != $Priv(y))} { - set Priv(mouseMoved) 1 - } - if {[info exists Priv(mouseMoved)] && $Priv(mouseMoved)} { - $w scan dragto $x $y - } - return -} - -# ::TreeCtrl::TryEvent -- -# -# This procedure is used to cause a treectrl to generate a dynamic event. -# If the treectrl doesn't have the event defined (because you didn't call -# the [notify install] command) nothing happens. TreeCtrl::PercentsCmd is -# used to perform %-substitution on any scripts bound to the event. -# -# Arguments: -# T The treectrl widget. -# event Name of event. -# detail Name of detail or "". -# charMap %-char substitution list (even number of elements). - -proc ::TreeCtrl::TryEvent {T event detail charMap} { - if {[lsearch -exact [$T notify eventnames] $event] == -1} return - if {$detail ne ""} { - if {[lsearch -exact [$T notify detailnames $event] $detail] == -1} return - $T notify generate <$event-$detail> $charMap "::TreeCtrl::PercentsCmd $T" - } else { - $T notify generate <$event> $charMap "::TreeCtrl::PercentsCmd $T" - } - return -} - -# ::TreeCtrl::PercentsCmd -- -# -# This command is passed to [notify generate] to perform %-substitution on -# scripts bound to dynamic events. It supports the same set of substitution -# characters as the built-in static events (plus any event-specific chars). -# -# Arguments: -# T The treectrl widget. -# char %-char to be replaced in bound scripts. -# object Same arg passed to [notify bind]. -# event Name of event. -# detail Name of detail or "". -# charMap %-char substitution list (even number of elements). - -proc ::TreeCtrl::PercentsCmd {T char object event detail charMap} { - if {$detail ne ""} { - set pattern <$event-$detail> - } else { - set pattern <$event> - } - switch -- $char { - d { return $detail } - e { return $event } - P { return $pattern } - W { return $object } - T { return $T } - ? { - array set map $charMap - array set map [list T $T W $object P $pattern e $event d $detail] - return [array get map] - } - default { - array set map [list $char $char] - array set map $charMap - return $map($char) - } - } - return -} - -namespace eval TreeCtrl { -catch { - foreach theme [ttk::style theme names] { - ttk::style theme settings $theme { - ttk::style configure TreeCtrlHeading -relief raised -font TkHeadingFont - ttk::style map TreeCtrlHeading -relief { - pressed sunken - } - } - } -} -} +# Copyright (c) 2002-2011 Tim Baker + +bind TreeCtrl { + TreeCtrl::CursorCheck %W %x %y + TreeCtrl::MotionInHeader %W %x %y + TreeCtrl::MotionInButtons %W %x %y +} +bind TreeCtrl { + TreeCtrl::CursorCancel %W + TreeCtrl::MotionInHeader %W + TreeCtrl::MotionInButtons %W +} +bind TreeCtrl { + TreeCtrl::ButtonPress1 %W %x %y +} +bind TreeCtrl { + TreeCtrl::DoubleButton1 %W %x %y +} +bind TreeCtrl { + TreeCtrl::Motion1 %W %x %y +} +bind TreeCtrl { + TreeCtrl::Release1 %W %x %y +} +bind TreeCtrl { + set TreeCtrl::Priv(buttonMode) normal + TreeCtrl::BeginExtend %W [%W item id {nearest %x %y}] +} +# Command-click should provide a discontinuous selection on OSX +switch -- [tk windowingsystem] { + "aqua" { set modifier Command } + default { set modifier Control } +} +bind TreeCtrl <$modifier-ButtonPress-1> { + set TreeCtrl::Priv(buttonMode) normal + TreeCtrl::BeginToggle %W [%W item id {nearest %x %y}] +} +bind TreeCtrl { + TreeCtrl::Leave1 %W %x %y +} +bind TreeCtrl { + TreeCtrl::Enter1 %W %x %y +} + +bind TreeCtrl { + TreeCtrl::SetActiveItem %W [TreeCtrl::UpDown %W active -1] +} +bind TreeCtrl { + TreeCtrl::Extend %W above +} +bind TreeCtrl { + TreeCtrl::SetActiveItem %W [TreeCtrl::UpDown %W active 1] +} +bind TreeCtrl { + TreeCtrl::Extend %W below +} +bind TreeCtrl { + if {![TreeCtrl::Has2DLayout %W]} { + %W item collapse [%W item id active] + } else { + TreeCtrl::SetActiveItem %W [TreeCtrl::LeftRight %W active -1] + } +} +bind TreeCtrl { + TreeCtrl::Extend %W left +} +bind TreeCtrl { + %W xview scroll -1 pages +} +bind TreeCtrl { + if {![TreeCtrl::Has2DLayout %W]} { + %W item expand [%W item id active] + } else { + TreeCtrl::SetActiveItem %W [TreeCtrl::LeftRight %W active 1] + } +} +bind TreeCtrl { + TreeCtrl::Extend %W right +} +bind TreeCtrl { + %W xview scroll 1 pages +} +bind TreeCtrl { + %W yview scroll -1 pages + if {[%W item id {nearest 0 0}] ne ""} { + %W activate {nearest 0 0} + } +} +bind TreeCtrl { + %W yview scroll 1 pages + if {[%W item id {nearest 0 0}] ne ""} { + %W activate {nearest 0 0} + } +} +bind TreeCtrl { + %W xview scroll -1 pages +} +bind TreeCtrl { + %W xview scroll 1 pages +} +bind TreeCtrl { + %W xview moveto 0 +} +bind TreeCtrl { + %W xview moveto 1 +} +bind TreeCtrl { + TreeCtrl::SetActiveItem %W [%W item id {first visible state enabled}] +} +bind TreeCtrl { + TreeCtrl::DataExtend %W [%W item id {first visible state enabled}] +} +bind TreeCtrl { + TreeCtrl::SetActiveItem %W [%W item id {last visible state enabled}] +} +bind TreeCtrl { + TreeCtrl::DataExtend %W [%W item id {last visible state enabled}] +} +bind TreeCtrl <> { + if {[string equal [selection own -displayof %W] "%W"]} { + clipboard clear -displayof %W + clipboard append -displayof %W [selection get -displayof %W] + } +} +bind TreeCtrl { + TreeCtrl::BeginSelect %W [%W item id active] +} +bind TreeCtrl { + TreeCtrl::BeginSelect %W [%W item id active] +} +bind TreeCtrl { + TreeCtrl::BeginExtend %W [%W item id active] +} +bind TreeCtrl { + TreeCtrl::BeginExtend %W [%W item id active] +} +bind TreeCtrl { + TreeCtrl::Cancel %W +} +bind TreeCtrl { + TreeCtrl::SelectAll %W +} +bind TreeCtrl { + if {[string compare [%W cget -selectmode] "browse"]} { + %W selection clear + } +} + +bind TreeCtrl { + %W item expand [%W item id active] +} +bind TreeCtrl { + %W item collapse [%W item id active] +} +bind TreeCtrl { + %W item toggle [%W item id active] +} + + +# Additional Tk bindings that aren't part of the Motif look and feel: + +bind TreeCtrl { + focus %W + TreeCtrl::ScanMark %W %x %y +} +bind TreeCtrl { + TreeCtrl::ScanDrag %W %x %y +} + +if {$tcl_platform(platform) eq "windows"} { + bind TreeCtrl { + TreeCtrl::ScanMark %W %x %y + } + bind TreeCtrl { + TreeCtrl::ScanDrag %W %x %y + } +} +if {[string equal [tk windowingsystem] "aqua"]} { + # Middle mouse on Mac OSX + bind TreeCtrl { + TreeCtrl::ScanMark %W %x %y + } + bind TreeCtrl { + TreeCtrl::ScanDrag %W %x %y + } +} + +# MouseWheel +if {[string equal "x11" [tk windowingsystem]]} { + # Support for mousewheels on Linux/Unix commonly comes through mapping + # the wheel to the extended buttons. If you have a mousewheel, find + # Linux configuration info at: + # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ + + # with recent Tk, use the binding of ttk::treeview + bind TreeCtrl [bind Treeview ] + bind TreeCtrl [bind Treeview ] + + bind TreeCtrl <4> { + if {!$tk_strictMotif} { + %W yview scroll -5 units + } + } + bind TreeCtrl { + if {!$tk_strictMotif} { + %W xview scroll -5 units + } + } + bind TreeCtrl <5> { + if {!$tk_strictMotif} { + %W yview scroll 5 units + } + } + bind TreeCtrl { + if {!$tk_strictMotif} { + %W xview scroll 5 units + } + } +} elseif {[string equal [tk windowingsystem] "aqua"]} { + bind TreeCtrl { + %W yview scroll [expr {- (%D)}] units + } + bind TreeCtrl { + %W yview scroll [expr {-10 * (%D)}] units + } + bind TreeCtrl { + %W xview scroll [expr {- (%D)}] units + } + bind TreeCtrl { + %W xview scroll [expr {-10 * (%D)}] units + } +} else { + bind TreeCtrl { + %W yview scroll [expr {- (%D / 120) * 4}] units + } + bind TreeCtrl { + %W xview scroll [expr {- (%D / 120) * 4}] units + } +} + +namespace eval ::TreeCtrl { + variable Priv + array set Priv { + prev {} + } + + if {[info procs ::lassign] eq ""} { + proc lassign {values args} { + uplevel 1 [list foreach $args [linsert $values end {}] break] + lrange $values [llength $args] end + } + } +} + +# Retrieve filelist bindings from this dir +source [file join [file dirname [info script]] filelist-bindings.tcl] + +# ::TreeCtrl::ColumnCanResizeLeft -- +# +# Return 1 if the given column should be resized by the left edge. +# +# Arguments: +# w The treectrl widget. +# column The column. + +proc ::TreeCtrl::ColumnCanResizeLeft {w column} { + if {[$w column cget $column -lock] eq "right"} { + return 1 + } + return 0 +} + +# ::TreeCtrl::ColumnCanMoveHere -- +# +# Return 1 if the given column can be moved before another. +# +# Arguments: +# w The treectrl widget. +# column The column. +# before The column to place 'column' before. + +proc ::TreeCtrl::ColumnCanMoveHere {w column before} { + if {[$w column compare $column == $before] || + ([$w column order $column] == [$w column order $before] - 1)} { + return 0 + } + set lock [$w column cget $column -lock] + return [expr {[$w column compare $before >= "first lock $lock"] && + [$w column compare $before <= "last lock $lock next"]}] +} + +# ::TreeCtrl::ColumnDragFindBefore -- +# +# This is called when dragging a column header. The result is 1 if the given +# coordinates are near a column header before which the dragged column can +# be moved. +# +# Arguments: +# w The treectrl widget. +# x Window x-coord. +# y Window y-coord. +# dragColumn The column being dragged. +# indColumn_ Out: what to set -indicatorcolumn to. +# indSide_ Out: what to set -indicatorside to. + +proc ::TreeCtrl::ColumnDragFindBefore {w x y dragColumn indColumn_ indSide_} { + upvar $indColumn_ indColumn + upvar $indSide_ indSide + + set lock [$w column cget $dragColumn -lock] + scan [$w bbox header.$lock] "%d %d %d %d" minX y1 maxX y2 + if {$x < $minX} { + set x $minX + } + if {$x >= $maxX} { + set x [expr {$maxX - 1}] + } + $w identify -array id $x $y + if {$id(where) ne "header"} { + return 0 + } + set indColumn $id(column) + if {[$w column compare $indColumn == $dragColumn]} { + return 0 + } + + # The given $x is either the left edge or the right edge of the column + # header that is being dragged depending on which direction the user + # is dragging the column. + # When dragging to the left, the indicator column is chosen to be the + # leftmost column whose mid-way point is greater than the left edge of the + # dragged header. + # When dragging to the right, the indicator column is chosen to be the + # rightmost column whose mid-way point is less than the right edge of the + # dragged header. + if {[$w column compare $indColumn != "tail"]} { + variable Priv + scan [$w header bbox $Priv(header) $indColumn] "%d %d %d %d" x1 y1 x2 y2 + # Hack - ignore canvaspadx + if {[$w column cget $indColumn -lock] eq "none" && + [$w column compare $indColumn == "first visible lock none"]} { + incr x1 [lindex [$w cget -canvaspadx] 0] + } + if {[$w column compare $dragColumn < $indColumn]} { + if {$x < $x1 + ($x2 - $x1) / 2} { + set indColumn [$w column id "$indColumn prev visible"] + set indColumn [GetSpanStartColumn $w $Priv(header) $indColumn] + } + } else { + if {$x > $x1 + ($x2 - $x1) / 2} { + # Find the column at the start of the next visible span + set starts [GetSpanStarts $w $Priv(header)] + for {set i [$w column order $indColumn]} {true} {incr i} { + if {[$w column compare [lindex $starts $i] > $indColumn]} break + } + set indColumn [lindex $starts $i] + } + } + } + + set before $indColumn + set prev [$w column id "$dragColumn prev visible"] + set next [$w column id "$dragColumn next visible"] + if {[$w column compare $indColumn == "tail"]} { + set indSide left + set indColumn [$w column id "last lock none visible"] + set indSide right + } elseif {$prev ne "" && [$w column compare $prev == $indColumn]} { + set indSide left + } elseif {$next ne "" && [$w column compare $next == $indColumn]} { + set before [$w column id "$indColumn next visible"] + set indSide right + } else { + scan [$w column bbox $indColumn] "%d %d %d %d" x1 y1 x2 y2 + if {$x < $x1 + ($x2 - $x1) / 2} { + set indSide left + } else { + set before [$w column id "$indColumn next visible"] + set indSide right + } + } + if {$before eq "" || [$w column compare $before > "last lock $lock next"]} { + set before [$w column id "last lock $lock next"] + } + return [ColumnCanMoveHere $w $dragColumn $before] +} + +# ::TreeCtrl::ListElementWindows -- +# +# Return a list of Tk windows in window elements in a column header. +# +# Arguments: +# T The treectrl widget. +# H Header id +# C Column id + +proc ::TreeCtrl::ListElementWindows {T H C} { + set S [$T header style set $H $C] + if {$S eq ""} return + set result {} + foreach E [$T header style elements $H $C] { + if {[$T element type $E] eq "window"} { + set window [$T header element cget $H $C $E -window] + if {$window ne ""} { + lappend result $window + } + } + } + return $result +} + +# ::TreeCtrl::ColumnDragRestackWindows -- +# +# Restack windows in window elements so that windows in dragged headers +# are above all other windows in undragged headers. +# +# Arguments: +# T The treectrl widget. + +proc ::TreeCtrl::ColumnDragRestackWindows {T} { + variable Priv + set C [$T header dragcget -imagecolumn] + set lock [$T column cget $C -lock] + set span [$T header dragcget -imagespan] + set last [$T column id [list $C span $span]] + set dragged [$T column id [list range $C $last]] + foreach H [$T header id all] { + set prev "" + set lowest "" + foreach C $dragged { + foreach win [ListElementWindows $T $H $C] { + if {$prev eq ""} { + set lowest $win + } else { + raise $win $prev + } + set prev $win + } + } + if {$lowest eq ""} continue + foreach C [$T column id "lock $lock !tail"] { + if {[lsearch -exact $dragged $C] != -1} continue + foreach win [ListElementWindows $T $H $C] { + lower $win $lowest + } + } + } + return +} + +# ::TreeCtrl::CursorAction -- +# +# If the given point is at the left or right edge of a resizable column +# header, the result is "action header-resize header H column C". +# If the given point is in a header with -button=TRUE, the result is +# "action header-button header H column C". +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::CursorAction {w x y var_} { + upvar $var_ var + variable Priv + $w identify -array id $x $y + + set var(action) "" + if {$id(where) eq "header"} { + set var(header) $id(header) + set column $id(column) + set side $id(side) + if {$side eq ""} { + if {[scan [$w bbox header.left] "%d %d %d %d" x1 y1 x2 y2] == 4} { + if {$x < $x2 + 4 && $x >= $x2} { + set column [$w column id "last visible lock left"] + set side right + } + } + if {[scan [$w bbox header.right] "%d %d %d %d" x1 y1 x2 y2] == 4} { + if {$x >= $x1 - 4 && $x < $x1} { + set column [$w column id "first visible lock right"] + set side left + } + } + } + if {$side eq "left"} { + if {[ColumnCanResizeLeft $w $column]} { + if {[$w column cget $column -resize]} { + array set var [list action "header-resize" column $column] + return + } + } else { + # Resize the previous column + if {[$w column compare $column == tail]} { + set prev [$w column id "last visible lock none"] + if {$prev eq ""} { + set prev [$w column id "last visible lock left"] + } + } else { + set prev [$w column id "$column prev visible"] + } + if {$prev ne "" && [$w column cget $prev -resize]} { + array set var [list action "header-resize" column $prev] + return + } + } + } elseif {$side eq "right"} { + # Get the last visible column in the span + set span [$w header span $id(header) $column] + set last [$w column id "$column span $span"] + set columns [$w column id [list range $column $last visible]] + set column2 [lindex $columns end] + if {[ColumnCanResizeLeft $w $column2]} { + # Resize the next column + set next [$w column id "$column2 next visible !tail"] + if {$next ne "" && [$w column cget $next -resize]} { + array set var [list action "header-resize" column $next] + return + } + } else { + if {[$w column cget $column2 -resize]} { + array set var [list action "header-resize" column $column2] + return + } + } + } + if {[$w column compare $column == "tail"]} { + # Can't -resize or -button the tail column + } elseif {[$w header cget $id(header) $column -button]} { + array set var [list action "header-button" column $column] + return + } + } + return +} + +# ::TreeCtrl::CursorCheck -- +# +# Sees if the given pointer coordinates are near the edge of a resizable +# column in the header. If so and the treectrl's cursor is not already +# set to sb_h_double_arrow, then the current cursor is saved and changed +# to sb_h_double_arrow, and an [after] callback to CursorCheckAux is +# scheduled. +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::CursorCheck {w x y} { + variable Priv + CursorAction $w $x $y action + # If we are in the middle of resizing a column, don't cancel the cursor + if {[info exists Priv(buttonMode)] && $Priv(buttonMode) eq "resize"} { + array set action {action "header-resize" header XXX column XXX} + } + if {$action(action) ne "header-resize"} { + CursorCancel $w + return + } + set cursor sb_h_double_arrow + if {$cursor ne [$w cget -cursor]} { + if {![info exists Priv(cursor,$w)]} { + set Priv(cursor,$w) [$w cget -cursor] + } + $w configure -cursor $cursor + } + if {[info exists Priv(cursor,afterId,$w)]} { + after cancel $Priv(cursor,afterId,$w) + } + set Priv(cursor,afterId,$w) [after 150 [list TreeCtrl::CursorCheckAux $w]] + return +} + +# ::TreeCtrl::CursorCheckAux -- +# +# Get's the location of the pointer and calls CursorCheck if the treectrl's +# cursor was previously set to sb_h_double_arrow. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::CursorCheckAux {w} { + variable Priv + if {![winfo exists $w]} return + set x [winfo pointerx $w] + set y [winfo pointery $w] + if {[info exists Priv(cursor,$w)]} { + set x [expr {$x - [winfo rootx $w]}] + set y [expr {$y - [winfo rooty $w]}] + CursorCheck $w $x $y + } + return +} + +# ::TreeCtrl::CursorCancel -- +# +# Restores the treectrl's cursor if it was changed to sb_h_double_arrow. +# Cancels any pending [after] callback to CursorCheckAux. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::CursorCancel {w} { + variable Priv + if {[info exists Priv(cursor,$w)]} { + $w configure -cursor $Priv(cursor,$w) + unset Priv(cursor,$w) + } + if {[info exists Priv(cursor,afterId,$w)]} { + after cancel $Priv(cursor,afterId,$w) + unset Priv(cursor,afterId,$w) + } + return +} + +# ::TreeCtrl::GetSpanStarts -- +# +# This procedure returns a list of column ids, one per tree column. +# Each column id indicates the column at the start of a span. +# +# Arguments: +# T The treectrl widget. +# H Header id + +proc ::TreeCtrl::GetSpanStarts {T H} { + set columns [list] + set spans [$T header span $H] + if {[lindex [lsort -integer $spans] end] eq 1} { + return [$T column list] + } + for {set index 0} {$index < [$T column count]} {} { + set Cspan [$T column id "order $index"] + set span [lindex $spans $index] + if {![$T column cget $Cspan -visible]} { + set span 1 + } + while {$span > 0 && $index < [$T column count]} { + if {[$T column cget "order $index" -lock] ne [$T column cget $Cspan -lock]} break + lappend columns $Cspan + incr span -1 + incr index + } + } + return $columns +} + +# ::TreeCtrl::GetSpanStartColumn -- +# +# This procedure returns the column at the start of a span which covers the +# given column. +# +# Arguments: +# T The treectrl widget. +# H Header id +# C Column id + +proc ::TreeCtrl::GetSpanStartColumn {T H C} { + set columns [GetSpanStarts $T $H] + return [lindex $columns [$T column order $C]] +} + +# ::TreeCtrl::SetHeaderState -- +# +# This procedure sets the state of a header-column and remembers that +# header-column. If a different header-column is passed later the previous +# header-column's state is set to 'normal'. +# +# Arguments: +# T The treectrl widget. +# H Header id +# C Column id +# state active|normal|pressed + +proc ::TreeCtrl::SetHeaderState {T H C state} { + variable Priv + if {[info exists Priv(inheader,$T)]} { + lassign $Priv(inheader,$T) Hprev Cprev + } else { + if {$H eq "" || $C eq ""} return + set Hprev [set Cprev ""] + } + if {$H ne $Hprev || $C ne $Cprev} { + if {$Hprev ne "" && [$T header id $Hprev] ne ""} { + if {$Cprev ne "" && [$T column id $Cprev] ne ""} { + $T header configure $Hprev $Cprev -state normal + TryEvent $T Header state [list H $Hprev C $Cprev s normal] + } + } + } + if {$H eq "" || $C eq ""} { + unset Priv(inheader,$T) + } else { + $T header configure $H $C -state $state + TryEvent $T Header state [list H $H C $C s $state] + set Priv(inheader,$T) [list $H $C] + } + return +} + +# ::TreeCtrl::ClearHeaderState -- +# +# If a header-column's state was previously set via SetHeaderState then +# that column's state is set to normal and the header-column is forgotten. +# +# Arguments: +# T The treectrl widget. +# H Header id +# C Column id +# state active|normal|pressed + +proc ::TreeCtrl::ClearHeaderState {T} { + SetHeaderState $T "" "" "" + return +} + +# ::TreeCtrl::MotionInHeader -- +# +# This procedure updates the active/normal states of column headers as the +# mouse pointer moves in and out of them. Typically this results in visual +# feedback by changing the appearance of the headers. +# +# Arguments: +# w The treectrl widget. +# args x y coords if the pointer is in the window, or an empty list. + +proc ::TreeCtrl::MotionInHeader {w args} { + variable Priv + if {[llength $args]} { + set x [lindex $args 0] + set y [lindex $args 1] + CursorAction $w $x $y action + } else { + array set action {action ""} + } + if {[info exists Priv(inheader,$w)]} { + lassign $Priv(inheader,$w) headerPrev columnPrev + } else { + set headerPrev [set columnPrev ""] + } + set header "" + set column "" + if {$action(action) eq "header-button"} { + set header $action(header) + set column $action(column) + } elseif {$action(action) eq "header-resize"} { + set header $action(header) + set column [GetSpanStartColumn $w $header $action(column)] + } + if {$header ne $headerPrev || $column ne $columnPrev} { + if {$column ne ""} { + SetHeaderState $w $header $column active + } else { + ClearHeaderState $w + } + } + return +} + +# ::TreeCtrl::MotionInButtons -- +# +# This procedure updates the active/normal states of item buttons. +# Typically this results in visual feedback by changing the appearance +# of the buttons. +# +# Arguments: +# T The treectrl widget. +# args x y coords if the pointer is in the window, or an empty list. + +proc ::TreeCtrl::MotionInButtons {T args} { + variable Priv + set button "" + if {[llength $args]} { + set x [lindex $args 0] + set y [lindex $args 1] + $T identify -array id $x $y + if {$id(where) eq "item" && $id(button)} { + set button $id(item) + } + } + if {[info exists Priv(inbutton,$T)]} { + set prevButton $Priv(inbutton,$T) + } else { + set prevButton "" + } + if {$button ne $prevButton} { + if {$prevButton ne ""} { + if {[$T item id $prevButton] ne ""} { + $T item buttonstate $prevButton normal + } + } + if {$button ne ""} { + $T item buttonstate $button active + set Priv(inbutton,$T) $button + } else { + unset Priv(inbutton,$T) + } + } + if {[$T notify bind TreeCtrlButtonNotifyScroll] eq ""} { + $T notify bind TreeCtrlButtonNotifyScroll { + TreeCtrl::ButtonNotifyScroll %T + } + } + return +} + +# ::TreeCtrl::ButtonNotifyScroll -- +# +# Called when a event occurs and a button is in the active state. +# Finds the mouse pointer coords and calls MotionInButtons to update the +# state of affected buttons. +# +# Arguments: +# T The treectrl widget. + +proc ::TreeCtrl::ButtonNotifyScroll {T} { + set x [expr {[winfo pointerx $T] - [winfo rootx $T]}] + set y [expr {[winfo pointery $T] - [winfo rooty $T]}] + MotionInButtons $T $x $y + return +} + +# ::TreeCtrl::ButtonPress1 -- +# +# Handle event. +# +# Arguments: +# w The treectrl widget. +# x Window x coord. +# y Window y coord. + +proc ::TreeCtrl::ButtonPress1 {w x y} { + variable Priv + focus $w + + $w identify -array id $x $y + if {$id(where) eq ""} { + return + } + + if {$id(where) eq "item"} { + set item $id(item) + if {$id(button)} { + if {[$w cget -buttontracking]} { + $w item buttonstate $item pressed + set Priv(buttonMode) buttonTracking + set Priv(buttontrack,item) $item + } else { + $w item toggle $item -animate + } + return + } elseif {$id(line) ne ""} { + $w item toggle $id(line) + return + } + } + set Priv(buttonMode) "" + if {$id(where) eq "header"} { + CursorAction $w $x $y action + if {$action(action) eq "header-resize"} { + set column $action(column) + set Priv(buttonMode) resize + set Priv(header) $action(header) + set Priv(column) $column + set Priv(x) $x + set Priv(y) $y + set Priv(width) [$w column width $column] + return + } + set column $id(column) + if {$action(action) eq "header-button"} { + set Priv(buttonMode) header + SetHeaderState $w $action(header) $column pressed + } else { + if {[$w column compare $column == "tail"]} return + if {![$w header dragcget -enable]} return + if {![$w header dragcget $action(header) -enable]} return + set Priv(buttonMode) dragColumnWait + } + set Priv(header) $action(header) + set Priv(column) $column + set Priv(columnDrag,x) $x + set Priv(columnDrag,y) $y + return + } + set item $id(item) + if {![$w item enabled $item]} { + return + } + + # If the initial mouse-click is in a locked column, restrict scrolling + # to the vertical. + set count [scan [$w contentbox] "%d %d %d %d" x1 y1 x2 y2] + if {$count != -1 && $x >= $x1 && $x < $x2} { + set Priv(autoscan,direction,$w) xy + } else { + set Priv(autoscan,direction,$w) y + } + + set Priv(buttonMode) normal + BeginSelect $w $item + return +} + +# ::TreeCtrl::DoubleButtonPress1 -- +# +# Handle event. +# +# Arguments: +# w The treectrl widget. +# x Window x coord. +# y Window y coord. + +proc ::TreeCtrl::DoubleButton1 {w x y} { + + $w identify -array id $x $y + if {$id(where) eq ""} { + return + } + if {$id(where) eq "item"} { + if {$id(button)} { + if {[$w cget -buttontracking]} { + # There is no so just toggle it + $w item toggle $id(item) -animate + } else { + $w item toggle $id(item) -animate + } + return + } elseif {$id(line) ne ""} { + $w item toggle $id(line) + return + } + } + if {$id(where) eq "header"} { + CursorAction $w $x $y action + # Double-click between columns to set default column width + if {$action(action) eq "header-resize"} { + set column $action(column) + $w column configure $column -width "" + CursorCheck $w $x $y + MotionInHeader $w $x $y + } else { + ButtonPress1 $w $x $y + } + } + return +} + +# ::TreeCtrl::Motion1 -- +# +# Handle event. +# +# Arguments: +# w The treectrl widget. +# x Window x coord. +# y Window y coord. + +proc ::TreeCtrl::Motion1 {w x y} { + variable Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + header { + $w identify -array id $x $y + if {$id(where) ne "header" || + $id(header) ne $Priv(header) || + $id(column) ne $Priv(column)} { + if {[$w header cget $Priv(header) $Priv(column) -state] eq "pressed"} { + ClearHeaderState $w + } + } else { + if {[$w header cget $Priv(header) $Priv(column) -state] ne "pressed"} { + SetHeaderState $w $Priv(header) $Priv(column) pressed + } + if {[$w header dragcget -enable] && + [$w header dragcget $Priv(header) -enable] && + (abs($Priv(columnDrag,x) - $x) > 4)} { + set Priv(columnDrag,x) $x + $w header dragconfigure \ + -imagecolumn $Priv(column) \ + -imageoffset [expr {$x - $Priv(columnDrag,x)}] \ + -imagespan [$w header span $Priv(header) $Priv(column)] + ColumnDragRestackWindows $w + set Priv(buttonMode) dragColumn + TryEvent $w ColumnDrag begin [list H $Priv(header) C $Priv(column)] + # Allow binding scripts to cancel the drag + if {[$w header dragcget -imagecolumn] eq ""} { + set Priv(buttonMode) header + } + } + } + } + buttonTracking { + $w identify -array id $x $y + set itemTrack $Priv(buttontrack,item) + set exists [expr {[$w item id $itemTrack] ne ""}] + set mouseover 0 + if {$id(where) eq "item" && $id(button)} { + if {$exists && [$w item compare $itemTrack == $id(item)]} { + set mouseover 1 + } + } + if {$mouseover} { + $w item buttonstate $itemTrack pressed + } elseif {$exists} { + $w item buttonstate $itemTrack normal + } + } + dragColumnWait { + if {(abs($Priv(columnDrag,x) - $x) > 4)} { + set Priv(columnDrag,x) $x + $w header dragconfigure \ + -imagecolumn $Priv(column) \ + -imageoffset [expr {$x - $Priv(columnDrag,x)}] \ + -imagespan [$w header span $Priv(header) $Priv(column)] + ColumnDragRestackWindows $w + set Priv(buttonMode) dragColumn + TryEvent $w ColumnDrag begin [list H $Priv(header) C $Priv(column)] + # Allow binding scripts to cancel the drag + if {[$w header dragcget -imagecolumn] eq ""} { + unset Priv(buttonMode) + } + } + } + dragColumn { + scan [$w bbox header] "%d %d %d %d" x1 y1 x2 y2 + if {$y < $y1 - 30 || $y >= $y2 + 30} { + set inside 0 + } else { + set inside 1 + } + if {$inside && ([$w header dragcget -imagecolumn] eq "")} { + $w header dragconfigure -imagecolumn $Priv(column) + } elseif {!$inside && ([$w header dragcget -imagecolumn] ne "")} { + $w header dragconfigure -imagecolumn "" -indicatorcolumn "" + } + if {$inside} { + set offset [expr {$x - $Priv(columnDrag,x)}] + $w header dragconfigure -imageoffset $offset + + # When dragging to the left, use the left edge of the dragged + # header to choose the -indicatorcolumn. When dragging to the + # right, use the right edge. + scan [$w header bbox $Priv(header) $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 + if {$offset > 0} { + set xEdge [expr {$offset + $x2}] + } else { + set xEdge [expr {$offset + $x1}] + } + + if {[ColumnDragFindBefore $w $xEdge $Priv(columnDrag,y) $Priv(column) indColumn indSide]} { + set prevIndColumn [$w header dragcget -indicatorcolumn] + $w header dragconfigure \ + -indicatorcolumn $indColumn \ + -indicatorside $indSide \ + -indicatorspan [$w header span $Priv(header) $indColumn] + if {$indColumn != $prevIndColumn} { + TryEvent $w ColumnDrag indicator [list H $Priv(header) C $indColumn] + } + } else { + $w header dragconfigure -indicatorcolumn "" + } + } + if {[$w column cget $Priv(column) -lock] eq "none"} { + ColumnDragScrollCheck $w $x $y + } + } + normal { + set Priv(x) $x + set Priv(y) $y + SelectionMotion $w [$w item id [list nearest $x $y]] + set Priv(autoscan,command,$w) {SelectionMotion %T [%T item id "nearest %x %y"]} + AutoScanCheck $w $x $y + } + resize { + if {[ColumnCanResizeLeft $w $Priv(column)]} { + set width [expr {$Priv(width) + $Priv(x) - $x}] + } else { + set width [expr {$Priv(width) + $x - $Priv(x)}] + } + set minWidth [$w column cget $Priv(column) -minwidth] + set maxWidth [$w column cget $Priv(column) -maxwidth] + if {$minWidth eq ""} { + set minWidth 0 + } + if {$width < $minWidth} { + set width $minWidth + } + if {($maxWidth ne "") && ($width > $maxWidth)} { + set width $maxWidth + } + if {$width == 0} { + incr width + } + switch -- [$w cget -columnresizemode] { + proxy { + scan [$w column bbox $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 + if {[ColumnCanResizeLeft $w $Priv(column)]} { + # Use "ne" because -columnproxy could be "" + if {$x2 - $width ne [$w cget -columnproxy]} { + $w configure -columnproxy [expr {$x2 - $width}] + } + } else { + if {($x1 + $width - 1) ne [$w cget -columnproxy]} { + $w configure -columnproxy [expr {$x1 + $width - 1}] + } + } + } + realtime { + if {[$w column cget $Priv(column) -width] != $width} { + $w column configure $Priv(column) -width $width + } + } + } + } + } + return +} + +# ::TreeCtrl::Leave1 -- +# +# Handle event. +# +# Arguments: +# w The treectrl widget. +# x Window x coord. +# y Window y coord. + +proc ::TreeCtrl::Leave1 {w x y} { + variable Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + header { + if {[$w header cget $Priv(header) $Priv(column) -state] eq "pressed"} { + ClearHeaderState $w + } + } + } + return +} + +# ::TreeCtrl::Enter1 -- +# +# Handle event. +# +# Arguments: +# w The treectrl widget. +# x Window x coord. +# y Window y coord. + +proc ::TreeCtrl::Enter1 {w x y} { + variable Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + default {} + } + return +} + +# ::TreeCtrl::Release1 -- +# +# Handle event. +# +# Arguments: +# w The treectrl widget. +# x Window x coord. +# y Window y coord. + +proc ::TreeCtrl::Release1 {w x y} { + variable Priv + if {![info exists Priv(buttonMode)]} return + switch $Priv(buttonMode) { + header { + if {[$w header cget $Priv(header) $Priv(column) -state] eq "pressed"} { + SetHeaderState $w $Priv(header) $Priv(column) active + TryEvent $w Header invoke [list H $Priv(header) C $Priv(column)] + } + CursorCheck $w $x $y + MotionInHeader $w $x $y + } + buttonTracking { + $w identify -array id $x $y + set itemTrack $Priv(buttontrack,item) + set exists [expr {[$w item id $itemTrack] ne ""}] + if {$id(where) eq "item" && $id(button)} { + if {$exists && [$w item compare $itemTrack == $id(item)]} { + $w item buttonstate $id(item) active + $w item toggle $itemTrack -animate + } + } + } + dragColumn { + AutoScanCancel $w + ClearHeaderState $w + if {[$w header dragcget -imagecolumn] ne ""} { + set visible 1 + } else { + set visible 0 + } + set column [$w header dragcget -indicatorcolumn] + $w header dragconfigure -imagecolumn "" -indicatorcolumn "" + if {$visible && ($column ne "")} { + # If dragging to the right, drop after the last column in the + # span of the indicator column. + if {[$w column order $Priv(column)] < [$w column order $column]} { + set span [$w header dragcget -indicatorspan] + set column [$w column id "$column span $span next"] + } + set lock [$w column cget $Priv(column) -lock] + if {$column eq "" || [$w column compare $column > "last lock $lock next"]} { + set column [$w column id "last lock $lock next"] + } + TryEvent $w ColumnDrag receive [list H $Priv(header) C $Priv(column) b $column] + } + CursorCheck $w $x $y + MotionInHeader $w $x $y + TryEvent $w ColumnDrag end [list H $Priv(header) C $Priv(column)] + } + normal { + AutoScanCancel $w + set nearest [$w item id [list nearest $x $y]] + if {$nearest ne ""} { + $w activate $nearest + } +set Priv(prev) "" + } + resize { + if {[$w cget -columnproxy] ne ""} { + scan [$w column bbox $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 + if {[ColumnCanResizeLeft $w $Priv(column)]} { + set width [expr {$x2 - [$w cget -columnproxy]}] + } else { + set width [expr {[$w cget -columnproxy] - $x1 + 1}] + } + $w configure -columnproxy {} + $w column configure $Priv(column) -width $width + } + # Clear buttonMode early so CursorCheck doesn't exit + unset Priv(buttonMode) + CursorCheck $w $x $y + MotionInHeader $w $x $y + return + } + } + unset Priv(buttonMode) + return +} + +# ::TreeCtrl::BeginSelect -- +# +# This procedure is typically invoked on button-1 presses. It begins +# the process of making a selection in the treectrl. Its exact behavior +# depends on the selection mode currently in effect for the treectrl. +# +# Arguments: +# w The treectrl widget. +# item The item for the selection operation (typically the +# one under the pointer). + +proc ::TreeCtrl::BeginSelect {w item} { + variable Priv + if {$item eq ""} return + if {[string equal [$w cget -selectmode] "multiple"]} { + if {[$w selection includes $item]} { + $w selection clear $item + } else { + $w selection add $item + } + } else { + $w selection anchor $item + $w selection modify $item all + set Priv(selection) {} + set Priv(prev) $item + } + return +} + +# ::TreeCtrl::SelectionMotion -- +# +# This procedure is called to process mouse motion events while +# button 1 is down. It may move or extend the selection, depending +# on the treectrl's selection mode. +# +# Arguments: +# w The treectrl widget. +# item- The item under the pointer. + +proc ::TreeCtrl::SelectionMotion {w item} { + variable Priv + + if {$item eq ""} return + set item [$w item id $item] + if {$item eq $Priv(prev)} return + if {![$w item enabled $item]} return + + switch [$w cget -selectmode] { + browse { + $w selection modify $item all + set Priv(prev) $item + } + extended { + set i $Priv(prev) + set select {} + set deselect {} + if {$i eq ""} { + set i $item + lappend select $item + set hack [$w item compare $item == anchor] + } else { + set hack 0 + } + if {[$w selection includes anchor] || $hack} { + set deselect [concat $deselect [$w item range $i $item]] + set select [concat $select [$w item range anchor $item]] + } else { + set deselect [concat $deselect [$w item range $i $item]] + set deselect [concat $deselect [$w item range anchor $item]] + } + if {![info exists Priv(selection)]} { + set Priv(selection) [$w selection get] + } + while {[$w item compare $i < $item] && [$w item compare $i < anchor]} { + if {[lsearch $Priv(selection) $i] >= 0} { + lappend select $i + } + set i [$w item id "$i next visible"] + } + while {[$w item compare $i > $item] && [$w item compare $i > anchor]} { + if {[lsearch $Priv(selection) $i] >= 0} { + lappend select $i + } + set i [$w item id "$i prev visible"] + } + set Priv(prev) $item + $w selection modify $select $deselect + } + } + return +} + +# ::TreeCtrl::BeginExtend -- +# +# This procedure is typically invoked on shift-button-1 presses. It +# begins the process of extending a selection in the treectrl. Its +# exact behavior depends on the selection mode currently in effect +# for the treectrl. +# +# Arguments: +# w The treectrl widget. +# item- The item for the selection operation (typically the +# one under the pointer). + +proc ::TreeCtrl::BeginExtend {w item} { + if {[string equal [$w cget -selectmode] "extended"]} { + if {[$w selection includes anchor]} { + SelectionMotion $w $item + } else { + # No selection yet; simulate the begin-select operation. + BeginSelect $w $item + } + } + return +} + +# ::TreeCtrl::BeginToggle -- +# +# This procedure is typically invoked on control-button-1 presses. It +# begins the process of toggling a selection in the treectrl. Its +# exact behavior depends on the selection mode currently in effect +# for the treectrl. +# +# Arguments: +# w The treectrl widget. +# item The item for the selection operation (typically the +# one under the pointer). + +proc ::TreeCtrl::BeginToggle {w item} { + variable Priv + if {$item eq ""} return + if {[string equal [$w cget -selectmode] "extended"]} { + set Priv(selection) [$w selection get] + set Priv(prev) $item + $w selection anchor $item + if {[$w selection includes $item]} { + $w selection clear $item + } else { + $w selection add $item + } + } + return +} + +# ::TreeCtrl::AutoScanCheck -- +# +# Sees if the given pointer coords are outside the content area of the +# treectrl (ie, not including borders or column headers) or within +# -scrollmargin distance of the edges of the content area. If so and +# auto-scanning is not already in progress, then the window is scrolled +# and an [after] callback to AutoScanCheckAux is scheduled. +# +# Arguments: +# w The treectrl widget. +# x Window x coord. +# y Window y coord. + +proc ::TreeCtrl::AutoScanCheck {w x y} { + variable Priv + # Could have clicked in locked column + if {[scan [$w contentbox] "%d %d %d %d" x1 y1 x2 y2] == -1} { + if {[scan [$w bbox left] "%d %d %d %d" x1 y1 x2 y2] == -1} { + scan [$w bbox right] "%d %d %d %d" x1 y1 x2 y2 + } + } + set margin [winfo pixels $w [$w cget -scrollmargin]] + if {![info exists Priv(autoscan,direction,$w)]} { + set Priv(autoscan,direction,$w) xy + } + set scrollX [string match *x* $Priv(autoscan,direction,$w)] + set scrollY [string match *y* $Priv(autoscan,direction,$w)] + if {($scrollX && (($x < $x1 + $margin) || ($x >= $x2 - $margin))) || + ($scrollY && (($y < $y1 + $margin) || ($y >= $y2 - $margin)))} { + if {[info exists Priv(autoscan,afterId,$w)]} return + if {$scrollY && $y >= $y2 - $margin} { + $w yview scroll 1 units + set delay [$w cget -yscrolldelay] + } elseif {$scrollY && $y < $y1 + $margin} { + $w yview scroll -1 units + set delay [$w cget -yscrolldelay] + } elseif {$scrollX && $x >= $x2 - $margin} { + $w xview scroll 1 units + set delay [$w cget -xscrolldelay] + } elseif {$scrollX && $x < $x1 + $margin} { + $w xview scroll -1 units + set delay [$w cget -xscrolldelay] + } + set count [scan $delay "%d %d" d1 d2] + if {[info exists Priv(autoscan,scanning,$w)]} { + if {$count == 2} { + set delay $d2 + } + } else { + if {$count == 2} { + set delay $d1 + } + set Priv(autoscan,scanning,$w) 1 + } + if {$Priv(autoscan,command,$w) ne ""} { + set command [string map [list %T $w %x $x %y $y] $Priv(autoscan,command,$w)] + eval $command + } + set Priv(autoscan,afterId,$w) [after $delay [list TreeCtrl::AutoScanCheckAux $w]] + return + } + AutoScanCancel $w + return +} + +# ::TreeCtrl::AutoScanCheckAux -- +# +# Gets the location of the pointer and calls AutoScanCheck. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::AutoScanCheckAux {w} { + variable Priv + if {![winfo exists $w]} return + # Not quite sure how this can happen + if {![info exists Priv(autoscan,afterId,$w)]} return + unset Priv(autoscan,afterId,$w) + set x [winfo pointerx $w] + set y [winfo pointery $w] + set x [expr {$x - [winfo rootx $w]}] + set y [expr {$y - [winfo rooty $w]}] + AutoScanCheck $w $x $y + return +} + +# ::TreeCtrl::AutoScanCancel -- +# +# Cancels any pending [after] callback to AutoScanCheckAux. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::AutoScanCancel {w} { + variable Priv + if {[info exists Priv(autoscan,afterId,$w)]} { + after cancel $Priv(autoscan,afterId,$w) + unset Priv(autoscan,afterId,$w) + } + unset -nocomplain Priv(autoscan,scanning,$w) + return +} + +# ::TreeCtrl::ColumnDragScrollCheck -- +# +# Sees if the given pointer coords are outside the left or right edges of +# the content area of the treectrl (ie, not including borders). If so and +# auto-scanning is not already in progress, then the window is scrolled +# horizontally and the column drag-image is repositioned, and an [after] +# callback to ColumnDragScrollCheckAux is scheduled. +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::ColumnDragScrollCheck {w x y} { + variable Priv + + # When dragging to the left, use the left edge of the dragged + # header to choose the -indicatorcolumn. When dragging to the + # right, use the right edge. + scan [$w header bbox $Priv(header) $Priv(column)] "%d %d %d %d" x1 y1 x2 y2 + set offset [$w header dragcget -imageoffset] + if {$offset > 0} { + set xEdge [expr {$offset + $x2}] + } else { + set xEdge [expr {$offset + $x1}] + } + + scan [$w bbox header.none] "%d %d %d %d" x1 y1 x2 y2 + + if {($x < $x1) || ($x >= $x2)} { + if {![info exists Priv(autoscan,afterId,$w)]} { + set bbox1 [$w column bbox $Priv(column)] + if {$xEdge >= $x2} { + $w xview scroll 1 units + } else { + $w xview scroll -1 units + } + set bbox2 [$w column bbox $Priv(column)] + if {[lindex $bbox1 0] != [lindex $bbox2 0]} { + incr Priv(columnDrag,x) [expr {[lindex $bbox2 0] - [lindex $bbox1 0]}] + $w header dragconfigure -imageoffset [expr {$x - $Priv(columnDrag,x)}] + + if {[ColumnDragFindBefore $w $xEdge $Priv(columnDrag,y) $Priv(column) indColumn indSide]} { + $w header dragconfigure -indicatorcolumn $indColumn \ + -indicatorside $indSide + } else { + $w header dragconfigure -indicatorcolumn "" + } + } + set Priv(autoscan,afterId,$w) [after 50 [list TreeCtrl::ColumnDragScrollCheckAux $w]] + } + return + } + AutoScanCancel $w + return +} + +# ::TreeCtrl::ColumnDragScrollCheckAux -- +# +# Gets the location of the pointer and calls ColumnDragScrollCheck. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::ColumnDragScrollCheckAux {w} { + variable Priv + if {![winfo exists $w]} return + # Not quite sure how this can happen + if {![info exists Priv(autoscan,afterId,$w)]} return + unset Priv(autoscan,afterId,$w) + set x [winfo pointerx $w] + set y [winfo pointery $w] + set x [expr {$x - [winfo rootx $w]}] + set y [expr {$y - [winfo rooty $w]}] + ColumnDragScrollCheck $w $x $y + return +} + +# ::TreeCtrl::Has2DLayout -- +# +# Determine if items are displayed in a 2-dimensional arrangement. +# This is used by the and bindings. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::Has2DLayout {T} { + if {[$T cget -orient] ne "vertical" || [$T cget -wrap] ne ""} { + return 1 + } + set item [$T item id "last visible"] + if {$item ne ""} { + lassign [$T item rnc $item] row column + if {$column > 0} { + return 1 + } + } + return 0 +} + +# ::TreeCtrl::UpDown -- +# +# Returns the id of an item above or below the given item that the active +# item could be set to. If the given item isn't visible, the first visible +# enabled item is returned. An attempt is made to choose an item in the +# same column over repeat calls; this gives a better result if some rows +# have less items than others. Only enabled items are considered. +# +# Arguments: +# w The treectrl widget. +# item Item to move from, typically the active item. +# n +1 to move down, -1 to move up. + +proc ::TreeCtrl::UpDown {w item n} { + variable Priv + set rnc [$w item rnc $item] + if {$rnc eq ""} { + return [$w item id {first visible state enabled}] + } + scan $rnc "%d %d" row col + set Priv(keyNav,row,$w) [expr {$row + $n}] + if {![info exists Priv(keyNav,rnc,$w)] || $rnc ne $Priv(keyNav,rnc,$w)} { + set Priv(keyNav,col,$w) $col + } + set item2 [$w item id "rnc $Priv(keyNav,row,$w) $Priv(keyNav,col,$w)"] + if {[$w item compare $item == $item2]} { + set Priv(keyNav,row,$w) $row + if {![$w item enabled $item2]} { + return "" + } + } else { + set Priv(keyNav,rnc,$w) [$w item rnc $item2] + if {![$w item enabled $item2]} { + return [UpDown $w $item2 $n] + } + } + return $item2 +} + +# ::TreeCtrl::LeftRight -- +# +# Returns the id of an item left or right of the given item that the active +# item could be set to. If the given item isn't visible, the first visible +# enabled item is returned. An attempt is made to choose an item in the +# same row over repeat calls; this gives a better result if some columns +# have less items than others. Only enabled items are considered. +# +# Arguments: +# w The treectrl widget. +# item Item to move from, typically the active item. +# n +1 to move right, -1 to move left. + +proc ::TreeCtrl::LeftRight {w item n} { + variable Priv + set rnc [$w item rnc $item] + if {$rnc eq ""} { + return [$w item id {first visible state enabled}] + } + scan $rnc "%d %d" row col + set Priv(keyNav,col,$w) [expr {$col + $n}] + if {![info exists Priv(keyNav,rnc,$w)] || $rnc ne $Priv(keyNav,rnc,$w)} { + set Priv(keyNav,row,$w) $row + } + set item2 [$w item id "rnc $Priv(keyNav,row,$w) $Priv(keyNav,col,$w)"] + if {[$w item compare $item == $item2]} { + set Priv(keyNav,col,$w) $col + if {![$w item enabled $item2]} { + return "" + } + } else { + set Priv(keyNav,rnc,$w) [$w item rnc $item2] + if {![$w item enabled $item2]} { + return [LeftRight $w $item2 $n] + } + } + return $item2 +} + +# ::TreeCtrl::SetActiveItem -- +# +# Sets the active item, scrolls it into view, and makes it the only selected +# item. If -selectmode is extended, makes the active item the anchor of any +# future extended selection. +# +# Arguments: +# w The treectrl widget. +# item The new active item, or "". + +proc ::TreeCtrl::SetActiveItem {w item} { + if {$item eq ""} return + $w activate $item + $w see active + $w selection modify active all + switch [$w cget -selectmode] { + extended { + $w selection anchor active + set Priv(prev) [$w item id active] + set Priv(selection) {} + } + } + return +} + +# ::TreeCtrl::Extend -- +# +# Does nothing unless we're in extended selection mode; in this +# case it moves the location cursor (active item) up, down, left or +# right, and extends the selection to that point. +# +# Arguments: +# w The treectrl widget. +# dir up, down, left or right + +proc ::TreeCtrl::Extend {w dir} { + variable Priv + if {[string compare [$w cget -selectmode] "extended"]} { + return + } + if {![info exists Priv(selection)]} { + $w selection add active + set Priv(selection) [$w selection get] + } + switch -- $dir { + above { set item [UpDown $w active -1] } + below { set item [UpDown $w active 1] } + left { set item [LeftRight $w active -1] } + right { set item [LeftRight $w active 1] } + } + if {$item eq ""} return + $w activate $item + $w see active + SelectionMotion $w [$w item id active] + return +} + +# ::TreeCtrl::DataExtend +# +# This procedure is called for key-presses such as Shift-KEndData. +# If the selection mode isn't multiple or extended then it does nothing. +# Otherwise it moves the active item and, if we're in +# extended mode, extends the selection to that point. +# +# Arguments: +# w The treectrl widget. +# item Item to become new active item. + +proc ::TreeCtrl::DataExtend {w item} { + if {$item eq ""} return + set mode [$w cget -selectmode] + if {[string equal $mode "extended"]} { + $w activate $item + $w see $item + if {[$w selection includes anchor]} { + SelectionMotion $w $item + } + } elseif {[string equal $mode "multiple"]} { + $w activate $item + $w see $item + } + return +} + +# ::TreeCtrl::Cancel +# +# This procedure is invoked to cancel an extended selection in +# progress. If there is an extended selection in progress, it +# restores all of the items between the active one and the anchor +# to their previous selection state. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::Cancel w { + variable Priv + if {[string compare [$w cget -selectmode] "extended"]} { + return + } + set first [$w item id anchor] + set last $Priv(prev) + if {[string equal $last ""] || [string equal [$w item id $last] ""]} { + # Not actually doing any selection right now + return + } + if {[$w item compare $first > $last]} { + set tmp $first + set first $last + set last $tmp + } + set select {} + set deselect {} + foreach item [$w item id "range $first $last visible"] { + if {[lsearch $Priv(selection) $item] == -1} { + lappend deselect $item + } else { + lappend select $item + } + } + $w selection modify $select $deselect + return +} + +# ::TreeCtrl::SelectAll +# +# This procedure is invoked to handle the "select all" operation. +# For single and browse mode, it just selects the active item. +# Otherwise it selects everything in the widget. +# +# Arguments: +# w The treectrl widget. + +proc ::TreeCtrl::SelectAll w { + set mode [$w cget -selectmode] + if {[string equal $mode "single"] || [string equal $mode "browse"]} { + $w selection modify active all + } else { + $w selection add all + } + return +} + +# ::TreeCtrl::MarqueeBegin -- +# +# Shows the selection rectangle at the given coords. +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::MarqueeBegin {w x y} { + set x [$w canvasx $x] + set y [$w canvasy $y] + $w marquee coords $x $y $x $y + $w marquee configure -visible yes + return +} + +# ::TreeCtrl::MarqueeUpdate -- +# +# Resizes the selection rectangle. +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::MarqueeUpdate {w x y} { + set x [$w canvasx $x] + set y [$w canvasy $y] + $w marquee corner $x $y + return +} + +# ::TreeCtrl::MarqueeEnd -- +# +# Hides the selection rectangle. +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::MarqueeEnd {w x y} { + $w marquee configure -visible no + return +} + +# ::TreeCtrl::ScanMark -- +# +# Marks the start of a possible scan drag operation. +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::ScanMark {w x y} { + variable Priv + $w scan mark $x $y + set Priv(x) $x + set Priv(y) $y + set Priv(mouseMoved) 0 + return +} + +# ::TreeCtrl::ScanDrag -- +# +# Performs a scan drag if the mouse moved. +# +# Arguments: +# w The treectrl widget. +# x Window coord of pointer. +# y Window coord of pointer. + +proc ::TreeCtrl::ScanDrag {w x y} { + variable Priv + if {![info exists Priv(x)]} { set Priv(x) $x } + if {![info exists Priv(y)]} { set Priv(y) $y } + if {($x != $Priv(x)) || ($y != $Priv(y))} { + set Priv(mouseMoved) 1 + } + if {[info exists Priv(mouseMoved)] && $Priv(mouseMoved)} { + $w scan dragto $x $y + } + return +} + +# ::TreeCtrl::TryEvent -- +# +# This procedure is used to cause a treectrl to generate a dynamic event. +# If the treectrl doesn't have the event defined (because you didn't call +# the [notify install] command) nothing happens. TreeCtrl::PercentsCmd is +# used to perform %-substitution on any scripts bound to the event. +# +# Arguments: +# T The treectrl widget. +# event Name of event. +# detail Name of detail or "". +# charMap %-char substitution list (even number of elements). + +proc ::TreeCtrl::TryEvent {T event detail charMap} { + if {[lsearch -exact [$T notify eventnames] $event] == -1} return + if {$detail ne ""} { + if {[lsearch -exact [$T notify detailnames $event] $detail] == -1} return + $T notify generate <$event-$detail> $charMap "::TreeCtrl::PercentsCmd $T" + } else { + $T notify generate <$event> $charMap "::TreeCtrl::PercentsCmd $T" + } + return +} + +# ::TreeCtrl::PercentsCmd -- +# +# This command is passed to [notify generate] to perform %-substitution on +# scripts bound to dynamic events. It supports the same set of substitution +# characters as the built-in static events (plus any event-specific chars). +# +# Arguments: +# T The treectrl widget. +# char %-char to be replaced in bound scripts. +# object Same arg passed to [notify bind]. +# event Name of event. +# detail Name of detail or "". +# charMap %-char substitution list (even number of elements). + +proc ::TreeCtrl::PercentsCmd {T char object event detail charMap} { + if {$detail ne ""} { + set pattern <$event-$detail> + } else { + set pattern <$event> + } + switch -- $char { + d { return $detail } + e { return $event } + P { return $pattern } + W { return $object } + T { return $T } + ? { + array set map $charMap + array set map [list T $T W $object P $pattern e $event d $detail] + return [array get map] + } + default { + array set map [list $char $char] + array set map $charMap + return $map($char) + } + } + return +} + +namespace eval TreeCtrl { +catch { + foreach theme [ttk::style theme names] { + ttk::style theme settings $theme { + ttk::style configure TreeCtrlHeading -relief raised -font TkHeadingFont + ttk::style map TreeCtrlHeading -relief { + pressed sunken + } + } + } +} +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/broadcast.tcl b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/broadcast.tcl new file mode 100644 index 00000000..a5badc5a --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/broadcast.tcl @@ -0,0 +1,39 @@ +#!/usr/bin/env tclsh +# multicast.tcl - Copyright (C) 2004 Pat Thoyts +# +# Demonstrate the use of broadcast UDP sockets. +# +# You can send to ths using netcat: +# echo HELLO | nc -u 192.168.255.255 7772 +# +# $Id: broadcast.tcl,v 1.1 2004/11/22 23:48:47 patthoyts Exp $ + +package require udp 1.0.6 + +proc udpEvent {chan} { + set data [read $chan] + set peer [fconfigure $chan -peer] + puts "$peer [string length $data] '$data'" + if {[string match "QUIT*" $data]} { + close $chan + set ::forever 1 + } + return +} + +# Select a subnet and the port number. +set subnet 192.168.255.255 +set port 7772 + +# Create a listening socket and configure for sending too. +set s [udp_open $port] +fconfigure $s -buffering none -blocking 0 +fconfigure $s -broadcast 1 -remote [list $subnet $port] +fileevent $s readable [list udpEvent $s] + +# Announce our presence and run +puts -nonewline $s "hello, world" +set forever 0 +vwait ::forever + +exit diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/bug1158628.tcl b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/bug1158628.tcl new file mode 100644 index 00000000..e32a2ed7 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/bug1158628.tcl @@ -0,0 +1,56 @@ +#!/usr/bin/env tclsh +# bug1158628.tcl - Copyright (C) 2005 Pat Thoyts +# +# "On windows XP, I have a GUI that has an exit buttons which when +# pressed does: {set done 1; destroy .;exit} If there is an open UDP +# channel with a fileevent on it, the program will not exit -- +# i.e. task manager still shows it. Also if I have the console up, the +# console goes away when the exit button is invoked, but the program +# does not exit. NOTE -- all windows are correctly destroyed (or at +# least withdrawn)" +# +# The fault is calling Tcl_UnregisterChannel in the udpClose function. +# We must let tcl handle this itself. Solved by Reinhard Max. +# +# This script demonstrates the problem. Using udp 1.0.6 the program hangs +# after printing "Exiting...". With the fix applied it properly exits. +# +# $Id: bug1158628.tcl,v 1.2 2005/05/19 20:46:23 patthoyts Exp $ + +#load [file join [file dirname [info script]] .. win Release udp107.dll] +#load [file join [file dirname [info script]] .. i386-unknown-openbsd3.6 libudp107.so] +package require udp + +variable forever 0 + +proc Event {sock} { + variable forever + set pkt [read $sock] + set peer [fconfigure $sock -peer] + puts "Recieved [string length $pkt] from $peer\n$pkt" + #set forever 1 + return +} + +proc Listen {port} { + set s [udp_open $port] + fconfigure $s -blocking 0 -buffering none -translation binary + fileevent $s readable [list Event $s] + return $s +} + +proc Exit {sock} { + puts "Exiting" + exit 0 +} + +if {!$tcl_interactive} { + puts "Bug #1158628 - hangs in exit if open udp channels" + puts " Using a buggy version, this will hang after printing Exiting..." + puts "" + set sock [Listen 10245] + puts "Wait 1 sec..." + after 1000 [list Exit $sock] + vwait forever + close $sock +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/chat.tcl b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/chat.tcl new file mode 100644 index 00000000..bf3143b9 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/chat.tcl @@ -0,0 +1,81 @@ +#!/usr/bin/env tclsh +# chat.tcl - Copyright (C) 2004 Pat Thoyts +# +# This is a sample application from TclUDP. +# +# This illustrates the use of multicast UDP messages to implement a +# primitive chat application. +# +# $Id: chat.tcl,v 1.2 2007/04/10 23:36:14 patthoyts Exp $ + +package require Tk 8.4- +package require udp 1.0.6 + +variable Address 224.5.1.21 +variable Port 7771 + +proc Receive {sock} { + set pkt [read $sock] + set peer [fconfigure $sock -peer] + AddMessage $peer $pkt + return +} + +proc Start {addr port} { + set s [udp_open $port] + fconfigure $s -blocking 0 -buffering none -translation binary \ + -mcastadd $addr -remote [list $addr $port] + fileevent $s readable [list ::Receive $s] + return $s +} + +proc CreateGui {socket} { + text .t -yscrollcommand {.s set} + scrollbar .s -command {.t yview} + frame .f -border 0 + entry .f.e -textvariable ::_msg + button .f.ok -text Send -underline 0 \ + -command "SendMessage $socket \$::_msg" + button .f.ex -text Exit -underline 1 -command {destroy .} + pack .f.ex .f.ok -side right + pack .f.e -side left -expand 1 -fill x + grid .t .s -sticky news + grid .f - -sticky ew + grid columnconfigure . 0 -weight 1 + grid rowconfigure . 0 -weight 1 + bind .f.e {.f.ok invoke} + .t tag configure CLNT -foreground red + .t configure -tabs {90} +} + +proc SendMessage {sock msg} { + puts -nonewline $sock $msg +} + +proc AddMessage {client msg} { + set msg [string map [list "\r\n" "" "\r" "" "\n" ""] $msg] + set client [lindex $client 0] + if {[string length $msg] > 0} { + .t insert end "$client\t" CLNT "$msg\n" MSG + .t see end + } +} + +proc Main {} { + variable Address + variable Port + variable sock + set sock [Start $Address $Port] + CreateGui $sock + after idle [list SendMessage $sock \ + "$::tcl_platform(user)@[info hostname] connected"] + tkwait window . + close $sock +} + +if {!$tcl_interactive} { + set r [catch [linsert $argv 0 Main] err] + if {$r} {puts $::errorInfo} else {puts $err} + exit 0 +} + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/multicast.tcl b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/multicast.tcl new file mode 100644 index 00000000..64939828 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/multicast.tcl @@ -0,0 +1,45 @@ +#!/usr/bin/env tclsh +# multicast.tcl - Copyright (C) 2004 Pat Thoyts +# +# Demonstrate the use of IPv4 multicast UDP sockets. +# +# You can send to ths using netcat: +# echo HELLO | nc -u 224.5.1.21 7771 +# +# $Id: multicast.tcl,v 1.3 2007/04/10 23:49:38 patthoyts Exp $ + +package require udp 1.0.6 + +proc udpEvent {chan} { + set data [read $chan] + set peer [fconfigure $chan -peer] + set group [lindex [fconfigure $chan -remote] 0] + puts "$peer ($group) [string length $data] '$data' {[fconfigure $chan]}" + if {[string match "QUIT*" $data]} { + close $chan + set ::forever 1 + } + return +} + +# Select a multicast group and the port number. +# +# We have two groups here to show that it's possible. +# +set group1 224.5.1.21 +set group2 224.5.2.21 +set port 7771 + +# Create a listening socket and configure for sending too. +set s [udp_open $port] +fconfigure $s -buffering none -blocking 0 +fconfigure $s -mcastadd $group2 -remote [list $group2 $port] +fconfigure $s -mcastadd $group1 -remote [list $group1 $port] +fileevent $s readable [list udpEvent $s] + +# Announce our presence and run +puts -nonewline $s "hello, world" +set forever 0 +vwait ::forever + +exit diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/udpcat.tcl b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/udpcat.tcl new file mode 100644 index 00000000..3b1bf255 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/demos/udpcat.tcl @@ -0,0 +1,65 @@ +#!/usr/bin/env tclsh +# udpsend.tcl - Copyright (C) 2004 Pat Thoyts +# +# Demo application - cat data from stdin via a UDP socket. +# +# $Id: udpcat.tcl,v 1.1 2004/11/22 23:48:47 patthoyts Exp $ + +package require udp 1.0.6 + +proc Event {sock} { + global forever + set pkt [read $sock] + set peer [fconfigure $sock -peer] + puts "Received [string length $pkt] from $peer\n$pkt" + set forever 1 + return +} + +proc Send {host port {msg {}}} { + set s [udp_open] + fconfigure $s -blocking 0 -buffering none -translation binary \ + -remote [list $host $port] + fileevent $s readable [list Event $s] + if {$msg eq {}} { + fcopy stdin $s + } else { + puts -nonewline $s $msg + } + + after 2000 + close $s +} + +proc Listen {port} { + set s [udp_open $port] + fconfigure $s -blocking 0 -buffering none -translation binary + fileevent $s readable [list Event $s] + return $s +} + +# ------------------------------------------------------------------------- +# Runtime +# udpsend listen -port N -blocking 0 +# udpsend send host port message +# ------------------------------------------------------------------------- +set forever 0 + +if {! $tcl_interactive} { + switch -exact -- [set cmd [lindex $argv 0]] { + send { + eval [list Send] [lrange $argv 1 end] + } + listen { + set s [Listen [lindex $argv 1]] + vwait ::forever + close $s + } + default { + puts "usage: udpcat send host port ?message?\ + \n udpcat listen port" + } + } +} + + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/pkgIndex.tcl new file mode 100644 index 00000000..42f0856e --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/pkgIndex.tcl @@ -0,0 +1,33 @@ +# -*- tcl -*- +# Tcl package index file, version 1.1 +# +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded udp 1.0.12 [list apply {{dir} { + # Load library + load [file join $dir tcl9udp1012.dll] [string totitle udp] + + # Source init file + set initScript [file join $dir udp.tcl] + if {[file exists $initScript]} { + source -encoding utf-8 $initScript + } + }} $dir] +} else { + if {![package vsatisfies [package provide Tcl] 8.5]} {return} + package ifneeded udp 1.0.12 [list apply {{dir} { + # Load library + if {[string tolower [file extension udp1012t.dll]] in [list .dll .dylib .so]} { + # Load dynamic library + load [file join $dir udp1012t.dll] [string totitle udp] + } else { + # Static library + load {} [string totitle udp] + } + + # Source init file + set initScript [file join $dir udp.tcl] + if {[file exists $initScript]} { + source -encoding utf-8 $initScript + } + }} $dir] +} diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/tcl9udp1012.dll b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/tcl9udp1012.dll new file mode 100644 index 00000000..b895ff99 Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/tcl9udp1012.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/udp.html b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/udp.html new file mode 100644 index 00000000..60b0ebf3 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/udp1.0.12/udp.html @@ -0,0 +1,326 @@ + + + +udp - Tcl UDP extension + + + + + +
+

udp(n) 1.0.12 udp "Tcl UDP extension"

+

Name

+

udp - Create UDP sockets in Tcl

+
+ + +

Description

+

This package provides support for using UDP through Tcl. The package provides +a new channel type and attempts to permit the use of packet oriented UDP +over stream oriented Tcl channels. The package defined three commands but +udp_conf should be considered depreciated in favor of the standard +Tcl command fconfigure.

+
+

COMMANDS

+
+
udp_open ?localport? ?reuse? ?ipv6?
+

udp_open will open a UDP socket. If a localport is specified the UDP +socket will be opened on that port. Otherwise the system will choose a port +and the user can use the udp_conf command to obtain the port number +if required.

+

The following keywords can be used to specify options on the opened socket.

+
+
reuse
+

Using this keyword sets the SO_REUSEADDR socket option which permits multiple +sockets to be bound to the same address/port combination.

+
ipv6
+

By default a IPv4 socket is created. When keyword ipv6 is specified, an IPv6 +socket is opened.

+
+
udp_conf channel host port
+

Deprecated in favor of the standard Tcl fconfigure or +chan configure commands.

+

udp_conf in this configuration is used to specify the remote destination +for packets written to this channel. You must call this command before +writing data to the UDP socket.

+
udp_conf channel ?optionName? ?value? ?optionName value ...?
+

Deprecated in favor of the standard Tcl fconfigure or +chan configure commands.

+

In addition to being used to configure the remote host, the udp_conf +command is used to obtain information about the UDP socket. NOTE all these +options are now available using the standard Tcl fconfigure or +chan configure command.

+
+
-myport
+

Returns the local port number of the socket. Read-only option.

+
-remote ?address port?
+

Specifies or returns the remote hostname and port number. Can also be set using +udp_conf channel host port.

+
-peer
+

Returns the remote hostname and port number for the packet most recently +received by this socket. Read-only option.

+
-family
+

Returns whether socket is configured for IPv4 or IPv6. Read-only option.

+
-broadcast ?boolean?
+

Specifies or returns whether can listen and send on the broadcast address. For some systems +a flag must be set on the socket to use broadcast. This option is not permitted when +using IPv6, instead use multicast.

+
-ttl ?count?
+

The time-to-live is given as the number of router hops the packet may do. For +multicast packets this is important in specifying the distribution of the +packet. The system default for multicast is 1 which restricts the packet +to the local subnet. To permit packets to pass routers, you must increase the +ttl. A value of 31 should keep it within a site, while 255 is global.

+
-mcastadd groupaddr
+
+
-mcastadd "groupaddr netwif"
+
+
-mcastdrop groupaddr
+
+
-mcastdrop "groupaddr netwif"
+
+
-mcastgroups
+

tcludp sockets can support IPv4 and IPv6 multicast operations. To receive +multicast packets the application has to notify the operating system that +it should join a particular multicast group. For IPv4 these are specified as addresses +in the range 224.0.0.0 to 239.255.255.255.

+

When specifying only the groupaddr the system will determine the network interface to use. +Specifying the netwif will join a multicast group on a specific network interface. +This is useful on a multihomed system with multiple network interfaces. +On windows you must specify the network interface index. For other platforms the network +interface (e.g. 'eth0') name can be specified.

+

To view the current set of multicast groups for a channel use -mcastgroups

+
-mcastif
+

Returns which interface is used for outgoing multicast packets. UNIX only.

+
-mcastloop ?boolean?
+

With multicast udp the system can choose to receive packets that it has sent +or it can drop them. This is known as multicast loopback and can be controlled +using this option. By default the value is true and your application will receive +its own transmissions.

+
+
udp_peek channel ?buffersize?
+

Examine a packet without removing it from the buffer. Option buffersize specifies the +maximum buffer size. Value must be between 0 and 16.

+

This function is not available on windows.

+
::udp::build-info
+

Return information on the build environment.

+
::udp::getaddrinfo -hostname name ?optionName value ...?
+

Returns a list with info on the IP address matching the specified parameters. +Valid options are:

+
+
-hostname name
+

Specifies which IP address to use for lookup. Can use IP address or name. Required option.

+
-port number
+

Specifies which port number to use for lookup.

+
-service name
+

Specifies which well-known service (i.e. http, https, etc.) to use for port in lookup.

+
-ipv4
+

Only return IP v4 addresses.

+
-ipv6
+

Only return IP v6 addresses.

+
-server
+

Only return services for which hostname is a server.

+
-tcp
+

Only return TCP services.

+
-udp
+

Only return UDP services.

+
+
::udp::getnameinfo address ?ipv6?
+

::udp::getnameinfo will return the name(s) corresponding to IP +address address. With ipv6, address is an IPv6 address.

+
+
+

EXAMPLES

+
+# Send data to a remote UDP socket
+proc udp_puts {host port} {
+    set s [udp_open]
+    fconfigure $s -remote [list $host $port]
+    puts $s "Hello, World"
+    close $f
+}
+
+
+# A simple UDP server
+package require udp
+proc udpEventHandler {sock} {
+    set pkt [read $sock]
+    set peer [fconfigure $sock -peer]
+    puts "$peer: [string length $pkt] {$pkt}"
+    return
+}
+proc udp_listen {port} {
+    set srv [udp_open $port]
+    fconfigure $srv -buffering none -translation binary
+    fileevent $srv readable [list ::udpEventHandler $srv]
+    puts "Listening on udp port: [fconfigure $srv -myport]"
+    return $srv
+}
+set sock [udp_listen 53530]
+vwait forever
+close $sock
+
+
+# A multicast demo.
+proc udpEvent {chan} {
+    set data [read $chan]
+    set peer [fconfigure $chan -peer]
+    puts "$peer [string length $data] '$data'"
+    if {[string match "QUIT*" $data]} {
+        close $chan
+        set ::forever 1
+    }
+    return
+}
+set group 224.5.1.21
+set port  7771
+set s [udp_open $port]
+fconfigure $s -buffering none -blocking 0
+fconfigure $s -mcastadd $group -remote [list $group $port]
+fileevent $s readable [list udpEvent $s]
+puts -nonewline $s "hello, world"
+set ::forever 0
+vwait ::forever
+exit
+
+
+

HISTORY

+

Some of the code in this extension is copied from Michael Miller's tcludp +package. (http://www.neosoft.com/tcl/ftparchive/sorted/comm/tcludp-1.0/) +Compared with Michael's UDP extension, this extension provides Windows +support and provides the ability of using 'gets/puts' to read/write +the socket. In addition, it provides more configuration ability.

+

Enhancements to support binary data and to setup the package for the Tcl +Extension Architecture by Pat Thoyts.

+

Support for IPv6 and allowing a multicast join on a specific network interface is added by Huub Eikens.

+
+

See Also

+

socket(n)

+
+

Keywords

+

I/O, IP Address, TclUDP, UDP, asynchronous I/O, bind, channel, connection, domain, host, name, network, network address, networking, socket, udp

+
+ +
diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/LICENSE b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/LICENSE new file mode 100644 index 00000000..ed47ca52 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/LICENSE @@ -0,0 +1,24 @@ +BSD 2-Clause License + +Copyright (c) 2024, apnadkarni + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/README.md b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/README.md new file mode 100644 index 00000000..3dacb02b --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/README.md @@ -0,0 +1 @@ +# tcl-xtal \ No newline at end of file diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ooparser.tcl b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ooparser.tcl new file mode 100644 index 00000000..80e03245 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ooparser.tcl @@ -0,0 +1,6448 @@ +## -*- tcl -*- +## +## OO-based Tcl/PARAM implementation of the parsing +## expression grammar +## +## Xtal +## +## Generated from file unknown +## for user unknown +## +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 9 +package require TclOO +package require pt::rde::oo ; # OO-based implementation of the + # PARAM virtual machine + # underlying the Tcl/PARAM code + # used below. + +# # ## ### ##### ######## ############# ##################### +## + +oo::class create xtal::ParserBase { + # # ## ### ##### ######## ############# + ## Public API + + superclass pt::rde::oo ; # TODO - Define this class. + # Or can we inherit from a snit + # class too ? + + method parse {channel} { + my reset $channel + my MAIN ; # Entrypoint for the generated code. + return [my complete] + } + + method parset {text} { + my reset {} + my data $text + my MAIN ; # Entrypoint for the generated code. + return [my complete] + } + + # # ## ### ###### ######## ############# + ## BEGIN of GENERATED CODE. DO NOT EDIT. + + # + # Grammar Start Expression + # + + method MAIN {} { + my sym_Program + return + } + + # + # value Symbol 'AddExpr' + # + + method sym_AddExpr {} { + # x + # (MulExpr) + # * + # x + # (WS) + # (AddOp) + # (WS) + # (MulExpr) + + my si:value_symbol_start AddExpr + my sequence_11 + my si:reduce_symbol_end AddExpr + return + } + + method sequence_11 {} { + # x + # (MulExpr) + # * + # x + # (WS) + # (AddOp) + # (WS) + # (MulExpr) + + my si:value_state_push + my sym_MulExpr + my si:valuevalue_part + my kleene_9 + my si:value_state_merge + return + } + + method kleene_9 {} { + # * + # x + # (WS) + # (AddOp) + # (WS) + # (MulExpr) + + while {1} { + my si:void2_state_push + my sequence_7 + my si:kleene_close + } + return + } + + method sequence_7 {} { + # x + # (WS) + # (AddOp) + # (WS) + # (MulExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_AddOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_MulExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'AddOp' + # + + method sym_AddOp {} { + # [+-] + + my si:void_symbol_start AddOp + my si:next_class +- + my si:void_leaf_symbol_end AddOp + return + } + + # + # value Symbol 'Argument' + # + + method sym_Argument {} { + # / + # x + # (OptionString) + # (WS) + # (Expression) + # (Expression) + + my si:value_symbol_start Argument + my choice_22 + my si:reduce_symbol_end Argument + return + } + + method choice_22 {} { + # / + # x + # (OptionString) + # (WS) + # (Expression) + # (Expression) + + my si:value_state_push + my sequence_19 + my si:valuevalue_branch + my sym_Expression + my si:value_state_merge + return + } + + method sequence_19 {} { + # x + # (OptionString) + # (WS) + # (Expression) + + my si:value_state_push + my sym_OptionString + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_Expression + my si:value_state_merge + return + } + + # + # value Symbol 'ArgumentList' + # + + method sym_ArgumentList {} { + # x + # (Argument) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Argument) + + my si:value_symbol_start ArgumentList + my sequence_34 + my si:reduce_symbol_end ArgumentList + return + } + + method sequence_34 {} { + # x + # (Argument) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Argument) + + my si:value_state_push + my sym_Argument + my si:valuevalue_part + my kleene_32 + my si:value_state_merge + return + } + + method kleene_32 {} { + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Argument) + + while {1} { + my si:void2_state_push + my sequence_30 + my si:kleene_close + } + return + } + + method sequence_30 {} { + # x + # (WSNL) + # ',' + # (WSNL) + # (Argument) + + my si:void_state_push + my sym_WSNL + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WSNL + my si:voidvalue_part + my sym_Argument + my si:value_state_merge + return + } + + # + # value Symbol 'Assignment' + # + + method sym_Assignment {} { + # x + # (LValue) + # (WS) + # (AssignOp) + # (WS) + # / + # (TclScriptBlock) + # (Expression) + + my si:value_symbol_start Assignment + my sequence_45 + my si:reduce_symbol_end Assignment + return + } + + method sequence_45 {} { + # x + # (LValue) + # (WS) + # (AssignOp) + # (WS) + # / + # (TclScriptBlock) + # (Expression) + + my si:value_state_push + my sym_LValue + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_AssignOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my choice_43 + my si:value_state_merge + return + } + + method choice_43 {} { + # / + # (TclScriptBlock) + # (Expression) + + my si:value_state_push + my sym_TclScriptBlock + my si:valuevalue_branch + my sym_Expression + my si:value_state_merge + return + } + + # + # leaf Symbol 'AssignOp' + # + + method sym_AssignOp {} { + # '=' + + my si:void_symbol_start AssignOp + my si:next_char = + my si:void_leaf_symbol_end AssignOp + return + } + + # + # void Symbol 'Backslash' + # + + method sym_Backslash {} { + # '\' + + my si:void_void_symbol_start Backslash + my si:next_char \134 + my si:void_clear_symbol_end Backslash + return + } + + # + # value Symbol 'BitAndExpr' + # + + method sym_BitAndExpr {} { + # x + # (RelExpr) + # * + # x + # (WS) + # (BitAndOp) + # (WS) + # (RelExpr) + + my si:value_symbol_start BitAndExpr + my sequence_61 + my si:reduce_symbol_end BitAndExpr + return + } + + method sequence_61 {} { + # x + # (RelExpr) + # * + # x + # (WS) + # (BitAndOp) + # (WS) + # (RelExpr) + + my si:value_state_push + my sym_RelExpr + my si:valuevalue_part + my kleene_59 + my si:value_state_merge + return + } + + method kleene_59 {} { + # * + # x + # (WS) + # (BitAndOp) + # (WS) + # (RelExpr) + + while {1} { + my si:void2_state_push + my sequence_57 + my si:kleene_close + } + return + } + + method sequence_57 {} { + # x + # (WS) + # (BitAndOp) + # (WS) + # (RelExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_BitAndOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_RelExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'BitAndOp' + # + + method sym_BitAndOp {} { + # '&' + + my si:void_symbol_start BitAndOp + my si:next_char & + my si:void_leaf_symbol_end BitAndOp + return + } + + # + # value Symbol 'BitOrExpr' + # + + method sym_BitOrExpr {} { + # x + # (BitXorExpr) + # * + # x + # (WS) + # (BitOrOp) + # (WS) + # (BitXorExpr) + + my si:value_symbol_start BitOrExpr + my sequence_75 + my si:reduce_symbol_end BitOrExpr + return + } + + method sequence_75 {} { + # x + # (BitXorExpr) + # * + # x + # (WS) + # (BitOrOp) + # (WS) + # (BitXorExpr) + + my si:value_state_push + my sym_BitXorExpr + my si:valuevalue_part + my kleene_73 + my si:value_state_merge + return + } + + method kleene_73 {} { + # * + # x + # (WS) + # (BitOrOp) + # (WS) + # (BitXorExpr) + + while {1} { + my si:void2_state_push + my sequence_71 + my si:kleene_close + } + return + } + + method sequence_71 {} { + # x + # (WS) + # (BitOrOp) + # (WS) + # (BitXorExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_BitOrOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_BitXorExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'BitOrOp' + # + + method sym_BitOrOp {} { + # '|' + + my si:void_symbol_start BitOrOp + my si:next_char | + my si:void_leaf_symbol_end BitOrOp + return + } + + # + # value Symbol 'BitXorExpr' + # + + method sym_BitXorExpr {} { + # x + # (BitAndExpr) + # * + # x + # (WS) + # (BitXorOp) + # (WS) + # (BitAndExpr) + + my si:value_symbol_start BitXorExpr + my sequence_89 + my si:reduce_symbol_end BitXorExpr + return + } + + method sequence_89 {} { + # x + # (BitAndExpr) + # * + # x + # (WS) + # (BitXorOp) + # (WS) + # (BitAndExpr) + + my si:value_state_push + my sym_BitAndExpr + my si:valuevalue_part + my kleene_87 + my si:value_state_merge + return + } + + method kleene_87 {} { + # * + # x + # (WS) + # (BitXorOp) + # (WS) + # (BitAndExpr) + + while {1} { + my si:void2_state_push + my sequence_85 + my si:kleene_close + } + return + } + + method sequence_85 {} { + # x + # (WS) + # (BitXorOp) + # (WS) + # (BitAndExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_BitXorOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_BitAndExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'BitXorOp' + # + + method sym_BitXorOp {} { + # '^' + + my si:void_symbol_start BitXorOp + my si:next_char ^ + my si:void_leaf_symbol_end BitXorOp + return + } + + # + # value Symbol 'Block' + # + + method sym_Block {} { + # x + # (WS) + # ? + # x + # (Statement) + # * + # x + # (WS) + # (Separator) + # (WS) + # (Statement) + # (WS) + + my si:value_symbol_start Block + my sequence_109 + my si:reduce_symbol_end Block + return + } + + method sequence_109 {} { + # x + # (WS) + # ? + # x + # (Statement) + # * + # x + # (WS) + # (Separator) + # (WS) + # (Statement) + # (WS) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my optional_106 + my si:valuevalue_part + my sym_WS + my si:value_state_merge + return + } + + method optional_106 {} { + # ? + # x + # (Statement) + # * + # x + # (WS) + # (Separator) + # (WS) + # (Statement) + + my si:void2_state_push + my sequence_104 + my si:void_state_merge_ok + return + } + + method sequence_104 {} { + # x + # (Statement) + # * + # x + # (WS) + # (Separator) + # (WS) + # (Statement) + + my si:value_state_push + my sym_Statement + my si:valuevalue_part + my kleene_102 + my si:value_state_merge + return + } + + method kleene_102 {} { + # * + # x + # (WS) + # (Separator) + # (WS) + # (Statement) + + while {1} { + my si:void2_state_push + my sequence_100 + my si:kleene_close + } + return + } + + method sequence_100 {} { + # x + # (WS) + # (Separator) + # (WS) + # (Statement) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my sym_Separator + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Statement + my si:value_state_merge + return + } + + # + # value Symbol 'BreakStatement' + # + + method sym_BreakStatement {} { + # "break" + + my si:void_symbol_start BreakStatement + my si:next_str break + my si:void_leaf_symbol_end BreakStatement + return + } + + # + # value Symbol 'BuiltIn' + # + + method sym_BuiltIn {} { + # / + # (ColumnConstructor) + # (TableConstructor) + # (ListCast) + # (DictCast) + # (SortCommand) + # (SearchCommand) + # (SelectorContext) + + my si:value_symbol_start BuiltIn + my choice_121 + my si:reduce_symbol_end BuiltIn + return + } + + method choice_121 {} { + # / + # (ColumnConstructor) + # (TableConstructor) + # (ListCast) + # (DictCast) + # (SortCommand) + # (SearchCommand) + # (SelectorContext) + + my si:value_state_push + my sym_ColumnConstructor + my si:valuevalue_branch + my sym_TableConstructor + my si:valuevalue_branch + my sym_ListCast + my si:valuevalue_branch + my sym_DictCast + my si:valuevalue_branch + my sym_SortCommand + my si:valuevalue_branch + my sym_SearchCommand + my si:valuevalue_branch + my sym_SelectorContext + my si:value_state_merge + return + } + + # + # value Symbol 'BuiltInCall' + # + + method sym_BuiltInCall {} { + # x + # '@' + # (BuiltInFunction) + # (WS) + # '\(' + # (WSNL) + # ? + # (ArgumentList) + # (WSNL) + # '\)' + + my si:value_symbol_start BuiltInCall + my sequence_134 + my si:reduce_symbol_end BuiltInCall + return + } + + method sequence_134 {} { + # x + # '@' + # (BuiltInFunction) + # (WS) + # '\(' + # (WSNL) + # ? + # (ArgumentList) + # (WSNL) + # '\)' + + my si:void_state_push + my si:next_char @ + my si:voidvalue_part + my sym_BuiltInFunction + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \50 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my optional_130 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my si:next_char \51 + my si:value_state_merge + return + } + + method optional_130 {} { + # ? + # (ArgumentList) + + my si:void2_state_push + my sym_ArgumentList + my si:void_state_merge_ok + return + } + + # + # leaf Symbol 'BuiltInFunction' + # + + method sym_BuiltInFunction {} { + # / + # "delete" + # "fill" + # "inject" + # "insert" + # "lookup" + # "reverse" + # "sum" + + my si:void_symbol_start BuiltInFunction + my choice_144 + my si:void_leaf_symbol_end BuiltInFunction + return + } + + method choice_144 {} { + # / + # "delete" + # "fill" + # "inject" + # "insert" + # "lookup" + # "reverse" + # "sum" + + my si:void_state_push + my si:next_str delete + my si:voidvoid_branch + my si:next_str fill + my si:voidvoid_branch + my si:next_str inject + my si:voidvoid_branch + my si:next_str insert + my si:voidvoid_branch + my si:next_str lookup + my si:voidvoid_branch + my si:next_str reverse + my si:voidvoid_branch + my si:next_str sum + my si:void_state_merge + return + } + + # + # void Symbol 'Char' + # + + method sym_Char {} { + # / + # x + # (BackSlash) + # / + # (Quote) + # (SingleQuote) + # (BackSlash) + # [bfnrt] + # x + # 'x' + # + # + # + # x + # 'u' + # + # + # + # + # x + # 'U' + # + # + # + # + # + # + # + # + # + + my si:void_void_symbol_start Char + my choice_181 + my si:void_clear_symbol_end Char + return + } + + method choice_181 {} { + # / + # x + # (BackSlash) + # / + # (Quote) + # (SingleQuote) + # (BackSlash) + # [bfnrt] + # x + # 'x' + # + # + # + # x + # 'u' + # + # + # + # + # x + # 'U' + # + # + # + # + # + # + # + # + # + + my si:void_state_push + my sequence_178 + my si:voidvoid_branch + my i_input_next dot + my si:void_state_merge + return + } + + method sequence_178 {} { + # x + # (BackSlash) + # / + # (Quote) + # (SingleQuote) + # (BackSlash) + # [bfnrt] + # x + # 'x' + # + # + # + # x + # 'u' + # + # + # + # + # x + # 'U' + # + # + # + # + # + # + # + # + + my si:void_state_push + my i_status_fail ; # Undefined symbol 'BackSlash' + my si:voidvoid_part + my choice_176 + my si:void_state_merge + return + } + + method choice_176 {} { + # / + # (Quote) + # (SingleQuote) + # (BackSlash) + # [bfnrt] + # x + # 'x' + # + # + # + # x + # 'u' + # + # + # + # + # x + # 'U' + # + # + # + # + # + # + # + # + + my si:void_state_push + my sym_Quote + my si:voidvoid_branch + my sym_SingleQuote + my si:voidvoid_branch + my i_status_fail ; # Undefined symbol 'BackSlash' + my si:voidvoid_branch + my si:next_class bfnrt + my si:voidvoid_branch + my sequence_156 + my si:voidvoid_branch + my sequence_163 + my si:voidvoid_branch + my sequence_174 + my si:void_state_merge + return + } + + method sequence_156 {} { + # x + # 'x' + # + # + # + + my si:void_state_push + my si:next_char x + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:void_state_merge + return + } + + method sequence_163 {} { + # x + # 'u' + # + # + # + # + + my si:void_state_push + my si:next_char u + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:void_state_merge + return + } + + method sequence_174 {} { + # x + # 'U' + # + # + # + # + # + # + # + # + + my si:void_state_push + my si:next_char U + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:voidvoid_part + my si:next_xdigit + my si:void_state_merge + return + } + + # + # value Symbol 'ColumnConstructor' + # + + method sym_ColumnConstructor {} { + # x + # '@' + # (ColumnType) + # ? + # x + # (WS) + # (ColumnConstructorSize) + # ? + # x + # (WS) + # (ColumnConstructorInit) + + my si:value_symbol_start ColumnConstructor + my sequence_198 + my si:reduce_symbol_end ColumnConstructor + return + } + + method sequence_198 {} { + # x + # '@' + # (ColumnType) + # ? + # x + # (WS) + # (ColumnConstructorSize) + # ? + # x + # (WS) + # (ColumnConstructorInit) + + my si:void_state_push + my si:next_char @ + my si:voidvalue_part + my sym_ColumnType + my si:valuevalue_part + my optional_190 + my si:valuevalue_part + my optional_196 + my si:value_state_merge + return + } + + method optional_190 {} { + # ? + # x + # (WS) + # (ColumnConstructorSize) + + my si:void2_state_push + my sequence_188 + my si:void_state_merge_ok + return + } + + method sequence_188 {} { + # x + # (WS) + # (ColumnConstructorSize) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_ColumnConstructorSize + my si:value_state_merge + return + } + + method optional_196 {} { + # ? + # x + # (WS) + # (ColumnConstructorInit) + + my si:void2_state_push + my sequence_194 + my si:void_state_merge_ok + return + } + + method sequence_194 {} { + # x + # (WS) + # (ColumnConstructorInit) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_ColumnConstructorInit + my si:value_state_merge + return + } + + # + # value Symbol 'ColumnConstructorExpr' + # + + method sym_ColumnConstructorExpr {} { + # / + # (ColumnConstructorRandom) + # (ColumnConstructorSeries) + + my si:value_symbol_start ColumnConstructorExpr + my choice_203 + my si:reduce_symbol_end ColumnConstructorExpr + return + } + + method choice_203 {} { + # / + # (ColumnConstructorRandom) + # (ColumnConstructorSeries) + + my si:value_state_push + my sym_ColumnConstructorRandom + my si:valuevalue_branch + my sym_ColumnConstructorSeries + my si:value_state_merge + return + } + + # + # value Symbol 'ColumnConstructorInit' + # + + method sym_ColumnConstructorInit {} { + # / + # (Sequence) + # x + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + # (ColumnConstructorExpr) + + my si:value_symbol_start ColumnConstructorInit + my choice_215 + my si:reduce_symbol_end ColumnConstructorInit + return + } + + method choice_215 {} { + # / + # (Sequence) + # x + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + # (ColumnConstructorExpr) + + my si:value_state_push + my sym_Sequence + my si:valuevalue_branch + my sequence_212 + my si:valuevalue_branch + my sym_ColumnConstructorExpr + my si:value_state_merge + return + } + + method sequence_212 {} { + # x + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + + my si:void_state_push + my si:next_char \50 + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \51 + my si:value_state_merge + return + } + + # + # value Symbol 'ColumnConstructorRandom' + # + + method sym_ColumnConstructorRandom {} { + # / + # '*' + # x + # (AddExpr) + # ? + # x + # (WS) + # ':' + # (WS) + # (AddExpr) + # (WS) + # ':' + # (WS) + # '*' + + my si:value_symbol_start ColumnConstructorRandom + my choice_234 + my si:reduce_symbol_end ColumnConstructorRandom + return + } + + method choice_234 {} { + # / + # '*' + # x + # (AddExpr) + # ? + # x + # (WS) + # ':' + # (WS) + # (AddExpr) + # (WS) + # ':' + # (WS) + # '*' + + my si:void_state_push + my si:next_char * + my si:voidvalue_branch + my sequence_232 + my si:value_state_merge + return + } + + method sequence_232 {} { + # x + # (AddExpr) + # ? + # x + # (WS) + # ':' + # (WS) + # (AddExpr) + # (WS) + # ':' + # (WS) + # '*' + + my si:value_state_push + my sym_AddExpr + my si:valuevalue_part + my optional_226 + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char : + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char * + my si:value_state_merge + return + } + + method optional_226 {} { + # ? + # x + # (WS) + # ':' + # (WS) + # (AddExpr) + + my si:void2_state_push + my sequence_224 + my si:void_state_merge_ok + return + } + + method sequence_224 {} { + # x + # (WS) + # ':' + # (WS) + # (AddExpr) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_char : + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_AddExpr + my si:value_state_merge + return + } + + # + # value Symbol 'ColumnConstructorSeries' + # + + method sym_ColumnConstructorSeries {} { + # x + # (AddExpr) + # (WS) + # ':' + # (WS) + # (AddExpr) + # ? + # x + # (WS) + # ':' + # (WS) + # (AddExpr) + + my si:value_symbol_start ColumnConstructorSeries + my sequence_248 + my si:reduce_symbol_end ColumnConstructorSeries + return + } + + method sequence_248 {} { + # x + # (AddExpr) + # (WS) + # ':' + # (WS) + # (AddExpr) + # ? + # x + # (WS) + # ':' + # (WS) + # (AddExpr) + + my si:value_state_push + my sym_AddExpr + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char : + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_AddExpr + my si:valuevalue_part + my optional_226 + my si:value_state_merge + return + } + + # + # value Symbol 'ColumnConstructorSize' + # + + method sym_ColumnConstructorSize {} { + # x + # '[' + # (WS) + # (Expression) + # (WS) + # ']' + + my si:value_symbol_start ColumnConstructorSize + my sequence_256 + my si:reduce_symbol_end ColumnConstructorSize + return + } + + method sequence_256 {} { + # x + # '[' + # (WS) + # (Expression) + # (WS) + # ']' + + my si:void_state_push + my si:next_char \133 + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \135 + my si:value_state_merge + return + } + + # + # value Symbol 'ColumnIdentifier' + # + + method sym_ColumnIdentifier {} { + # / + # (Identifier) + # (IndirectIdentifier) + # (IndirectLiteral) + # (String) + # (Number) + + my si:value_symbol_start ColumnIdentifier + my choice_264 + my si:reduce_symbol_end ColumnIdentifier + return + } + + method choice_264 {} { + # / + # (Identifier) + # (IndirectIdentifier) + # (IndirectLiteral) + # (String) + # (Number) + + my si:value_state_push + my sym_Identifier + my si:valuevalue_branch + my sym_IndirectIdentifier + my si:valuevalue_branch + my sym_IndirectLiteral + my si:valuevalue_branch + my sym_String + my si:valuevalue_branch + my sym_Number + my si:value_state_merge + return + } + + # + # leaf Symbol 'ColumnType' + # + + method sym_ColumnType {} { + # / + # "boolean" + # "byte" + # "int" + # "uint" + # "wide" + # "double" + # "string" + # "any" + + my si:void_symbol_start ColumnType + my choice_275 + my si:void_leaf_symbol_end ColumnType + return + } + + method choice_275 {} { + # / + # "boolean" + # "byte" + # "int" + # "uint" + # "wide" + # "double" + # "string" + # "any" + + my si:void_state_push + my si:next_str boolean + my si:voidvoid_branch + my si:next_str byte + my si:voidvoid_branch + my si:next_str int + my si:voidvoid_branch + my si:next_str uint + my si:voidvoid_branch + my si:next_str wide + my si:voidvoid_branch + my si:next_str double + my si:voidvoid_branch + my si:next_str string + my si:voidvoid_branch + my si:next_str any + my si:void_state_merge + return + } + + # + # void Symbol 'Comment' + # + + method sym_Comment {} { + # x + # '#' + # * + # x + # ! + # (EOL) + # + + my si:void_void_symbol_start Comment + my sequence_287 + my si:void_clear_symbol_end Comment + return + } + + method sequence_287 {} { + # x + # '#' + # * + # x + # ! + # (EOL) + # + + my si:void_state_push + my si:next_char # + my si:voidvoid_part + my kleene_285 + my si:void_state_merge + return + } + + method kleene_285 {} { + # * + # x + # ! + # (EOL) + # + + while {1} { + my si:void2_state_push + my sequence_283 + my si:kleene_close + } + return + } + + method sequence_283 {} { + # x + # ! + # (EOL) + # + + my si:void_state_push + my notahead_280 + my si:voidvoid_part + my i_input_next dot + my si:void_state_merge + return + } + + method notahead_280 {} { + # ! + # (EOL) + + my i_loc_push + my sym_EOL + my si:void_notahead_exit + return + } + + # + # value Symbol 'ContinueStatement' + # + + method sym_ContinueStatement {} { + # "continue" + + my si:void_symbol_start ContinueStatement + my si:next_str continue + my si:void_leaf_symbol_end ContinueStatement + return + } + + # + # value Symbol 'DictCast' + # + + method sym_DictCast {} { + # x + # "@dict" + # (WS) + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + + my si:value_symbol_start DictCast + my sequence_299 + my si:reduce_symbol_end DictCast + return + } + + method sequence_299 {} { + # x + # "@dict" + # (WS) + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + + my si:void_state_push + my si:next_str @dict + my si:voidvoid_part + my sym_WS + my si:voidvoid_part + my si:next_char \50 + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \51 + my si:value_state_merge + return + } + + # + # value Symbol 'Element' + # + + method sym_Element {} { + # x + # (ElementOp) + # (WS) + # (ElementIdentifier) + + my si:value_symbol_start Element + my sequence_305 + my si:reduce_symbol_end Element + return + } + + method sequence_305 {} { + # x + # (ElementOp) + # (WS) + # (ElementIdentifier) + + my si:value_state_push + my sym_ElementOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_ElementIdentifier + my si:value_state_merge + return + } + + # + # value Symbol 'ElementIdentifier' + # + + method sym_ElementIdentifier {} { + # / + # (Identifier) + # (IndirectIdentifier) + # (IndirectLiteral) + # (String) + # (Number) + + my si:value_symbol_start ElementIdentifier + my choice_264 + my si:reduce_symbol_end ElementIdentifier + return + } + + # + # leaf Symbol 'ElementOp' + # + + method sym_ElementOp {} { + # '.' + + my si:void_symbol_start ElementOp + my si:next_char . + my si:void_leaf_symbol_end ElementOp + return + } + + # + # value Symbol 'ElseClause' + # + + method sym_ElseClause {} { + # x + # "else" + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start ElseClause + my sequence_322 + my si:reduce_symbol_end ElseClause + return + } + + method sequence_322 {} { + # x + # "else" + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str else + my si:voidvoid_part + my sym_WSob + my si:voidvoid_part + my si:next_char \173 + my si:voidvalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + # + # value Symbol 'ElseifClause' + # + + method sym_ElseifClause {} { + # x + # "elseif" + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start ElseifClause + my sequence_332 + my si:reduce_symbol_end ElseifClause + return + } + + method sequence_332 {} { + # x + # "elseif" + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str elseif + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + # + # void Symbol 'Empty' + # + + method sym_Empty {} { + # (WS) + + my si:void_void_symbol_start Empty + my sym_WS + my si:void_clear_symbol_end Empty + return + } + + # + # void Symbol 'EOF' + # + + method sym_EOF {} { + # ! + # + + my si:void_void_symbol_start EOF + my notahead_338 + my si:void_clear_symbol_end EOF + return + } + + method notahead_338 {} { + # ! + # + + my i_loc_push + my i_input_next dot + my si:void_notahead_exit + return + } + + # + # void Symbol 'EOL' + # + + method sym_EOL {} { + # '\n' + + my si:void_void_symbol_start EOL + my si:next_char \n + my si:void_clear_symbol_end EOL + return + } + + # + # value Symbol 'Expression' + # + + method sym_Expression {} { + # (LogicalOrExpr) + + my si:value_symbol_start Expression + my sym_LogicalOrExpr + my si:reduce_symbol_end Expression + return + } + + # + # value Symbol 'FinallyClause' + # + + method sym_FinallyClause {} { + # x + # "finally" + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start FinallyClause + my sequence_350 + my si:reduce_symbol_end FinallyClause + return + } + + method sequence_350 {} { + # x + # "finally" + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str finally + my si:voidvoid_part + my sym_WSob + my si:voidvoid_part + my si:next_char \173 + my si:voidvalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + # + # value Symbol 'ForEachStatement' + # + + method sym_ForEachStatement {} { + # x + # "foreach" + # (WSob) + # (Identifier) + # ? + # x + # (WS) + # ',' + # (WS) + # (Identifier) + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start ForEachStatement + my sequence_370 + my si:reduce_symbol_end ForEachStatement + return + } + + method sequence_370 {} { + # x + # "foreach" + # (WSob) + # (Identifier) + # ? + # x + # (WS) + # ',' + # (WS) + # (Identifier) + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str foreach + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Identifier + my si:valuevalue_part + my optional_362 + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my sym_Expression + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + method optional_362 {} { + # ? + # x + # (WS) + # ',' + # (WS) + # (Identifier) + + my si:void2_state_push + my sequence_360 + my si:void_state_merge_ok + return + } + + method sequence_360 {} { + # x + # (WS) + # ',' + # (WS) + # (Identifier) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Identifier + my si:value_state_merge + return + } + + # + # value Symbol 'ForRangeIncrement' + # + + method sym_ForRangeIncrement {} { + # x + # ':' + # (WS) + # (AddExpr) + + my si:value_symbol_start ForRangeIncrement + my sequence_376 + my si:reduce_symbol_end ForRangeIncrement + return + } + + method sequence_376 {} { + # x + # ':' + # (WS) + # (AddExpr) + + my si:void_state_push + my si:next_char : + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_AddExpr + my si:value_state_merge + return + } + + # + # value Symbol 'ForRangeStatement' + # + + method sym_ForRangeStatement {} { + # x + # "for" + # (WSob) + # (Identifier) + # (WSob) + # (AddExpr) + # ? + # x + # (WS) + # ':' + # (WS) + # / + # x + # ? + # (AddExpr) + # (WS) + # (ForRangeIncrement) + # (AddExpr) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start ForRangeStatement + my sequence_405 + my si:reduce_symbol_end ForRangeStatement + return + } + + method sequence_405 {} { + # x + # "for" + # (WSob) + # (Identifier) + # (WSob) + # (AddExpr) + # ? + # x + # (WS) + # ':' + # (WS) + # / + # x + # ? + # (AddExpr) + # (WS) + # (ForRangeIncrement) + # (AddExpr) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str for + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Identifier + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my sym_AddExpr + my si:valuevalue_part + my optional_399 + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + method optional_399 {} { + # ? + # x + # (WS) + # ':' + # (WS) + # / + # x + # ? + # (AddExpr) + # (WS) + # (ForRangeIncrement) + # (AddExpr) + + my si:void2_state_push + my sequence_397 + my si:void_state_merge_ok + return + } + + method sequence_397 {} { + # x + # (WS) + # ':' + # (WS) + # / + # x + # ? + # (AddExpr) + # (WS) + # (ForRangeIncrement) + # (AddExpr) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_char : + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my choice_395 + my si:value_state_merge + return + } + + method choice_395 {} { + # / + # x + # ? + # (AddExpr) + # (WS) + # (ForRangeIncrement) + # (AddExpr) + + my si:value_state_push + my sequence_392 + my si:valuevalue_branch + my sym_AddExpr + my si:value_state_merge + return + } + + method sequence_392 {} { + # x + # ? + # (AddExpr) + # (WS) + # (ForRangeIncrement) + + my si:value_state_push + my optional_388 + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_ForRangeIncrement + my si:value_state_merge + return + } + + method optional_388 {} { + # ? + # (AddExpr) + + my si:void2_state_push + my sym_AddExpr + my si:void_state_merge_ok + return + } + + # + # value Symbol 'FunctionCall' + # + + method sym_FunctionCall {} { + # x + # * + # (Element) + # (WS) + # '\(' + # (WSNL) + # ? + # (ArgumentList) + # (WSNL) + # '\)' + + my si:value_symbol_start FunctionCall + my sequence_418 + my si:reduce_symbol_end FunctionCall + return + } + + method sequence_418 {} { + # x + # * + # (Element) + # (WS) + # '\(' + # (WSNL) + # ? + # (ArgumentList) + # (WSNL) + # '\)' + + my si:value_state_push + my kleene_409 + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \50 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my optional_130 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my si:next_char \51 + my si:value_state_merge + return + } + + method kleene_409 {} { + # * + # (Element) + + while {1} { + my si:void2_state_push + my sym_Element + my si:kleene_close + } + return + } + + # + # value Symbol 'FunctionDefinition' + # + + method sym_FunctionDefinition {} { + # x + # "function" + # (WSob) + # (Identifier) + # (WS) + # '\(' + # (WS) + # (ParameterDefinitions) + # (WS) + # '\)' + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start FunctionDefinition + my sequence_434 + my si:reduce_symbol_end FunctionDefinition + return + } + + method sequence_434 {} { + # x + # "function" + # (WSob) + # (Identifier) + # (WS) + # '\(' + # (WS) + # (ParameterDefinitions) + # (WS) + # '\)' + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str function + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Identifier + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \50 + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_ParameterDefinitions + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \51 + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + # + # leaf Symbol 'Identifier' + # + + method sym_Identifier {} { + # x + # ! + # (Keyword) + # / + # '_' + # "::" + # + # * + # / + # '_' + # "::" + # + + my si:void_symbol_start Identifier + my sequence_452 + my si:void_leaf_symbol_end Identifier + return + } + + method sequence_452 {} { + # x + # ! + # (Keyword) + # / + # '_' + # "::" + # + # * + # / + # '_' + # "::" + # + + my si:void_state_push + my notahead_438 + my si:voidvoid_part + my choice_443 + my si:voidvoid_part + my kleene_450 + my si:void_state_merge + return + } + + method notahead_438 {} { + # ! + # (Keyword) + + my i_loc_push + my sym_Keyword + my si:void_notahead_exit + return + } + + method choice_443 {} { + # / + # '_' + # "::" + # + + my si:void_state_push + my si:next_char _ + my si:voidvoid_branch + my si:next_str :: + my si:voidvoid_branch + my si:next_alpha + my si:void_state_merge + return + } + + method kleene_450 {} { + # * + # / + # '_' + # "::" + # + + while {1} { + my si:void2_state_push + my choice_448 + my si:kleene_close + } + return + } + + method choice_448 {} { + # / + # '_' + # "::" + # + + my si:void_state_push + my si:next_char _ + my si:voidvoid_branch + my si:next_str :: + my si:voidvoid_branch + my si:next_alnum + my si:void_state_merge + return + } + + # + # value Symbol 'IdentifierList' + # + + method sym_IdentifierList {} { + # x + # (Identifier) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Identifier) + + my si:value_symbol_start IdentifierList + my sequence_464 + my si:reduce_symbol_end IdentifierList + return + } + + method sequence_464 {} { + # x + # (Identifier) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Identifier) + + my si:value_state_push + my sym_Identifier + my si:valuevalue_part + my kleene_462 + my si:value_state_merge + return + } + + method kleene_462 {} { + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Identifier) + + while {1} { + my si:void2_state_push + my sequence_460 + my si:kleene_close + } + return + } + + method sequence_460 {} { + # x + # (WSNL) + # ',' + # (WSNL) + # (Identifier) + + my si:void_state_push + my sym_WSNL + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WSNL + my si:voidvalue_part + my sym_Identifier + my si:value_state_merge + return + } + + # + # value Symbol 'IfStatement' + # + + method sym_IfStatement {} { + # x + # "if" + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + # * + # x + # (WSob) + # (ElseifClause) + # ? + # x + # (WSob) + # (ElseClause) + + my si:value_symbol_start IfStatement + my sequence_486 + my si:reduce_symbol_end IfStatement + return + } + + method sequence_486 {} { + # x + # "if" + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + # * + # x + # (WSob) + # (ElseifClause) + # ? + # x + # (WSob) + # (ElseClause) + + my si:void_state_push + my si:next_str if + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:valuevalue_part + my kleene_478 + my si:valuevalue_part + my optional_484 + my si:value_state_merge + return + } + + method kleene_478 {} { + # * + # x + # (WSob) + # (ElseifClause) + + while {1} { + my si:void2_state_push + my sequence_476 + my si:kleene_close + } + return + } + + method sequence_476 {} { + # x + # (WSob) + # (ElseifClause) + + my si:void_state_push + my sym_WSob + my si:voidvalue_part + my sym_ElseifClause + my si:value_state_merge + return + } + + method optional_484 {} { + # ? + # x + # (WSob) + # (ElseClause) + + my si:void2_state_push + my sequence_482 + my si:void_state_merge_ok + return + } + + method sequence_482 {} { + # x + # (WSob) + # (ElseClause) + + my si:void_state_push + my sym_WSob + my si:voidvalue_part + my sym_ElseClause + my si:value_state_merge + return + } + + # + # leaf Symbol 'IndirectIdentifier' + # + + method sym_IndirectIdentifier {} { + # x + # '$' + # (Identifier) + + my si:value_symbol_start IndirectIdentifier + my sequence_491 + my si:value_leaf_symbol_end IndirectIdentifier + return + } + + method sequence_491 {} { + # x + # '$' + # (Identifier) + + my si:void_state_push + my si:next_char $ + my si:voidvalue_part + my sym_Identifier + my si:value_state_merge + return + } + + # + # value Symbol 'IndirectLiteral' + # + + method sym_IndirectLiteral {} { + # x + # '$' + # (String) + + my si:value_symbol_start IndirectLiteral + my sequence_496 + my si:reduce_symbol_end IndirectLiteral + return + } + + method sequence_496 {} { + # x + # '$' + # (String) + + my si:void_state_push + my si:next_char $ + my si:voidvalue_part + my sym_String + my si:value_state_merge + return + } + + # + # void Symbol 'Keyword' + # + + method sym_Keyword {} { + # / + # "if" + # "while" + # "for" + # "foreach" + # "function" + # "try" + # "throw" + # "return" + # "break" + # "continue" + + my si:void_void_symbol_start Keyword + my choice_509 + my si:void_clear_symbol_end Keyword + return + } + + method choice_509 {} { + # / + # "if" + # "while" + # "for" + # "foreach" + # "function" + # "try" + # "throw" + # "return" + # "break" + # "continue" + + my si:void_state_push + my si:next_str if + my si:voidvoid_branch + my si:next_str while + my si:voidvoid_branch + my si:next_str for + my si:voidvoid_branch + my si:next_str foreach + my si:voidvoid_branch + my si:next_str function + my si:voidvoid_branch + my si:next_str try + my si:voidvoid_branch + my si:next_str throw + my si:voidvoid_branch + my si:next_str return + my si:voidvoid_branch + my si:next_str break + my si:voidvoid_branch + my si:next_str continue + my si:void_state_merge + return + } + + # + # value Symbol 'ListCast' + # + + method sym_ListCast {} { + # x + # "@list" + # (WS) + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + + my si:value_symbol_start ListCast + my sequence_519 + my si:reduce_symbol_end ListCast + return + } + + method sequence_519 {} { + # x + # "@list" + # (WS) + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + + my si:void_state_push + my si:next_str @list + my si:voidvoid_part + my sym_WS + my si:voidvoid_part + my si:next_char \50 + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \51 + my si:value_state_merge + return + } + + # + # value Symbol 'LogicalAndExpr' + # + + method sym_LogicalAndExpr {} { + # x + # (RangeExpr) + # * + # x + # (WS) + # (LogicalAndOp) + # (WS) + # (RangeExpr) + + my si:value_symbol_start LogicalAndExpr + my sequence_531 + my si:reduce_symbol_end LogicalAndExpr + return + } + + method sequence_531 {} { + # x + # (RangeExpr) + # * + # x + # (WS) + # (LogicalAndOp) + # (WS) + # (RangeExpr) + + my si:value_state_push + my sym_RangeExpr + my si:valuevalue_part + my kleene_529 + my si:value_state_merge + return + } + + method kleene_529 {} { + # * + # x + # (WS) + # (LogicalAndOp) + # (WS) + # (RangeExpr) + + while {1} { + my si:void2_state_push + my sequence_527 + my si:kleene_close + } + return + } + + method sequence_527 {} { + # x + # (WS) + # (LogicalAndOp) + # (WS) + # (RangeExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_LogicalAndOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_RangeExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'LogicalAndOp' + # + + method sym_LogicalAndOp {} { + # "&&" + + my si:void_symbol_start LogicalAndOp + my si:next_str && + my si:void_leaf_symbol_end LogicalAndOp + return + } + + # + # value Symbol 'LogicalOrExpr' + # + + method sym_LogicalOrExpr {} { + # x + # (LogicalAndExpr) + # * + # x + # (WS) + # (LogicalOrOp) + # (WS) + # (LogicalAndExpr) + + my si:value_symbol_start LogicalOrExpr + my sequence_545 + my si:reduce_symbol_end LogicalOrExpr + return + } + + method sequence_545 {} { + # x + # (LogicalAndExpr) + # * + # x + # (WS) + # (LogicalOrOp) + # (WS) + # (LogicalAndExpr) + + my si:value_state_push + my sym_LogicalAndExpr + my si:valuevalue_part + my kleene_543 + my si:value_state_merge + return + } + + method kleene_543 {} { + # * + # x + # (WS) + # (LogicalOrOp) + # (WS) + # (LogicalAndExpr) + + while {1} { + my si:void2_state_push + my sequence_541 + my si:kleene_close + } + return + } + + method sequence_541 {} { + # x + # (WS) + # (LogicalOrOp) + # (WS) + # (LogicalAndExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_LogicalOrOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_LogicalAndExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'LogicalOrOp' + # + + method sym_LogicalOrOp {} { + # "||" + + my si:void_symbol_start LogicalOrOp + my si:next_str || + my si:void_leaf_symbol_end LogicalOrOp + return + } + + # + # value Symbol 'LValue' + # + + method sym_LValue {} { + # x + # (Identifier) + # (WS) + # ? + # / + # (Element) + # (TableColumns) + # ? + # x + # (WS) + # '[' + # (WS) + # / + # (Range) + # (Expression) + # (WS) + # ']' + + my si:value_symbol_start LValue + my sequence_571 + my si:reduce_symbol_end LValue + return + } + + method sequence_571 {} { + # x + # (Identifier) + # (WS) + # ? + # / + # (Element) + # (TableColumns) + # ? + # x + # (WS) + # '[' + # (WS) + # / + # (Range) + # (Expression) + # (WS) + # ']' + + my si:value_state_push + my sym_Identifier + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my optional_556 + my si:valuevalue_part + my optional_569 + my si:value_state_merge + return + } + + method optional_556 {} { + # ? + # / + # (Element) + # (TableColumns) + + my si:void2_state_push + my choice_554 + my si:void_state_merge_ok + return + } + + method choice_554 {} { + # / + # (Element) + # (TableColumns) + + my si:value_state_push + my sym_Element + my si:valuevalue_branch + my sym_TableColumns + my si:value_state_merge + return + } + + method optional_569 {} { + # ? + # x + # (WS) + # '[' + # (WS) + # / + # (Range) + # (Expression) + # (WS) + # ']' + + my si:void2_state_push + my sequence_567 + my si:void_state_merge_ok + return + } + + method sequence_567 {} { + # x + # (WS) + # '[' + # (WS) + # / + # (Range) + # (Expression) + # (WS) + # ']' + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_char \133 + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my choice_563 + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \135 + my si:value_state_merge + return + } + + method choice_563 {} { + # / + # (Range) + # (Expression) + + my si:void_state_push + my i_status_fail ; # Undefined symbol 'Range' + my si:voidvalue_branch + my sym_Expression + my si:value_state_merge + return + } + + # + # value Symbol 'MulExpr' + # + + method sym_MulExpr {} { + # x + # (UnaryExpr) + # * + # x + # (WS) + # (MulOp) + # (WS) + # (UnaryExpr) + + my si:value_symbol_start MulExpr + my sequence_583 + my si:reduce_symbol_end MulExpr + return + } + + method sequence_583 {} { + # x + # (UnaryExpr) + # * + # x + # (WS) + # (MulOp) + # (WS) + # (UnaryExpr) + + my si:value_state_push + my sym_UnaryExpr + my si:valuevalue_part + my kleene_581 + my si:value_state_merge + return + } + + method kleene_581 {} { + # * + # x + # (WS) + # (MulOp) + # (WS) + # (UnaryExpr) + + while {1} { + my si:void2_state_push + my sequence_579 + my si:kleene_close + } + return + } + + method sequence_579 {} { + # x + # (WS) + # (MulOp) + # (WS) + # (UnaryExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_MulOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_UnaryExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'MulOp' + # + + method sym_MulOp {} { + # [*/] + + my si:void_symbol_start MulOp + my si:next_class */ + my si:void_leaf_symbol_end MulOp + return + } + + # + # leaf Symbol 'Number' + # + + method sym_Number {} { + # / + # x + # "0x" + # + + # + # x + # + + # + # ? + # x + # '.' + # + + # + # ? + # x + # [eE] + # ? + # [+-] + # + + # + + my si:void_symbol_start Number + my choice_616 + my si:void_leaf_symbol_end Number + return + } + + method choice_616 {} { + # / + # x + # "0x" + # + + # + # x + # + + # + # ? + # x + # '.' + # + + # + # ? + # x + # [eE] + # ? + # [+-] + # + + # + + my si:void_state_push + my sequence_592 + my si:voidvoid_branch + my sequence_614 + my si:void_state_merge + return + } + + method sequence_592 {} { + # x + # "0x" + # + + # + + my si:void_state_push + my si:next_str 0x + my si:voidvoid_part + my poskleene_590 + my si:void_state_merge + return + } + + method poskleene_590 {} { + # + + # + + my i_loc_push + my si:next_xdigit + my si:kleene_abort + while {1} { + my si:void2_state_push + my si:next_xdigit + my si:kleene_close + } + return + } + + method sequence_614 {} { + # x + # + + # + # ? + # x + # '.' + # + + # + # ? + # x + # [eE] + # ? + # [+-] + # + + # + + my si:void_state_push + my poskleene_595 + my si:voidvoid_part + my optional_602 + my si:voidvoid_part + my optional_612 + my si:void_state_merge + return + } + + method poskleene_595 {} { + # + + # + + my i_loc_push + my si:next_ddigit + my si:kleene_abort + while {1} { + my si:void2_state_push + my si:next_ddigit + my si:kleene_close + } + return + } + + method optional_602 {} { + # ? + # x + # '.' + # + + # + + my si:void2_state_push + my sequence_600 + my si:void_state_merge_ok + return + } + + method sequence_600 {} { + # x + # '.' + # + + # + + my si:void_state_push + my si:next_char . + my si:voidvoid_part + my poskleene_595 + my si:void_state_merge + return + } + + method optional_612 {} { + # ? + # x + # [eE] + # ? + # [+-] + # + + # + + my si:void2_state_push + my sequence_610 + my si:void_state_merge_ok + return + } + + method sequence_610 {} { + # x + # [eE] + # ? + # [+-] + # + + # + + my si:void_state_push + my si:next_class eE + my si:voidvoid_part + my optional_606 + my si:voidvoid_part + my poskleene_595 + my si:void_state_merge + return + } + + method optional_606 {} { + # ? + # [+-] + + my si:void2_state_push + my si:next_class +- + my si:void_state_merge_ok + return + } + + # + # value Symbol 'OnHandler' + # + + method sym_OnHandler {} { + # x + # "on" + # (WSob) + # (ReturnCode) + # * + # x + # (WSob) + # (Identifier) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start OnHandler + my sequence_632 + my si:reduce_symbol_end OnHandler + return + } + + method sequence_632 {} { + # x + # "on" + # (WSob) + # (ReturnCode) + # * + # x + # (WSob) + # (Identifier) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str on + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_ReturnCode + my si:valuevalue_part + my kleene_626 + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + method kleene_626 {} { + # * + # x + # (WSob) + # (Identifier) + + while {1} { + my si:void2_state_push + my sequence_624 + my si:kleene_close + } + return + } + + method sequence_624 {} { + # x + # (WSob) + # (Identifier) + + my si:void_state_push + my sym_WSob + my si:voidvalue_part + my sym_Identifier + my si:value_state_merge + return + } + + # + # leaf Symbol 'OptionString' + # + + method sym_OptionString {} { + # x + # '-' + # + + # / + # [_-] + # + + my si:void_symbol_start OptionString + my sequence_642 + my si:void_leaf_symbol_end OptionString + return + } + + method sequence_642 {} { + # x + # '-' + # + + # / + # [_-] + # + + my si:void_state_push + my si:next_char - + my si:voidvoid_part + my poskleene_640 + my si:void_state_merge + return + } + + method poskleene_640 {} { + # + + # / + # [_-] + # + + my i_loc_push + my choice_638 + my si:kleene_abort + while {1} { + my si:void2_state_push + my choice_638 + my si:kleene_close + } + return + } + + method choice_638 {} { + # / + # [_-] + # + + my si:void_state_push + my si:next_class _- + my si:voidvoid_branch + my si:next_alnum + my si:void_state_merge + return + } + + # + # value Symbol 'Parameter' + # + + method sym_Parameter {} { + # x + # (ParameterIdentifier) + # ? + # x + # (WS) + # '=' + # (WS) + # (Expression) + + my si:value_symbol_start Parameter + my sequence_654 + my si:reduce_symbol_end Parameter + return + } + + method sequence_654 {} { + # x + # (ParameterIdentifier) + # ? + # x + # (WS) + # '=' + # (WS) + # (Expression) + + my si:value_state_push + my sym_ParameterIdentifier + my si:valuevalue_part + my optional_652 + my si:value_state_merge + return + } + + method optional_652 {} { + # ? + # x + # (WS) + # '=' + # (WS) + # (Expression) + + my si:void2_state_push + my sequence_650 + my si:void_state_merge_ok + return + } + + method sequence_650 {} { + # x + # (WS) + # '=' + # (WS) + # (Expression) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_char = + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:value_state_merge + return + } + + # + # value Symbol 'ParameterDefinitions' + # + + method sym_ParameterDefinitions {} { + # ? + # x + # (Parameter) + # * + # x + # (WS) + # ',' + # (WS) + # (Parameter) + + my si:value_symbol_start ParameterDefinitions + my optional_668 + my si:reduce_symbol_end ParameterDefinitions + return + } + + method optional_668 {} { + # ? + # x + # (Parameter) + # * + # x + # (WS) + # ',' + # (WS) + # (Parameter) + + my si:void2_state_push + my sequence_666 + my si:void_state_merge_ok + return + } + + method sequence_666 {} { + # x + # (Parameter) + # * + # x + # (WS) + # ',' + # (WS) + # (Parameter) + + my si:value_state_push + my sym_Parameter + my si:valuevalue_part + my kleene_664 + my si:value_state_merge + return + } + + method kleene_664 {} { + # * + # x + # (WS) + # ',' + # (WS) + # (Parameter) + + while {1} { + my si:void2_state_push + my sequence_662 + my si:kleene_close + } + return + } + + method sequence_662 {} { + # x + # (WS) + # ',' + # (WS) + # (Parameter) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Parameter + my si:value_state_merge + return + } + + # + # leaf Symbol 'ParameterIdentifier' + # + + method sym_ParameterIdentifier {} { + # x + # / + # '_' + # + # * + # / + # '_' + # + + my si:void_symbol_start ParameterIdentifier + my sequence_681 + my si:void_leaf_symbol_end ParameterIdentifier + return + } + + method sequence_681 {} { + # x + # / + # '_' + # + # * + # / + # '_' + # + + my si:void_state_push + my choice_673 + my si:voidvoid_part + my kleene_679 + my si:void_state_merge + return + } + + method choice_673 {} { + # / + # '_' + # + + my si:void_state_push + my si:next_char _ + my si:voidvoid_branch + my si:next_alpha + my si:void_state_merge + return + } + + method kleene_679 {} { + # * + # / + # '_' + # + + while {1} { + my si:void2_state_push + my choice_677 + my si:kleene_close + } + return + } + + method choice_677 {} { + # / + # '_' + # + + my si:void_state_push + my si:next_char _ + my si:voidvoid_branch + my si:next_alnum + my si:void_state_merge + return + } + + # + # leaf Symbol 'PlainString' + # + + method sym_PlainString {} { + # x + # (SingleQuote) + # * + # x + # ! + # (SingleQuote) + # (Char) + # (SingleQuote) + + my si:void_symbol_start PlainString + my sequence_694 + my si:void_leaf_symbol_end PlainString + return + } + + method sequence_694 {} { + # x + # (SingleQuote) + # * + # x + # ! + # (SingleQuote) + # (Char) + # (SingleQuote) + + my si:void_state_push + my sym_SingleQuote + my si:voidvoid_part + my kleene_691 + my si:voidvoid_part + my sym_SingleQuote + my si:void_state_merge + return + } + + method kleene_691 {} { + # * + # x + # ! + # (SingleQuote) + # (Char) + + while {1} { + my si:void2_state_push + my sequence_689 + my si:kleene_close + } + return + } + + method sequence_689 {} { + # x + # ! + # (SingleQuote) + # (Char) + + my si:void_state_push + my notahead_686 + my si:voidvoid_part + my sym_Char + my si:void_state_merge + return + } + + method notahead_686 {} { + # ! + # (SingleQuote) + + my i_loc_push + my sym_SingleQuote + my si:void_notahead_exit + return + } + + # + # value Symbol 'PostfixExpr' + # + + method sym_PostfixExpr {} { + # x + # (PrimaryExpr) + # * + # x + # (WS) + # (PostfixOp) + + my si:value_symbol_start PostfixExpr + my sequence_704 + my si:reduce_symbol_end PostfixExpr + return + } + + method sequence_704 {} { + # x + # (PrimaryExpr) + # * + # x + # (WS) + # (PostfixOp) + + my si:value_state_push + my sym_PrimaryExpr + my si:valuevalue_part + my kleene_702 + my si:value_state_merge + return + } + + method kleene_702 {} { + # * + # x + # (WS) + # (PostfixOp) + + while {1} { + my si:void2_state_push + my sequence_700 + my si:kleene_close + } + return + } + + method sequence_700 {} { + # x + # (WS) + # (PostfixOp) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_PostfixOp + my si:value_state_merge + return + } + + # + # value Symbol 'PostfixOp' + # + + method sym_PostfixOp {} { + # / + # (Selector) + # (FunctionCall) + # (Element) + # (TableColumns) + + my si:value_symbol_start PostfixOp + my choice_711 + my si:reduce_symbol_end PostfixOp + return + } + + method choice_711 {} { + # / + # (Selector) + # (FunctionCall) + # (Element) + # (TableColumns) + + my si:value_state_push + my sym_Selector + my si:valuevalue_branch + my sym_FunctionCall + my si:valuevalue_branch + my sym_Element + my si:valuevalue_branch + my sym_TableColumns + my si:value_state_merge + return + } + + # + # leaf Symbol 'PowOp' + # + + method sym_PowOp {} { + # "**" + + my si:void_symbol_start PowOp + my si:next_str ** + my si:void_leaf_symbol_end PowOp + return + } + + # + # value Symbol 'PrimaryExpr' + # + + method sym_PrimaryExpr {} { + # / + # (BuiltIn) + # (BuiltInCall) + # (IndirectIdentifier) + # (IndirectLiteral) + # (Identifier) + # (Number) + # (String) + # (Sequence) + # x + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + + my si:value_symbol_start PrimaryExpr + my choice_730 + my si:reduce_symbol_end PrimaryExpr + return + } + + method choice_730 {} { + # / + # (BuiltIn) + # (BuiltInCall) + # (IndirectIdentifier) + # (IndirectLiteral) + # (Identifier) + # (Number) + # (String) + # (Sequence) + # x + # '\(' + # (WS) + # (Expression) + # (WS) + # '\)' + + my si:value_state_push + my sym_BuiltIn + my si:valuevalue_branch + my sym_BuiltInCall + my si:valuevalue_branch + my sym_IndirectIdentifier + my si:valuevalue_branch + my sym_IndirectLiteral + my si:valuevalue_branch + my sym_Identifier + my si:valuevalue_branch + my sym_Number + my si:valuevalue_branch + my sym_String + my si:valuevalue_branch + my sym_Sequence + my si:valuevalue_branch + my sequence_212 + my si:value_state_merge + return + } + + # + # value Symbol 'Program' + # + + method sym_Program {} { + # x + # (Block) + # ? + # (Comment) + # (EOF) + + my si:value_symbol_start Program + my sequence_738 + my si:reduce_symbol_end Program + return + } + + method sequence_738 {} { + # x + # (Block) + # ? + # (Comment) + # (EOF) + + my si:value_state_push + my sym_Block + my si:valuevalue_part + my optional_735 + my si:valuevalue_part + my sym_EOF + my si:value_state_merge + return + } + + method optional_735 {} { + # ? + # (Comment) + + my si:void2_state_push + my sym_Comment + my si:void_state_merge_ok + return + } + + # + # void Symbol 'Quote' + # + + method sym_Quote {} { + # '\"' + + my si:void_void_symbol_start Quote + my si:next_char \42 + my si:void_clear_symbol_end Quote + return + } + + # + # value Symbol 'RangeExpr' + # + + method sym_RangeExpr {} { + # / + # x + # (BitOrExpr) + # (WS) + # (RangeSeparator) + # ? + # x + # (WS) + # (BitOrExpr) + # (BitOrExpr) + + my si:value_symbol_start RangeExpr + my choice_755 + my si:reduce_symbol_end RangeExpr + return + } + + method choice_755 {} { + # / + # x + # (BitOrExpr) + # (WS) + # (RangeSeparator) + # ? + # x + # (WS) + # (BitOrExpr) + # (BitOrExpr) + + my si:value_state_push + my sequence_752 + my si:valuevalue_branch + my sym_BitOrExpr + my si:value_state_merge + return + } + + method sequence_752 {} { + # x + # (BitOrExpr) + # (WS) + # (RangeSeparator) + # ? + # x + # (WS) + # (BitOrExpr) + + my si:value_state_push + my sym_BitOrExpr + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_RangeSeparator + my si:valuevalue_part + my optional_750 + my si:value_state_merge + return + } + + method optional_750 {} { + # ? + # x + # (WS) + # (BitOrExpr) + + my si:void2_state_push + my sequence_748 + my si:void_state_merge_ok + return + } + + method sequence_748 {} { + # x + # (WS) + # (BitOrExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_BitOrExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'RangeSeparator' + # + + method sym_RangeSeparator {} { + # ':' + + my si:void_symbol_start RangeSeparator + my si:next_char : + my si:void_leaf_symbol_end RangeSeparator + return + } + + # + # value Symbol 'RelExpr' + # + + method sym_RelExpr {} { + # x + # (AddExpr) + # ? + # x + # (WS) + # (RelOp) + # (WS) + # (AddExpr) + + my si:value_symbol_start RelExpr + my sequence_769 + my si:reduce_symbol_end RelExpr + return + } + + method sequence_769 {} { + # x + # (AddExpr) + # ? + # x + # (WS) + # (RelOp) + # (WS) + # (AddExpr) + + my si:value_state_push + my sym_AddExpr + my si:valuevalue_part + my optional_767 + my si:value_state_merge + return + } + + method optional_767 {} { + # ? + # x + # (WS) + # (RelOp) + # (WS) + # (AddExpr) + + my si:void2_state_push + my sequence_765 + my si:void_state_merge_ok + return + } + + method sequence_765 {} { + # x + # (WS) + # (RelOp) + # (WS) + # (AddExpr) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_RelOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_AddExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'RelOp' + # + + method sym_RelOp {} { + # / + # "==" + # "!=" + # "<=" + # ">=" + # [<>] + # "=^" + # "!^" + # "~^" + # '~' + # "!~^" + # "!~" + + my si:void_symbol_start RelOp + my choice_783 + my si:void_leaf_symbol_end RelOp + return + } + + method choice_783 {} { + # / + # "==" + # "!=" + # "<=" + # ">=" + # [<>] + # "=^" + # "!^" + # "~^" + # '~' + # "!~^" + # "!~" + + my si:void_state_push + my si:next_str == + my si:voidvoid_branch + my si:next_str != + my si:voidvoid_branch + my si:next_str <= + my si:voidvoid_branch + my si:next_str >= + my si:voidvoid_branch + my si:next_class <> + my si:voidvoid_branch + my si:next_str =^ + my si:voidvoid_branch + my si:next_str !^ + my si:voidvoid_branch + my si:next_str ~^ + my si:voidvoid_branch + my si:next_char ~ + my si:voidvoid_branch + my si:next_str !~^ + my si:voidvoid_branch + my si:next_str !~ + my si:void_state_merge + return + } + + # + # value Symbol 'ReturnCode' + # + + method sym_ReturnCode {} { + # / + # "error" + # "ok" + # "continue" + # "return" + # "break" + # x + # ? + # '-' + # + + # + + my si:void_symbol_start ReturnCode + my choice_799 + my si:void_leaf_symbol_end ReturnCode + return + } + + method choice_799 {} { + # / + # "error" + # "ok" + # "continue" + # "return" + # "break" + # x + # ? + # '-' + # + + # + + my si:void_state_push + my si:next_str error + my si:voidvoid_branch + my si:next_str ok + my si:voidvoid_branch + my si:next_str continue + my si:voidvoid_branch + my si:next_str return + my si:voidvoid_branch + my si:next_str break + my si:voidvoid_branch + my sequence_797 + my si:void_state_merge + return + } + + method sequence_797 {} { + # x + # ? + # '-' + # + + # + + my si:void_state_push + my optional_792 + my si:voidvoid_part + my poskleene_795 + my si:void_state_merge + return + } + + method optional_792 {} { + # ? + # '-' + + my si:void2_state_push + my si:next_char - + my si:void_state_merge_ok + return + } + + method poskleene_795 {} { + # + + # + + my i_loc_push + my si:next_digit + my si:kleene_abort + while {1} { + my si:void2_state_push + my si:next_digit + my si:kleene_close + } + return + } + + # + # value Symbol 'ReturnStatement' + # + + method sym_ReturnStatement {} { + # x + # "return" + # ? + # x + # (WSob) + # (Expression) + + my si:value_symbol_start ReturnStatement + my sequence_809 + my si:reduce_symbol_end ReturnStatement + return + } + + method sequence_809 {} { + # x + # "return" + # ? + # x + # (WSob) + # (Expression) + + my si:void_state_push + my si:next_str return + my si:voidvalue_part + my optional_807 + my si:value_state_merge + return + } + + method optional_807 {} { + # ? + # x + # (WSob) + # (Expression) + + my si:void2_state_push + my sequence_805 + my si:void_state_merge_ok + return + } + + method sequence_805 {} { + # x + # (WSob) + # (Expression) + + my si:void_state_push + my sym_WSob + my si:voidvalue_part + my sym_Expression + my si:value_state_merge + return + } + + # + # value Symbol 'SearchCommand' + # + + method sym_SearchCommand {} { + # x + # "@search" + # (WS) + # (PostfixExpr) + # ? + # x + # (WS) + # (SearchTarget) + # (WS) + # (RelOp) + # (WS) + # (PostfixExpr) + # (WS) + # * + # x + # (WS) + # (SearchOption) + + my si:value_symbol_start SearchCommand + my sequence_832 + my si:reduce_symbol_end SearchCommand + return + } + + method sequence_832 {} { + # x + # "@search" + # (WS) + # (PostfixExpr) + # ? + # x + # (WS) + # (SearchTarget) + # (WS) + # (RelOp) + # (WS) + # (PostfixExpr) + # (WS) + # * + # x + # (WS) + # (SearchOption) + + my si:void_state_push + my si:next_str @search + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_PostfixExpr + my si:valuevalue_part + my optional_819 + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_RelOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_PostfixExpr + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my kleene_830 + my si:value_state_merge + return + } + + method optional_819 {} { + # ? + # x + # (WS) + # (SearchTarget) + + my si:void2_state_push + my sequence_817 + my si:void_state_merge_ok + return + } + + method sequence_817 {} { + # x + # (WS) + # (SearchTarget) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_SearchTarget + my si:value_state_merge + return + } + + method kleene_830 {} { + # * + # x + # (WS) + # (SearchOption) + + while {1} { + my si:void2_state_push + my sequence_828 + my si:kleene_close + } + return + } + + method sequence_828 {} { + # x + # (WS) + # (SearchOption) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_SearchOption + my si:value_state_merge + return + } + + # + # leaf Symbol 'SearchOption' + # + + method sym_SearchOption {} { + # / + # "inline" + # "all" + + my si:void_symbol_start SearchOption + my choice_837 + my si:void_leaf_symbol_end SearchOption + return + } + + method choice_837 {} { + # / + # "inline" + # "all" + + my si:void_state_push + my si:next_str inline + my si:voidvoid_branch + my si:next_str all + my si:void_state_merge + return + } + + # + # value Symbol 'SearchTarget' + # + + method sym_SearchTarget {} { + # x + # "->" + # (WS) + # (PostfixExpr) + + my si:value_symbol_start SearchTarget + my sequence_843 + my si:reduce_symbol_end SearchTarget + return + } + + method sequence_843 {} { + # x + # "->" + # (WS) + # (PostfixExpr) + + my si:void_state_push + my si:next_str -> + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_PostfixExpr + my si:value_state_merge + return + } + + # + # value Symbol 'Selector' + # + + method sym_Selector {} { + # x + # '[' + # (WS) + # (Expression) + # (WS) + # ']' + + my si:value_symbol_start Selector + my sequence_256 + my si:reduce_symbol_end Selector + return + } + + # + # leaf Symbol 'SelectorContext' + # + + method sym_SelectorContext {} { + # "@@" + + my si:void_symbol_start SelectorContext + my si:next_str @@ + my si:void_leaf_symbol_end SelectorContext + return + } + + # + # void Symbol 'Separator' + # + + method sym_Separator {} { + # / + # x + # ? + # (Comment) + # (EOL) + # ';' + + my si:void_void_symbol_start Separator + my choice_861 + my si:void_clear_symbol_end Separator + return + } + + method choice_861 {} { + # / + # x + # ? + # (Comment) + # (EOL) + # ';' + + my si:void_state_push + my sequence_858 + my si:voidvoid_branch + my si:next_char \73 + my si:void_state_merge + return + } + + method sequence_858 {} { + # x + # ? + # (Comment) + # (EOL) + + my si:void_state_push + my optional_735 + my si:voidvoid_part + my sym_EOL + my si:void_state_merge + return + } + + # + # value Symbol 'Sequence' + # + + method sym_Sequence {} { + # x + # '\{' + # (WSNL) + # ? + # (SequenceContent) + # (WSNL) + # '\}' + + my si:value_symbol_start Sequence + my sequence_871 + my si:reduce_symbol_end Sequence + return + } + + method sequence_871 {} { + # x + # '\{' + # (WSNL) + # ? + # (SequenceContent) + # (WSNL) + # '\}' + + my si:void_state_push + my si:next_char \173 + my si:voidvoid_part + my sym_WSNL + my si:voidvalue_part + my optional_867 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + method optional_867 {} { + # ? + # (SequenceContent) + + my si:void2_state_push + my sym_SequenceContent + my si:void_state_merge_ok + return + } + + # + # value Symbol 'SequenceContent' + # + + method sym_SequenceContent {} { + # x + # (Expression) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Expression) + + my si:value_symbol_start SequenceContent + my sequence_883 + my si:reduce_symbol_end SequenceContent + return + } + + method sequence_883 {} { + # x + # (Expression) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Expression) + + my si:value_state_push + my sym_Expression + my si:valuevalue_part + my kleene_881 + my si:value_state_merge + return + } + + method kleene_881 {} { + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (Expression) + + while {1} { + my si:void2_state_push + my sequence_879 + my si:kleene_close + } + return + } + + method sequence_879 {} { + # x + # (WSNL) + # ',' + # (WSNL) + # (Expression) + + my si:void_state_push + my sym_WSNL + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WSNL + my si:voidvalue_part + my sym_Expression + my si:value_state_merge + return + } + + # + # void Symbol 'SingleQuote' + # + + method sym_SingleQuote {} { + # ''' + + my si:void_void_symbol_start SingleQuote + my si:next_char ' + my si:void_clear_symbol_end SingleQuote + return + } + + # + # value Symbol 'SortCommand' + # + + method sym_SortCommand {} { + # x + # "@sort" + # (WS) + # (Expression) + # ? + # x + # (WS) + # "->" + # (WS) + # (Expression) + # ? + # x + # (WS) + # (SortOptions) + + my si:value_symbol_start SortCommand + my sequence_905 + my si:reduce_symbol_end SortCommand + return + } + + method sequence_905 {} { + # x + # "@sort" + # (WS) + # (Expression) + # ? + # x + # (WS) + # "->" + # (WS) + # (Expression) + # ? + # x + # (WS) + # (SortOptions) + + my si:void_state_push + my si:next_str @sort + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my optional_897 + my si:valuevalue_part + my optional_903 + my si:value_state_merge + return + } + + method optional_897 {} { + # ? + # x + # (WS) + # "->" + # (WS) + # (Expression) + + my si:void2_state_push + my sequence_895 + my si:void_state_merge_ok + return + } + + method sequence_895 {} { + # x + # (WS) + # "->" + # (WS) + # (Expression) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_str -> + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:value_state_merge + return + } + + method optional_903 {} { + # ? + # x + # (WS) + # (SortOptions) + + my si:void2_state_push + my sequence_901 + my si:void_state_merge_ok + return + } + + method sequence_901 {} { + # x + # (WS) + # (SortOptions) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_SortOptions + my si:value_state_merge + return + } + + # + # leaf Symbol 'SortOption' + # + + method sym_SortOption {} { + # / + # "indices" + # "nocase" + # "increasing" + # "decreasing" + + my si:void_symbol_start SortOption + my choice_912 + my si:void_leaf_symbol_end SortOption + return + } + + method choice_912 {} { + # / + # "indices" + # "nocase" + # "increasing" + # "decreasing" + + my si:void_state_push + my si:next_str indices + my si:voidvoid_branch + my si:next_str nocase + my si:voidvoid_branch + my si:next_str increasing + my si:voidvoid_branch + my si:next_str decreasing + my si:void_state_merge + return + } + + # + # value Symbol 'SortOptions' + # + + method sym_SortOptions {} { + # x + # (SortOption) + # * + # x + # (WS) + # (SortOption) + + my si:value_symbol_start SortOptions + my sequence_922 + my si:reduce_symbol_end SortOptions + return + } + + method sequence_922 {} { + # x + # (SortOption) + # * + # x + # (WS) + # (SortOption) + + my si:value_state_push + my sym_SortOption + my si:valuevalue_part + my kleene_920 + my si:value_state_merge + return + } + + method kleene_920 {} { + # * + # x + # (WS) + # (SortOption) + + while {1} { + my si:void2_state_push + my sequence_918 + my si:kleene_close + } + return + } + + method sequence_918 {} { + # x + # (WS) + # (SortOption) + + my si:void_state_push + my sym_WS + my si:voidvalue_part + my sym_SortOption + my si:value_state_merge + return + } + + # + # value Symbol 'Statement' + # + + method sym_Statement {} { + # / + # (IfStatement) + # (WhileStatement) + # (ForRangeStatement) + # (ForEachStatement) + # (FunctionDefinition) + # (TryStatement) + # (ThrowStatement) + # (ReturnStatement) + # (BreakStatement) + # (ContinueStatement) + # (Assignment) + # (Expression) + # (TclScriptBlock) + # (Empty) + + my si:value_symbol_start Statement + my choice_939 + my si:reduce_symbol_end Statement + return + } + + method choice_939 {} { + # / + # (IfStatement) + # (WhileStatement) + # (ForRangeStatement) + # (ForEachStatement) + # (FunctionDefinition) + # (TryStatement) + # (ThrowStatement) + # (ReturnStatement) + # (BreakStatement) + # (ContinueStatement) + # (Assignment) + # (Expression) + # (TclScriptBlock) + # (Empty) + + my si:value_state_push + my sym_IfStatement + my si:valuevalue_branch + my sym_WhileStatement + my si:valuevalue_branch + my sym_ForRangeStatement + my si:valuevalue_branch + my sym_ForEachStatement + my si:valuevalue_branch + my sym_FunctionDefinition + my si:valuevalue_branch + my sym_TryStatement + my si:valuevalue_branch + my sym_ThrowStatement + my si:valuevalue_branch + my sym_ReturnStatement + my si:valuevalue_branch + my sym_BreakStatement + my si:valuevalue_branch + my sym_ContinueStatement + my si:valuevalue_branch + my sym_Assignment + my si:valuevalue_branch + my sym_Expression + my si:valuevalue_branch + my sym_TclScriptBlock + my si:valuevoid_branch + my sym_Empty + my si:void_state_merge + return + } + + # + # value Symbol 'String' + # + + method sym_String {} { + # / + # (PlainString) + # (TclString) + + my si:value_symbol_start String + my choice_944 + my si:reduce_symbol_end String + return + } + + method choice_944 {} { + # / + # (PlainString) + # (TclString) + + my si:value_state_push + my sym_PlainString + my si:valuevalue_branch + my sym_TclString + my si:value_state_merge + return + } + + # + # value Symbol 'TableColumnDef' + # + + method sym_TableColumnDef {} { + # x + # (ColumnIdentifier) + # (WSNL) + # (ColumnType) + + my si:value_symbol_start TableColumnDef + my sequence_950 + my si:reduce_symbol_end TableColumnDef + return + } + + method sequence_950 {} { + # x + # (ColumnIdentifier) + # (WSNL) + # (ColumnType) + + my si:value_state_push + my sym_ColumnIdentifier + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my sym_ColumnType + my si:value_state_merge + return + } + + # + # value Symbol 'TableColumnDefs' + # + + method sym_TableColumnDefs {} { + # x + # (TableColumnDef) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (TableColumnDef) + + my si:value_symbol_start TableColumnDefs + my sequence_962 + my si:reduce_symbol_end TableColumnDefs + return + } + + method sequence_962 {} { + # x + # (TableColumnDef) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (TableColumnDef) + + my si:value_state_push + my sym_TableColumnDef + my si:valuevalue_part + my kleene_960 + my si:value_state_merge + return + } + + method kleene_960 {} { + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (TableColumnDef) + + while {1} { + my si:void2_state_push + my sequence_958 + my si:kleene_close + } + return + } + + method sequence_958 {} { + # x + # (WSNL) + # ',' + # (WSNL) + # (TableColumnDef) + + my si:void_state_push + my sym_WSNL + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WSNL + my si:voidvalue_part + my sym_TableColumnDef + my si:value_state_merge + return + } + + # + # value Symbol 'TableColumnList' + # + + method sym_TableColumnList {} { + # x + # (ColumnIdentifier) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (ColumnIdentifier) + + my si:value_symbol_start TableColumnList + my sequence_974 + my si:reduce_symbol_end TableColumnList + return + } + + method sequence_974 {} { + # x + # (ColumnIdentifier) + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (ColumnIdentifier) + + my si:value_state_push + my sym_ColumnIdentifier + my si:valuevalue_part + my kleene_972 + my si:value_state_merge + return + } + + method kleene_972 {} { + # * + # x + # (WSNL) + # ',' + # (WSNL) + # (ColumnIdentifier) + + while {1} { + my si:void2_state_push + my sequence_970 + my si:kleene_close + } + return + } + + method sequence_970 {} { + # x + # (WSNL) + # ',' + # (WSNL) + # (ColumnIdentifier) + + my si:void_state_push + my sym_WSNL + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WSNL + my si:voidvalue_part + my sym_ColumnIdentifier + my si:value_state_merge + return + } + + # + # value Symbol 'TableColumns' + # + + method sym_TableColumns {} { + # x + # (ElementOp) + # (WS) + # '\(' + # (WSNL) + # ? + # (TableColumnList) + # (WSNL) + # '\)' + + my si:value_symbol_start TableColumns + my sequence_986 + my si:reduce_symbol_end TableColumns + return + } + + method sequence_986 {} { + # x + # (ElementOp) + # (WS) + # '\(' + # (WSNL) + # ? + # (TableColumnList) + # (WSNL) + # '\)' + + my si:value_state_push + my sym_ElementOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my si:next_char \50 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my optional_982 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my si:next_char \51 + my si:value_state_merge + return + } + + method optional_982 {} { + # ? + # (TableColumnList) + + my si:void2_state_push + my sym_TableColumnList + my si:void_state_merge_ok + return + } + + # + # value Symbol 'TableConstructor' + # + + method sym_TableConstructor {} { + # x + # "@table" + # (WS) + # '\(' + # (WSNL) + # ? + # (TableColumnDefs) + # (WSNL) + # '\)' + # (WS) + # ? + # (Sequence) + + my si:value_symbol_start TableConstructor + my sequence_1002 + my si:reduce_symbol_end TableConstructor + return + } + + method sequence_1002 {} { + # x + # "@table" + # (WS) + # '\(' + # (WSNL) + # ? + # (TableColumnDefs) + # (WSNL) + # '\)' + # (WS) + # ? + # (Sequence) + + my si:void_state_push + my si:next_str @table + my si:voidvoid_part + my sym_WS + my si:voidvoid_part + my si:next_char \50 + my si:voidvoid_part + my sym_WSNL + my si:voidvalue_part + my optional_994 + my si:valuevalue_part + my sym_WSNL + my si:valuevalue_part + my si:next_char \51 + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my optional_1000 + my si:value_state_merge + return + } + + method optional_994 {} { + # ? + # (TableColumnDefs) + + my si:void2_state_push + my sym_TableColumnDefs + my si:void_state_merge_ok + return + } + + method optional_1000 {} { + # ? + # (Sequence) + + my si:void2_state_push + my sym_Sequence + my si:void_state_merge_ok + return + } + + # + # leaf Symbol 'TclScript' + # + + method sym_TclScript {} { + # * + # x + # ! + # x + # '>' + # (TclScriptEndMarker) + # + + my si:void_symbol_start TclScript + my kleene_1014 + my si:void_leaf_symbol_end TclScript + return + } + + method kleene_1014 {} { + # * + # x + # ! + # x + # '>' + # (TclScriptEndMarker) + # + + while {1} { + my si:void2_state_push + my sequence_1012 + my si:kleene_close + } + return + } + + method sequence_1012 {} { + # x + # ! + # x + # '>' + # (TclScriptEndMarker) + # + + my si:void_state_push + my notahead_1009 + my si:voidvoid_part + my i_input_next dot + my si:void_state_merge + return + } + + method notahead_1009 {} { + # ! + # x + # '>' + # (TclScriptEndMarker) + + my i_loc_push + my sequence_1007 + my si:void_notahead_exit + return + } + + method sequence_1007 {} { + # x + # '>' + # (TclScriptEndMarker) + + my si:void_state_push + my si:next_char > + my si:voidvoid_part + my sym_TclScriptEndMarker + my si:void_state_merge + return + } + + # + # value Symbol 'TclScriptBlock' + # + + method sym_TclScriptBlock {} { + # x + # '<' + # (TclScript) + # '>' + # & + # (TclScriptEndMarker) + + my si:value_symbol_start TclScriptBlock + my sequence_1023 + my si:reduce_symbol_end TclScriptBlock + return + } + + method sequence_1023 {} { + # x + # '<' + # (TclScript) + # '>' + # & + # (TclScriptEndMarker) + + my si:void_state_push + my si:next_char < + my si:voidvalue_part + my sym_TclScript + my si:valuevalue_part + my si:next_char > + my si:valuevalue_part + my ahead_1021 + my si:value_state_merge + return + } + + method ahead_1021 {} { + # & + # (TclScriptEndMarker) + + my i_loc_push + my sym_TclScriptEndMarker + my i_loc_pop_rewind + return + } + + # + # void Symbol 'TclScriptEndMarker' + # + + method sym_TclScriptEndMarker {} { + # x + # (WS) + # / + # ';' + # (EOL) + # (EOF) + + my si:void_void_symbol_start TclScriptEndMarker + my sequence_1032 + my si:void_clear_symbol_end TclScriptEndMarker + return + } + + method sequence_1032 {} { + # x + # (WS) + # / + # ';' + # (EOL) + # (EOF) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my choice_1030 + my si:void_state_merge + return + } + + method choice_1030 {} { + # / + # ';' + # (EOL) + # (EOF) + + my si:void_state_push + my si:next_char \73 + my si:voidvoid_branch + my sym_EOL + my si:voidvoid_branch + my sym_EOF + my si:void_state_merge + return + } + + # + # leaf Symbol 'TclString' + # + + method sym_TclString {} { + # x + # (Quote) + # * + # x + # ! + # (Quote) + # (Char) + # (Quote) + + my si:void_symbol_start TclString + my sequence_1045 + my si:void_leaf_symbol_end TclString + return + } + + method sequence_1045 {} { + # x + # (Quote) + # * + # x + # ! + # (Quote) + # (Char) + # (Quote) + + my si:void_state_push + my sym_Quote + my si:voidvoid_part + my kleene_1042 + my si:voidvoid_part + my sym_Quote + my si:void_state_merge + return + } + + method kleene_1042 {} { + # * + # x + # ! + # (Quote) + # (Char) + + while {1} { + my si:void2_state_push + my sequence_1040 + my si:kleene_close + } + return + } + + method sequence_1040 {} { + # x + # ! + # (Quote) + # (Char) + + my si:void_state_push + my notahead_1037 + my si:voidvoid_part + my sym_Char + my si:void_state_merge + return + } + + method notahead_1037 {} { + # ! + # (Quote) + + my i_loc_push + my sym_Quote + my si:void_notahead_exit + return + } + + # + # value Symbol 'ThrowStatement' + # + + method sym_ThrowStatement {} { + # x + # "throw" + # (WSob) + # (Expression) + # * + # x + # (WS) + # ',' + # (WS) + # (Expression) + + my si:value_symbol_start ThrowStatement + my sequence_1059 + my si:reduce_symbol_end ThrowStatement + return + } + + method sequence_1059 {} { + # x + # "throw" + # (WSob) + # (Expression) + # * + # x + # (WS) + # ',' + # (WS) + # (Expression) + + my si:void_state_push + my si:next_str throw + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my kleene_1057 + my si:value_state_merge + return + } + + method kleene_1057 {} { + # * + # x + # (WS) + # ',' + # (WS) + # (Expression) + + while {1} { + my si:void2_state_push + my sequence_1055 + my si:kleene_close + } + return + } + + method sequence_1055 {} { + # x + # (WS) + # ',' + # (WS) + # (Expression) + + my si:void_state_push + my sym_WS + my si:voidvoid_part + my si:next_char , + my si:voidvoid_part + my sym_WS + my si:voidvalue_part + my sym_Expression + my si:value_state_merge + return + } + + # + # value Symbol 'TrapHandler' + # + + method sym_TrapHandler {} { + # x + # "trap" + # (WSob) + # (Sequence) + # * + # x + # (WSob) + # (Identifier) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start TrapHandler + my sequence_1073 + my si:reduce_symbol_end TrapHandler + return + } + + method sequence_1073 {} { + # x + # "trap" + # (WSob) + # (Sequence) + # * + # x + # (WSob) + # (Identifier) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str trap + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Sequence + my si:valuevalue_part + my kleene_626 + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + # + # value Symbol 'TryStatement' + # + + method sym_TryStatement {} { + # x + # "try" + # (WSob) + # '\{' + # (Block) + # '\}' + # * + # x + # (WSob) + # / + # (OnHandler) + # (TrapHandler) + # ? + # x + # (WSob) + # (FinallyClause) + + my si:value_symbol_start TryStatement + my sequence_1096 + my si:reduce_symbol_end TryStatement + return + } + + method sequence_1096 {} { + # x + # "try" + # (WSob) + # '\{' + # (Block) + # '\}' + # * + # x + # (WSob) + # / + # (OnHandler) + # (TrapHandler) + # ? + # x + # (WSob) + # (FinallyClause) + + my si:void_state_push + my si:next_str try + my si:voidvoid_part + my sym_WSob + my si:voidvoid_part + my si:next_char \173 + my si:voidvalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:valuevalue_part + my kleene_1088 + my si:valuevalue_part + my optional_1094 + my si:value_state_merge + return + } + + method kleene_1088 {} { + # * + # x + # (WSob) + # / + # (OnHandler) + # (TrapHandler) + + while {1} { + my si:void2_state_push + my sequence_1086 + my si:kleene_close + } + return + } + + method sequence_1086 {} { + # x + # (WSob) + # / + # (OnHandler) + # (TrapHandler) + + my si:void_state_push + my sym_WSob + my si:voidvalue_part + my choice_1084 + my si:value_state_merge + return + } + + method choice_1084 {} { + # / + # (OnHandler) + # (TrapHandler) + + my si:value_state_push + my sym_OnHandler + my si:valuevalue_branch + my sym_TrapHandler + my si:value_state_merge + return + } + + method optional_1094 {} { + # ? + # x + # (WSob) + # (FinallyClause) + + my si:void2_state_push + my sequence_1092 + my si:void_state_merge_ok + return + } + + method sequence_1092 {} { + # x + # (WSob) + # (FinallyClause) + + my si:void_state_push + my sym_WSob + my si:voidvalue_part + my sym_FinallyClause + my si:value_state_merge + return + } + + # + # value Symbol 'UnaryExpr' + # + + method sym_UnaryExpr {} { + # / + # (PostfixExpr) + # x + # (UnaryOp) + # (WS) + # (UnaryExpr) + + my si:value_symbol_start UnaryExpr + my choice_1105 + my si:reduce_symbol_end UnaryExpr + return + } + + method choice_1105 {} { + # / + # (PostfixExpr) + # x + # (UnaryOp) + # (WS) + # (UnaryExpr) + + my si:value_state_push + my sym_PostfixExpr + my si:valuevalue_branch + my sequence_1103 + my si:value_state_merge + return + } + + method sequence_1103 {} { + # x + # (UnaryOp) + # (WS) + # (UnaryExpr) + + my si:value_state_push + my sym_UnaryOp + my si:valuevalue_part + my sym_WS + my si:valuevalue_part + my sym_UnaryExpr + my si:value_state_merge + return + } + + # + # leaf Symbol 'UnaryOp' + # + + method sym_UnaryOp {} { + # [-+~!%] + + my si:void_symbol_start UnaryOp + my si:next_class -+~!% + my si:void_leaf_symbol_end UnaryOp + return + } + + # + # value Symbol 'WhileStatement' + # + + method sym_WhileStatement {} { + # x + # "while" + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:value_symbol_start WhileStatement + my sequence_1117 + my si:reduce_symbol_end WhileStatement + return + } + + method sequence_1117 {} { + # x + # "while" + # (WSob) + # (Expression) + # (WSob) + # '\{' + # (Block) + # '\}' + + my si:void_state_push + my si:next_str while + my si:voidvoid_part + my sym_WSob + my si:voidvalue_part + my sym_Expression + my si:valuevalue_part + my sym_WSob + my si:valuevalue_part + my si:next_char \173 + my si:valuevalue_part + my sym_Block + my si:valuevalue_part + my si:next_char \175 + my si:value_state_merge + return + } + + # + # void Symbol 'WS' + # + + method sym_WS {} { + # * + # / + # x + # '\' + # (EOL) + # x + # ! + # (EOL) + # + + my si:void_void_symbol_start WS + my kleene_1131 + my si:void_clear_symbol_end WS + return + } + + method kleene_1131 {} { + # * + # / + # x + # '\' + # (EOL) + # x + # ! + # (EOL) + # + + while {1} { + my si:void2_state_push + my choice_1129 + my si:kleene_close + } + return + } + + method choice_1129 {} { + # / + # x + # '\' + # (EOL) + # x + # ! + # (EOL) + # + + my si:void_state_push + my sequence_1122 + my si:voidvoid_branch + my sequence_1127 + my si:void_state_merge + return + } + + method sequence_1122 {} { + # x + # '\' + # (EOL) + + my si:void_state_push + my si:next_char \134 + my si:voidvoid_part + my sym_EOL + my si:void_state_merge + return + } + + method sequence_1127 {} { + # x + # ! + # (EOL) + # + + my si:void_state_push + my notahead_280 + my si:voidvoid_part + my si:next_space + my si:void_state_merge + return + } + + # + # void Symbol 'WSNL' + # + + method sym_WSNL {} { + # * + # + + my si:void_void_symbol_start WSNL + my kleene_1135 + my si:void_clear_symbol_end WSNL + return + } + + method kleene_1135 {} { + # * + # + + while {1} { + my si:void2_state_push + my si:next_space + my si:kleene_close + } + return + } + + # + # void Symbol 'WSob' + # + + method sym_WSob {} { + # + + # / + # x + # '\' + # (EOL) + # x + # ! + # (EOL) + # + + my si:void_void_symbol_start WSob + my poskleene_1146 + my si:void_clear_symbol_end WSob + return + } + + method poskleene_1146 {} { + # + + # / + # x + # '\' + # (EOL) + # x + # ! + # (EOL) + # + + my i_loc_push + my choice_1129 + my si:kleene_abort + while {1} { + my si:void2_state_push + my choice_1129 + my si:kleene_close + } + return + } + + ## END of GENERATED CODE. DO NOT EDIT. + # # ## ### ###### ######## ############# +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide xtal 2.0a1 +return \ No newline at end of file diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/pkgIndex.tcl b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/pkgIndex.tcl new file mode 100644 index 00000000..fd8e61aa --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/pkgIndex.tcl @@ -0,0 +1,36 @@ +# +# Tcl package index file - generated from pkgIndex.tcl.in +# + +package ifneeded xtal 2.0a1 \ + [list apply [list {dir} { + package require platform + set package_ns ::xtal + set initName [string totitle xtal] + if {[package vsatisfies [package require Tcl] 9]} { + set fileName "tcl9xtal20a1.dll" + } else { + set fileName "xtal20a1t.dll" + } + set platformId [platform::identify] + set searchPaths [list [file join $dir $platformId] \ + {*}[lmap platformId [platform::patterns $platformId] { + file join $dir $platformId + }] \ + $dir] + foreach path $searchPaths { + set lib [file join $path $fileName] + if {[file exists $lib]} { + uplevel #0 [list load $lib $initName] + # Load was successful + set ${package_ns}::dll_path $lib + set ${package_ns}::package_dir $dir + foreach f {xtal ptast ptutil shell} { + uplevel #0 [list source [file join $dir $f.tcl]] + } + package provide xtal 2.0a1 + return + } + } + error "Could not locate $fileName in directories [join $searchPaths {, }]" + }] $dir] diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ptast.tcl b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ptast.tcl new file mode 100644 index 00000000..6c5d2e29 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ptast.tcl @@ -0,0 +1,254 @@ +# +# Copyright (c) 2015, Ashok P. Nadkarni +# All rights reserved. +# +# See the file license.terms for license +# + +# We do not want the end application to have the entire pt tools package +# available since at runtime we only need it to display errors. So +# we try to load it and if not available we will land up using the +# copied version below. + +namespace eval xtal::pt::ast {} + +if {! [catch { + package require pt::ast +}]} { + interp alias {} ::xtal::pt::ast::bottomup {} ::pt::ast::bottomup + return +} + +# -*- tcl -*- +# Copyright (c) 2009 Andreas Kupries + +# Verification of serialized parsing expressions, conversion +# between such and other data structures, and their construction. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 9 ; # Required runtime. + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval xtal::pt::ast { + namespace export \ + verify verify-as-canonical canonicalize \ + equal bottomup topdown \ + print new new0 + + namespace ensemble create +} + +# # ## ### ##### ######## ############# +## Public API + +# Check that the proposed serialization of an abstract syntax tree is +# indeed such. + +proc xtal::pt::ast::verify {serial {canonvar {}}} { + variable ourprefix + #puts "V <$serial> /[llength [info level 0]] / [info level 0]" + + if {$canonvar ne {}} { + upvar 1 $canonvar iscanonical + set iscanonical [string equal $serial [list {*}$serial]] + } + + topdown [list [namespace current]::Verify] $serial + return +} + +proc xtal::pt::ast::verify-as-canonical {serial} { + verify $serial iscanonical + if {!$iscanonical} { + variable ourprefix + variable ourimpure + return -code error $ourprefix$ourimpure + } + return +} + +proc xtal::pt::ast::Verify {ast} { + variable ourprefix + variable ourbadrange + variable ourbadend + variable ourbadstart + variable ourshort + + if {[llength $ast] < 3} { + return -code error $ourprefix$ourshort + } + + # Open Questions + # - Should we constrain the locations of the children to be + # inside of the parent ? + # - Should we constrain the locations of the children to not + # overlap ? + # Note: Gaps we have to allow, comments and whitespace and such. + + lassign $ast type start end + + ##nagelfar ignore + if {![string is integer -strict $start]} { + return -code error $ourprefix[format $ourbadstart $start] + } elseif {$start < 0} { + return -code error $ourprefix[format $ourbadstart $start] + } + + ##nagelfar ignore + if {![string is integer -strict $end] || ($end < 0)} { + return -code error $ourprefix[format $ourbadend $end] + } + + if {$end < $start} { + return -code error $ourprefix$ourbadrange + } + + upvar 1 iscanonical iscanonical + if { + [info exists iscanonical] && ($ast ne [list {*}$ast]) + } { + # Reject coding with superfluous whitespace as non-canonical. + set iscanonical 0 + } + return +} + +# # ## ### ##### ######## ############# + +proc xtal::pt::ast::canonicalize {serial} { + verify $serial iscanonical + if {$iscanonical} { return $serial } + return [bottomup [list [namespace current]::Canonicalize] $serial] +} + +proc xtal::pt::ast::Canonicalize {ast} { + # We construct a pure list out of the node data. + return [list {*}$ast] +} + +# # ## ### ##### ######## ############# + +# Converts a parsing expression serialization into a human readable +# string for test results. It assumes that the serialization is at +# least structurally sound. + +proc xtal::pt::ast::print {serial} { + return [join [bottomup [list [namespace current]::Print] $serial] \n] +} + +proc xtal::pt::ast::Print {ast} { + set children [lassign $ast type start end] + set result [list [list <$type> :: $start $end]] + + # The arguments are already processed for printing + foreach c $children { + foreach line $c { + lappend result " $line" + } + } + return $result +} + +# # ## ### ##### ######## ############# + +proc xtal::pt::ast::equal {seriala serialb} { + return [string equal \ + [canonicalize $seriala] \ + [canonicalize $serialb]] +} + +# # ## ### ##### ######## ############# + +proc xtal::pt::ast::bottomup {cmdprefix ast} { + Bottomup 2 $cmdprefix $ast +} + +proc xtal::pt::ast::Bottomup {level cmdprefix ast} { + set children [lassign $ast type start end] + set new [list $type $start $end] + + set clevel $level + incr clevel + + foreach c $children { + lappend new [Bottomup $clevel $cmdprefix $c] + } + + return [uplevel $level [list {*}$cmdprefix $new]] +} + +proc xtal::pt::ast::topdown {cmdprefix ast} { + Topdown 2 $cmdprefix $ast + return +} + +proc xtal::pt::ast::Topdown {level cmdprefix ast} { + uplevel $level [list {*}$cmdprefix $ast] + + incr level + foreach c [lrange $ast 3 end] { + Topdown $level $cmdprefix $c + } + return +} + +# # ## ### ##### ######## ############# + +proc xtal::pt::ast::new {sym start end args} { + variable ourbadstart + variable ourbadend + variable ourbadrange + + if {![string is integer -strict $start] || ($start < 0)} { + return -code error [format $ourbadstart $start] + } + ##nagelfar ignore + if {![string is integer -strict $end] || ($end < 0)} { + return -code error [format $ourbadend $end] + } + if {$end < $start} { + return -code error $ourbadrange + } + + return [list $sym $start $end {*}$args] +} + +proc xtal::pt::ast::new0 {sym start args} { + variable ourbadstart + + ##nagelfar ignore + if {![string is integer -strict $start] || ($start < 0)} { + return -code error [format $ourbadstart $start] + } + + # The end of the range is placed one position before the start, + # making it zero-length (length = end-start+1), i.e. empty. Such + # nodes are possible for symbols whose RHS uses * or ? as their + # top-level operator. + + set end $start + incr end -1 + + return [list $sym $start $end {*}$args] +} + +namespace eval xtal::pt::ast { + # # ## ### ##### ######## ############# + ## Strings for error messages. + + variable ourprefix "error in serialization:" + variable ourbadstart " expected integer >= 0 as start of range, got \"%s\"" + variable ourbadend " expected integer >= 0 as end of range, got \"%s\"" + variable ourbadrange " expected start <= end for range" + variable ourshort " expected at least 3 elements for node" + variable ourimpure " has irrelevant whitespace" + + ## + # # ## ### ##### ######## ############# +} + + diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ptutil.tcl b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ptutil.tcl new file mode 100644 index 00000000..857038cc --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/ptutil.tcl @@ -0,0 +1,248 @@ +# +# Copyright (c) 2015, Ashok P. Nadkarni +# All rights reserved. +# +# See the file license.terms for license +# + +# We do not want the end application to have the entire pt tools package +# available since at runtime we only need it to display errors. So +# we try to load it and if not available we will land up using the copied +# version below. + +namespace eval xtal {} + +if {![catch { + package require pt::util +}]} { + # pt::util is available. However... + # tcllib-1.17 (or the corresponding pt package) has a bug in Readables + # with the use of the undefined variable details. Replace that routine + # in case present. TBD - once fixed in pt releases, revisit this + catch { + # Make sure pt::util::Readables is loaded (in case of lazy loading) + catch {pt::util::Readables} + if {[regexp {details} [info body pt::util::Readables]]} { + proc ::pt::util::Readables {msgs} { + set cl {} + set r {} + foreach pe $msgs { + switch -exact -- [lindex $pe 0] { + t { + # Fuse to multiple 't'-tags into a single 'cl'-tag. + lappend cl [lindex $pe 1] + } + cl { + # Fuse multiple 'cl'-tags into one. + foreach c [split [lindex $pe 1]] { lappend cl $c } + } + default { + lappend r [Readable $pe] + } + } + } + if {[set n [llength $cl]]} { + if {$n > 1} { + lappend r [Readable [list cl [join [lsort -dict $cl] {}]]] + } else { + lappend r [Readable [list t [lindex $cl 0]]] + } + } + return [lsort -dict $r] + } + } + } + interp alias {} xtal::error2readable {} ::pt::util::error2readable + return +} + +# Rest of this file is a slightly modified (namespace changes and minor edits) +# form of pt_util.tcl from the pt package. Also the use of the char package +# is replaced by the dumpstr routine from the wiki +# +# -*- tcl -*- +# Copyright (c) 2014 Andreas Kupries + +# Utility commands for parser syntax errors. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 9 ; # Required runtime. + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval ::xtal::pt::util { + namespace export error2readable error2position error2text + namespace ensemble create +} + +proc xtal::pt::util::dumpstr { s } { + set print "" + foreach c [split $s ""] { + if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} { + append print $c + } elseif {$c < "\u0100"} { + append print \\x[format %02X [scan $c %c]] + } elseif {$c > "\uFFFF"} { + append print \\U[format %08X [scan $c %c]] + } else { + append print \\u[format %04X [scan $c %c]] + } + } + return $print +} + +# This follows the char::quote api from the char package. If args is empty +# then str is returned in printable form. Else a list is returned of +# str+args in printable form. +# The parameter $type is not currently used. It's there for compatibility +# with char::quote +proc xtal::pt::util::printable {type str args} { + if {[llength $args] == 0} { + return [dumpstr $str] + } + set printables [list [dumpstr $str]] + foreach str $args { + lappend printables [dumpstr $str] + } + return $printables +} + +# # ## ### ##### ######## ############# +## Public API + +proc xtal::pt::util::error2readable {error text} { + lassign $error _ location msgs + lassign [Position $location $text] l c + + lappend map \n \\n + lappend map \r \\r + lappend map \t \\t + + # Get 10 chars before and after the failure point. Depending on + # the relative position of input beginning and end we may get less + # back of either. Special characters in the input (line endings, + # tabs) are quoted to keep this on a single line. + set prefix [string map $map [string range $text ${location}-10 $location]] + set suffix [string map $map [string range $text ${location}+1 ${location}+10]] + + # Construct a line pointing to the failure position. By using the + # transformed prefix as our source (length) no complex + # calculations are required. It is implicit in the prefix/suffix + # separation above. + set n [string length $prefix] + incr n -1 + set point [string repeat - $n] + append point ^ + + # Print our results. + lappend lines "Parse error at position $location (Line $l, column $c)." + lappend lines "... ${prefix}${suffix} ..." + lappend lines " $point" + lappend lines "Expected one of" + lappend lines "* [join [Readables $msgs] "\n* "]" + lappend lines "" + + return [join $lines \n] +} + +proc xtal::pt::util::error2position {error text} { + lassign $error _ location msgs + return [Position $location $text] +} + +proc xtal::pt::util::error2text {error} { + lassign $error _ location msgs + return [Readables $msgs] +} + +# # ## ### ##### ######## ############# +## Internals + +proc xtal::pt::util::Position {location text} { + incr location -1 + + # Computing the line/col of a position is quite easy. Split the + # part before the location into lines (at eol), count them, and + # look at the length of the last line in that. + + set prefix [string range $text 0 $location] + set lines [split $prefix \n] + set line [llength $lines] + set col [string length [lindex $lines end]] + + return [list $line $col] +} + +proc xtal::pt::util::Readables {msgs} { + set cl {} + set r {} + foreach pe $msgs { + switch -exact -- [lindex $pe 0] { + t { + # Fuse to multiple 't'-tags into a single 'cl'-tag. + lappend cl [lindex $pe 1] + } + cl { + # Fuse multiple 'cl'-tags into one. + foreach c [split [lindex $pe 1]] { lappend cl $c } + } + default { + lappend r [Readable $pe] + } + } + } + if {[set n [llength $cl]]} { + if {$n > 1} { + lappend r [Readable [list cl [join [lsort -dict $cl] {}]]] + } else { + lappend r [Readable [list t [lindex $cl 0]]] + } + } + return [lsort -dict $r] +} + +proc xtal::pt::util::Readable {pe} { + set details [lassign $pe tag] + switch -exact -- $tag { + t { + set details [printable string {*}$details] + set m "The character '$details'" + } + n { set m "The symbol $details" } + .. { + set details [printable string {*}$details] + set m "A character in range '[join $details '-']'" + } + str { + set details [join [printable string {*}[split $details {}]] {}] + set m "A string \"$details\"" + } + cl { + set details [join [printable string {*}[split $details {}]] {}] + set m "A character in set \{$details\}" + } + alpha { set m "A unicode alphabetical character" } + alnum { set m "A unicode alphanumerical character" } + ascii { set m "An ascii character" } + digit { set m "A unicode digit character" } + graph { set m "A unicode printing character, but not space" } + lower { set m "A unicode lower-case alphabetical character" } + print { set m "A unicode printing character, including space" } + control { set m "A unicode control character" } + punct { set m "A unicode punctuation character" } + space { set m "A unicode space character" } + upper { set m "A unicode upper-case alphabetical character" } + wordchar { set m "A unicode word character (alphanumerics + connectors)" } + xdigit { set m "A hexadecimal digit" } + ddigit { set m "A decimal digit" } + dot { set m "Any character" } + default { set m [string totitle $tag] } + } + return $m +} + +interp alias {} xtal::error2readable {} xtal::pt::util::error2readable +return diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/shell.tcl b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/shell.tcl new file mode 100644 index 00000000..7c41aa53 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/shell.tcl @@ -0,0 +1,389 @@ + +# +# Copyright (c) 2015, Ashok P. Nadkarni +# All rights reserved. +# +# See the file LICENSE for license +# + +# This file implements support for Xtal syntax in the Wish console and tkcon. +# Currently this is implemented by monkey patching the command dispatch +# code for those packages at runtime. Since the Wish console and tkcon +# dispatch code has been stable for many many years, assumption is it is +# unlikely to change significantly in the future. +# +# Down the road, alternative implementations, for example using +# tkcon getcommand and friends, may be explored. + +namespace eval xtal::shell { + variable options + array set options { + -lang auto + -prettify 1 + } + + # Indicates if the xtal shell is running and what env if so + variable host ""; # or "wish", "tclsh" or "tkcon" + + # The following is an adaptation of the command dispatch code + # from the wish console. We will use this to replace the wish + # console dispatch at runtime. + variable wish_monkeypatch { + # ::tk::ConsoleInvoke -- + # Processes the command line input. If the command is complete it + # is evaled in the main interpreter. Otherwise, the continuation + # prompt is added and more input may be added. + # + # Arguments: + # None. + proc ::tk::ConsoleInvoke {args} { + set ranges [.console tag ranges input] + set cmd "" + if {[llength $ranges]} { + set pos 0 + while {[lindex $ranges $pos] ne ""} { + set start [lindex $ranges $pos] + set end [lindex $ranges [incr pos]] + append cmd [.console get $start $end] + incr pos + } + } + if {$cmd eq ""} { + ConsolePrompt + } elseif {[info complete $cmd]} { + if {[catch { + set is_xtal [consoleinterp eval [list ::xtal::shell::XtalCmd? $cmd]] + }] == 0 && $is_xtal} { + set cmd "::xtal::xtal {[string trimright $cmd \n]}\n" + } + .console mark set output end + .console tag delete input + set result [consoleinterp eval [list ::xtal::shell::Prettify_graphic 0 [consoleinterp record $cmd]]] + if {$result ne ""} { + puts $result + } + ConsoleHistory reset + ConsolePrompt + } else { + ConsolePrompt partial + } + .console yview -pickplace insert + } + } + + # The following is an adaptation of the command dispatch code from + # tkcon. We will use this to replace the tkcon dispatch at runtime + variable tkcon_monkeypatch { + proc ::tkcon::EvalCmd {w cmd} { + variable OPT + variable PRIV + + $w mark set output end + if {$cmd ne ""} { + set code 0 + if {$OPT(subhistory)} { + set ev [EvalSlave history nextid] + incr ev -1 + ## FIX: calcmode doesn't work with requesting history events + if {$cmd eq "!!"} { + set code [catch {EvalSlave history event $ev} cmd] + if {!$code} {$w insert output $cmd\n stdin} + } elseif {[regexp {^!(.+)$} $cmd dummy event]} { + ## Check last event because history event is broken + set code [catch {EvalSlave history event $ev} cmd] + if {!$code && ![string match ${event}* $cmd]} { + set code [catch {EvalSlave history event $event} cmd] + } + if {!$code} {$w insert output $cmd\n stdin} + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { + set code [catch {EvalSlave history event $ev} cmd] + if {!$code} { + regsub -all -- $old $cmd $new cmd + $w insert output $cmd\n stdin + } + } elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} { + AddSlaveHistory $cmd + set cmd $err + set code -1 + } + } + if {$code} { + $w insert output $cmd\n stderr + } else { + # Check if an XTAL command + if {[catch { + set is_xtal [EvalAttached [list ::xtal::shell::XtalCmd? $cmd]] + }] == 0 && $is_xtal} { + set cmd "::xtal::xtal {[string trimright $cmd \n]}\n" + } + + ## We are about to evaluate the command, so move the limit + ## mark to ensure that further s don't cause double + ## evaluation of this command - for cases like the command + ## has a vwait or something in it + $w mark set limit end + if {$OPT(nontcl) && ($PRIV(apptype) eq "interp")} { + set code [catch {EvalSend $cmd} res] + if {$code == 1} { + set PRIV(errorInfo) "Non-Tcl errorInfo not available" + } + } elseif {$PRIV(apptype) eq "socket"} { + set code [catch {EvalSocket $cmd} res] + if {$code == 1} { + set PRIV(errorInfo) "Socket-based errorInfo not available" + } + } else { + set code [catch {EvalAttached $cmd} res] + if {$code == 1} { + if {[catch {EvalAttached [list set errorInfo]} err]} { + set PRIV(errorInfo) "Error getting errorInfo:\n$err" + } else { + set PRIV(errorInfo) $err + } + } + } + if {![winfo exists $w]} { + # early abort - must be a deleted tab + return + } + AddSlaveHistory $cmd + # Run any user defined result filter command. The command is + # passed result code and data. + if {[llength $OPT(resultfilter)]} { + set cmd [linsert $OPT(resultfilter) end $code $res] + if {[catch {EvalAttached $cmd} res2]} { + $w insert output "Filter failed: $res2" stderr \n stdout + } else { + set res $res2 + } + } + catch {EvalAttached [list set _ $res]} + set maxlen $OPT(maxlinelen) + set trailer "" + if {($maxlen > 0) && ([string length $res] > $maxlen)} { + # If we exceed maximum desired output line length, truncate + # the result and add "...+${num}b" in error coloring + set trailer ...+[expr {[string length $res]-$maxlen}]b + set res [string range $res 0 $maxlen] + } + if {$code} { + if {$OPT(hoterrors)} { + set tag [UniqueTag $w] + $w insert output $res [list stderr $tag] \n$trailer stderr + $w tag bind $tag \ + [list $w tag configure $tag -under 1] + $w tag bind $tag \ + [list $w tag configure $tag -under 0] + $w tag bind $tag \ + "if {!\[info exists tk::Priv(mouseMoved)\] || !\$tk::Priv(mouseMoved)} \ + {[list $OPT(edit) -attach [Attach] -type error -- $PRIV(errorInfo)]}" + } else { + $w insert output $res\n$trailer stderr + } + } elseif {$res ne ""} { + $w insert output $res stdout $trailer stderr \n stdout + } + } + } + Prompt + set PRIV(event) [EvalSlave history nextid] + } + } +} + +# Interactive command loop in tclsh - adapted from http://wiki.tcl.tk/1968 +namespace eval xtal::shell::tclsh { + proc banghist {val} { + variable verbose_history + if {![string compare $val "!"]} {set val ""} + if {$verbose_history} {puts "[::history event $val]"} + ::history redo $val + } + + proc read_stdin {} { + global tcl_prompt1 + variable eventLoop + variable long_command + set l [gets stdin] + if {[eof stdin]} { + set eventLoop "done" ;# terminate the vwait eventloop + } else { + if {[string compare $l {}]} { + append long_command "\n$l" + set l $long_command + if {[info complete $l]} { + if {[catch { + set is_xtal [::xtal::shell::XtalCmd? $l] + }] == 0 && $is_xtal} { + set l "::xtal::xtal {[string trimright $l \n]}\n" + } + if {[catch {uplevel \#0 history add [list $l] exec} err]} { + puts stderr $err + } elseif {[string compare $err {}]} { + puts [xtal::shell::Prettify_ascii 0 $err] + } + set long_command "" + catch $tcl_prompt1 + } else { + puts -nonewline "> " + } + } elseif {![string compare $long_command {}]} { + catch $tcl_prompt1 + } else { + puts -nonewline "> " + } + flush stdout + } + } + + proc repl {} { + variable long_command "" + variable verbose_history 0 + if {![catch {rename ::unknown ::_xtal_tcl_unknown}]} { + proc ::unknown {cmdname args} { + if {[regexp "^!..*" $cmdname]} { + ::xtal::shell::tclsh::banghist [string range $cmdname 1 end] + } else { + ::_xtal_tcl_unknown $cmdname $args + } + } + } + + if {![info exists ::tcl_prompt1]} { + set ::tcl_prompt1 {puts -nonewline "xtal ([history nextid]) % "} + set prompt_replaced 1 + } else { + set prompt_replaced 0 + } + + # set up our keyboard read event handler + # Vector stdin data to the socket + fileevent stdin readable [namespace current]::read_stdin + + catch $::tcl_prompt1 + flush stdout + # wait for and handle or stdin events... + vwait [namespace current]::eventLoop + if {[info procs ::_xtal_tcl_unknown] ne ""} { + rename ::unknown "" + rename ::_xtal_tcl_unknown ::unknown + } + if {$prompt_replaced} { + unset -nocomplain ::tcl_prompt1 + } + } +} + +# Prettify output. The interface params correspond to those for the +# tkcon resultfilter command +proc xtal::shell::Prettify_graphic {errorcode result} { + variable options + if {$options(-prettify)} { + return [tarray::prettify $result -style graphics] + } else { + return $result + } +} +proc xtal::shell::Prettify_ascii {errorcode result} { + variable options + if {$options(-prettify)} { + return [tarray::prettify $result] + } else { + return $result + } +} + +# Heuristic to check if passed command string might be Xtal +proc xtal::shell::XtalCmd? {cmd} { + variable options + + # cmd is expected to be a properly formed list + # where [info complete $cmd] will return true. There are special + # cases though where info complete returns 1 but the string + # is not a well formed list (unmatched braces) + + if {$options(-lang) eq "tcl"} { + return 0 + } elseif {$options(-lang) eq "xtal"} { + return 1 + } + + # Commands beginning with xtal are assumed to be invocations of + # Xtal from Tcl (so in effect not an xtal script) + if {[regexp {^\s*(::)?(xtal::)?xtal\s} $cmd]} { + return 0 + } + + # Commands wrapped in <> are Tcl scripts wrapped in Xtal <> + if {[regexp {^\s*<.*>\s*$} $cmd]} { + return 1 + } + + # Try translating it. + if {[catch {::xtal::translate $cmd}]} { + # Translation failed. Could be because it is actually Tcl + # or could be Xtal but containing syntax errors. + if {[lsearch -exact $cmd "="] >= 1 } { + # Assume Xtal assignment + return 1 + } + return 0 + } + + # Syntactically xtal. Could be single word Tcl commands like + # "exit" which would be treated as xtal variables. Guard against + # that by checking that the variable exists, otherwise a Tcl command. + # We also have to ensure we don't confuse x+1 and f() as Tcl + # commands. + if {[llength $cmd] == 1 && + ![regexp {[^[:alnum:]:_]+} [lindex $cmd 0]]} { + return [uplevel #0 [list info exists [lindex $cmd 0]]] + } + + return 1 +} + +proc xtal::shell::shell {args} { + variable host + variable options + + # Change shell options + dict for {opt val} $args { + switch -exact -- $opt { + -prettify { + if {![string is boolean -strict $val]} { + error "Invalid boolean value \"$val\"" + } + } + -lang { + if {$val ni {tcl xtal auto}} { + error "Invalid value \"$val\". Must be one of \"tcl\", \"xtal\" or \"auto\"." + } + } + default { + error "Unknown option \"$opt\"" + } + } + set options($opt) $val + } + + if {$host ne ""} { + return; # Already running + } + if {[info commands ::tkcon] eq "::tkcon"} { + ::tkcon eval eval $::xtal::shell::tkcon_monkeypatch + ::tkcon resultfilter ::xtal::shell::Prettify_graphic + set host tkcon + } elseif {[info commands ::console] eq "::console"} { + ::console eval $::xtal::shell::wish_monkeypatch + set host wish + } elseif {$::tcl_interactive} { + xtal::shell::tclsh::repl + set host tclsh + } else { + error "Unsupported console environment." + } + return +} + +interp alias {} xtal::shell {} xtal::shell::shell diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/win32-x86_64/tcl9xtal20a1.dll b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/win32-x86_64/tcl9xtal20a1.dll new file mode 100644 index 00000000..8dbe9aab Binary files /dev/null and b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/win32-x86_64/tcl9xtal20a1.dll differ diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/xtal.tcl b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/xtal.tcl new file mode 100644 index 00000000..e0bdbf21 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/xtal.tcl @@ -0,0 +1,2796 @@ +# +# Copyright (c) 2015-2017, Ashok P. Nadkarni +# All rights reserved. +# +# See the file license.terms for license +# + +namespace eval xtal { + variable scriptDir [file normalize [file dirname [info script]]] + + # In production code we use the critcl C-based parser. For development + # build the parser on the fly using the oo based parser. To do this, + # set the _use_oo_parser to 1 in the shell, package require tarray + # and then source this file. + variable _use_oo_parser + if {![info exists _use_oo_parser]} { + set _use_oo_parser 0 + } + + namespace export xtal +} + +package require tarray +if {$xtal::_use_oo_parser} { + source [file join $::xtal::scriptDir ooparser.tcl] +} else { + # Production - we are already embedded into the critcl based parser + # so nothing to do +} + +namespace eval xtal::ast { + proc Print {s ast} { + proc [namespace current]::Print {s ast} { + set children [lassign $ast type start end] + set result [list [list <$type> :: $start $end [string range $s $start $end]]] + + # The arguments are already processed for printing + foreach c $children { + foreach line $c { + lappend result " $line" + } + } + return $result + } + return [Print $s $ast] + } + + proc print {s ast} { + puts [join [xtal::pt::ast::bottomup [list [namespace current]::Print $s] $ast] \n] + } +} + +proc xtal::_map_search_op {op} { + # Maps relational operators to column search switches + # Note the order of options in each entry is important as they + # are checked for in other places. + set map { + == {-eq} + != {-not -eq} + < {-lt} + <= {-not -gt} + > {-gt} + >= {-not -lt} + =^ {-nocase -eq} + !^ {-nocase -not -eq} + ~ {-re} + !~ {-not -re} + ~^ {-nocase -re} + !~^ {-nocase -not -re} + } + + if {[dict exists $map $op]} { + return [dict get $map $op] + } else { + return "" + } +} + +proc xtal::_map_search_op_reverse {op} { + # Like _map_search_op except that instead of COLUMN OP OPERAND + # this maps OPERAND OP COLUMN + # Note regexp and glob operators are missing here since + # for consistency, the pattern must only appear on the RHS side + # of the operator. + # Note the order of options in each entry is important as they + # are checked for in other places. + set map { + == {-eq} + != {-not -eq} + < {-gt} + <= {-not -lt} + > {-lt} + >= {-not -gt} + =^ {-nocase -eq} + !^ {-nocase -not -eq} + } + if {[dict exists $map $op]} { + return [dict get $map $op] + } else { + return "" + } +} + +proc xtal::_math_op_reverse {op} { + # Converts OPERANDA OP OPERANDB to OPERANDB REVERSE_OP OPERANDA + # Note regexp and glob operators are missing here since + # for consistency, the pattern must only appear on the RHS side + # of the operator. + set map { + == == + != != + < > + <= >= + > < + >= <= + =^ =^ + !^ !^ + } + + if {[dict exists $map $op]} { + return [dict get $map $op] + } else { + return "" + } +} + +proc xtal::_init_compiler {} { + xtal::Compiler create compiler $::xtal::_use_oo_parser + ::proc _init_compiler {args} {} + return +} + +proc xtal::translate {script} { + _init_compiler + ::proc translate {script} { + return [compiler translate $script] + } + tailcall translate $script +} + +proc xtal::xtal {script} { + # TBD - should we replace with + # tailcall try $script + uplevel 1 [translate $script] +} + +proc xtal::function {name arguments body} { + _init_compiler + ::proc [namespace current]::proc {name arguments body} { + uplevel 1 [list ::proc $name $arguments [compiler translate $body]] + } + tailcall [namespace current]::proc $name $arguments $body +} + +proc xtal::method {class name arguments body} { + _init_compiler + ::proc [namespace current]::method {class name arguments body} { + uplevel 1 [list ::oo::define $class method $name $arguments [compiler translate $body]] + } + tailcall [namespace current]::method $class $name $arguments $body +} + +proc xtal::objmethod {obj name arguments body} { + _init_compiler + ::proc [namespace current]::objmethod {obj name arguments body} { + uplevel 1 [list ::oo::objdefine $obj method $name $arguments [compiler translate $body]] + } + tailcall [namespace current]::objmethod $obj $name $arguments $body +} + +proc xtal::translate_file {args} { + set nargs [llength $args] + if {$nargs != 1 && $nargs != 3} { + error "invalid syntax: should be \"translate_file ?-encoding ENCODING? PATH\"" + } + set path [lindex $args end] + if {$nargs == 3} { + if {[lindex $args 0] ne "-encoding"} { + error "invalid syntax: should be \"translate_file ?-encoding ENCODING? PATH\"" + } + set encoding [lindex $args 1] + } + set fd [open $path r] + try { + if {[info exists encoding]} { + fconfigure $fd -encoding $encoding -translation auto + } else { + fconfigure $fd -translation auto + } + set script [read $fd] + return [translate $script] + } finally { + close $fd + } +} + +proc xtal::source {args} { + return [uplevel 1 [translate_file {*}$args]] +} + +proc xtal::compile {args} { + set nargs [llength $args] + if {$nargs != 2 && $nargs != 4} { + error "invalid syntax: should be \"tcompile ?-encoding ENCODING? XTALFILE TCLFILE\"" + } + set from [lindex $args end-1] + set to [lindex $args end] + set args [lrange $args 0 end-2] + set script [translate_file {*}$args $from] + set fd [open $to w] + try { + if {[dict exists $args -encoding]} { + fconfigure $fd -translation auto -encoding [dict get $args -encoding] + } else { + fconfigure $fd -translation auto + } + puts $fd $script + } finally { + close $fd + } +} + +oo::class create xtal::Parser { + variable Script + + constructor {use_oo_parser} { + if {$use_oo_parser} { + xtal::ParserBase create baseparser + } else { + xtal::ParserBase_critcl baseparser + } + } + + forward parse baseparser parse + forward parset baseparser parset + + method ast {text} { + xtal::ast::print $text [my parset $text] + } + + method _print {node {indent {}}} { + set children [lassign $node name] + puts "${indent}$name -> $children" + foreach child $children { + my _print $child " ${indent}" + } + } + + method print {text} { + foreach stmt [my translate $text] { + my _print $stmt + } + } + + method translate {text} { + set Script $text + if {[catch {my parset $text} ast eropts]} { + if {[string match {pt::rde *} $ast]} { + error [xtal::error2readable $ast $text] + } else { + return -options $eropts $ast + } + } + return [xtal::pt::ast::bottomup [list [namespace which my] node] $ast] + } + + method node {ast} { + return [my {*}$ast] + } + + method _child {from to ast} { + return $ast + } + + method _extract {name from to} { + return [list $name [string range $Script $from $to]] + } + + method Program {from to child} { + return $child + } + + method Block {from to args} { + return $args + } + + method Statement {from to {child {}}} { + if {[llength $child]} { + return [list Statement $child] + } else { + return {} + } + } + + method IfStatement {from to args} { + return [list IfStatement {*}$args] + } + + method ElseClause {from to clause} { + return [list ElseClause $clause] + } + + method ElseifClause {from to expr clause} { + return [list ElseifClause $expr $clause] + } + + method WhileStatement {from to args} { + return [list WhileStatement {*}$args] + } + + method ReturnStatement {from to {expr {}}} { + return [list ReturnStatement $expr] + } + + method BreakStatement {from to} { + return [list BreakStatement] + } + + method ContinueStatement {from to} { + return [list ContinueStatement] + } + + method ForRangeStatement {from to loopvar low args} { + set nargs [llength $args] + set loopvar [lindex $loopvar 1] + if {$nargs == 1} { + # No upper limit, increment defaults to 1 + return [list ForRangeStatement $loopvar $low {} {Number 1} [lindex $args 0]] + } + + if {$nargs == 2} { + if {[lindex $args 0 0] eq "ForRangeIncrement"} { + # No upper limit but increment specified + return [list ForRangeStatement $loopvar $low {} [lindex $args 0 1] [lindex $args 1]] + } else { + # Upper limit, default increment + return [list ForRangeStatement $loopvar $low [lindex $args 0] {Number 1} [lindex $args 1]] + } + } + + if {$nargs == 3 && + [lindex $args 0 0] ne "ForRangeIncrement" && + [lindex $args 1 0] eq "ForRangeIncrement"} { + # Both upper limit and increment specified + return [list ForRangeStatement $loopvar $low [lindex $args 0] [lindex $args 1 1] [lindex $args 2]] + } + + error "Internal error parsing for statement. Unexpected argument count or types" + } + + method ForRangeIncrement {from to args} { + return [list ForRangeIncrement {*}$args] + } + + method ForEachStatement {from to var args} { + if {[llength $args] == 2} { + # foreach loopvar collection body + return [list ForEachStatement [lindex $var 1] {*}$args] + } else { + # foreach keyvar loopvar collection body + return [list ForEachIndexedStatement [lindex $var 1] [lindex $args 0 1] [lindex $args 1] [lindex $args 2]] + } + } + + method TryStatement {from to block args} { + return [list TryStatement $block {*}$args] + } + + method OnHandler {from to returncode args} { + # on errorcode (, var)* body + set vars [lmap arg [lrange $args 0 end-1] { + lindex $arg 1 + }] + return [list OnHandler [lindex $returncode 1] $vars [lindex $args end]] + } + + method TrapHandler {from to trappattern args} { + # trap trappattern (, var)* body + set vars [lmap arg [lrange $args 0 end-1] { + lindex $arg 1 + }] + return [list TrapHandler $trappattern $vars [lindex $args end]] + } + + method FinallyClause {from to block} { + return [list FinallyClause $block] + } + + forward ReturnCode my _extract ReturnCode + + method ThrowStatement {from to args} { + return [list ThrowStatement {*}$args] + } + + method Assignment {from to lvalue assignop expr} { + if {[lindex $lvalue 0] eq "Identifier"} { + set ident [lindex $lvalue 1] + # Try for some optimization that can make use of the v* form of + # when target of assignment is a simple identifier + switch -exact -- [lindex $expr 0] { + SortCommand { + # We can optimize sorts of the form + # var = @sort var options + # provided options does not contain the -indices option + if {[lindex $expr 1 0] eq "Identifier" && + [lindex $expr 1 1] eq $ident && + ([llength $expr] == 2 || + ([lindex $expr 2 0] eq "SortOptions" && + "-indices" ni [lindex $expr 2 1]))} { + return [list VSort $ident [lindex $expr 2 1]] + } + } + BuiltInCall { + if {[lindex $expr 2 1 0 0] eq "Identifier" && + [lindex $expr 2 1 0 1] eq $ident} { + switch -exact -- [lindex $expr 1] { + delete - + fill - + inject - + insert - + reverse { + return [list VBuiltInCall v[lindex $expr 1] [lindex $expr 2]] + } + } + } + } + } + } + + # No optimizations detected + return [list [lindex $assignop 1] $lvalue $expr] + } + + method LValue {from to first_child args} { + if {[llength $args] == 0} { + return $first_child; + } else { + return [switch -exact -- [lindex $args 0 0] { + Element { + # args is element node followed by remaining args + # + list LValueElement [lindex $first_child 1] {*}[lrange $args 0 end] + } + TableColumns { + # args is column node, remaining args + list LValueTableColumns [lindex $first_child 1] {*}$args + } + default { + list LValueTarray [lindex $first_child 1] {*}$args + } + }] + } + } + + forward Expression my _child + + method RangeExpr {from to first_child args} { + if {[llength $args] == 0} { + # RangeExpr EXPR + return $first_child + } elseif {[llength $args] == 1} { + # RangeExpr EXPR : + return [list Range $first_child] + } else { + # RangeExpr EXPR : EXPR + return [list Range $first_child [lindex $args 1]] + } + } + + method RangeSeparator {from to} { + return [list RangeSeparator [string range $Script $from $to]] + } + + method AddExpr {from to first_child args} { + # args will be a list of alternating AddOp and operand nodes + if {[llength $args] == 0} { + # Simply promote and return the child + return $first_child + } + + # TBD - AddExpr reordering for optimization might lead + # to different overflow behaviour + # Maybe it should not do that? Probably ok for integers + # because even with overflow, result will be the same + + # We want to do constant folding and also optimize number of + # calls the runtime will make to tarray::column::math. + # const will hold the result of constant folding + # positives will hold the non-const operands whose operator is + + # negatives will hold the non-const operands whose operator is - + # Note the operand itself may be positive or negative as well! + set negatives {} + if {[lindex $first_child 0] eq "Number"} { + set const [lindex $first_child 1] + set positives {} + } else { + set const 0 + set positives [list $first_child] + } + foreach {op operand} $args { + if {[lindex $operand 0] eq "Number"} { + # Note: don't use incr because it cannot handle op=-, operand=-4 + append const [lindex $op 1] [lindex $operand 1] + } else { + if {[lindex $op 1] eq "+"} { + lappend positives $operand + } else { + lappend negatives $operand + } + } + } + # Result is const + positive - negatives. Optimize for when + # various components are missing. + set const [expr $const]; # Fold constants + if {$const == 0} { + if {[llength $positives] == 0} { + # No positives, const 0 + if {[llength $negatives] == 0} { + # No positives, no negatives const 0 + return [list Number 0] + } else { + # No positives, at least one negative, const 0 + return [list - [list Number 0] {*}$negatives] + } + } else { + # At least one positive, const 0 + if {[llength $negatives] == 0} { + # Only positives, no negatives, const = 0 + if {[llength $positives] == 1} { + # A single positive, no negatives, const 0 + return [lindex $positives 0] + } else { + # Multiple positives, no negatives, const 0 + return [list + {*}$positives] + } + } else { + # Both positives and negatives, const 0 + if {[llength $positives] == 1} { + # Single positive, at least one negative, const 0 + if {[llength $negatives] == 1} { + # Single positive, single negative, const 0 + return [list - [lindex $positives 0] [lindex $negatives 0]] + } else { + # Single positive, multiple negative, const 0 + return [list - [lindex $positives 0] [list + {*}$negatives]] + } + } else { + # Multiple positive, at least one negative, const 0 + if {[llength $negatives] == 1} { + # Multiple positive, single negative, const 0 + return [list - [list + {*}$positives] [lindex $negatives 0]] + } else { + # Multiple positive, multiple negatives, const 0 + return [list - [list + {*}$positives] [list + {*}$negatives]] + } + } + } + } + } else { + # const non-0 + set const [list Number $const] + if {[llength $positives] == 0} { + # No positives, const non-0 + if {[llength $negatives] == 0} { + # No positives, no negatives const non-0 + return $const + } else { + # No positives, at least one negative, const non-0 + return [list - $const {*}$negatives] + } + } else { + # At least one positive, const non-0 + if {[llength $negatives] == 0} { + # Only positives, no negatives, const non-0 + return [list + $const {*}$positives] + } else { + # Both positives and negatives, const non-0 + return [list - [list + $const {*}$positives] {*}$negatives] + } + } + } + error "Internal error: missed a case in AddExpr!" + } + + method _leftassoc_fold {from to first_child args} { + if {[llength $args] == 0} { + return $first_child + } + set command {} + set prev_operand $first_child + set fold 1 + foreach {op operand} $args { + set op [lindex $op 1] + if {$fold} { + if {[lindex $prev_operand 0] eq "Number" && + [lindex $operand 0] eq "Number"} { + # Fold leading constants + set prev_operand [list Number [expr [list [lindex $prev_operand 1] $op [lindex $operand 1]]]] + } else { + # Can't fold any more + set prev_operand [list $op $prev_operand $operand] + set fold 0 + } + } else { + # No folding going on now. If this operation same as last + # operation, add the new operand + if {$prev_op eq $op} { + lappend prev_operand $operand + } else { + set prev_operand [list $op $prev_operand $operand] + } + } + set prev_op $op + } + return $prev_operand + } + + forward LogicalOrExpr my _leftassoc_fold + forward LogicalAndExpr my _leftassoc_fold + forward MulExpr my _leftassoc_fold + forward BitOrExpr my _leftassoc_fold + forward BitXorExpr my _leftassoc_fold + forward BitAndExpr my _leftassoc_fold + forward RelExpr my _leftassoc_fold + + method UnaryExpr {from to postfix_expr args} { + if {[llength $args] == 0} { + return $postfix_expr + } else { + # postfix_expr is actually UnaryOp. + # $args should be a single argument again of type UnaryExpr + # or a descendant + set op [lindex $postfix_expr 1] + set postfix_expr [lindex $args 0] + + if {[lindex $postfix_expr 0] eq "Number"} { + return [list Number [::tcl::mathop::$op [lindex $postfix_expr 1]]] + } elseif {[lindex $postfix_expr 0] eq "UnaryExpr" && + $op eq [lindex $postfix_expr 1]} { + # Note: A unary + is a no-op so we could ignore it. However + # we don't discard it because it is an error if the operand + # is not numeric (which we cannot know if it is not a literal). + # Consecutive ++ can be shrunk to +. Consecutive + # "--" or "~~" can be completely discarded. "!" changes + # the value of numerics (!! is not a no-op) so we leave it + # alone. + + if {$op in {- ~}} { + return [lindex $postfix_expr 2] + } + if {$op eq "+"} { + return $postfix_expr + } + } + + # Special cases above did not apply. Need to do operation at runtime + return [list UnaryExpr $op {*}$args] + } + } + + method PostfixExpr {from to primary_expr args} { + if {[llength $args] == 0} { + return $primary_expr + } + # Optimize I[I RelOp Operand] to I[@@ RelOp Operand] + # in preparation for further optimization in second pass. + if {[lindex $primary_expr 0] eq "Identifier" && + [lindex $args 0 0] eq "Selector"} { + set selector [lindex $args 0 1] + if {[llength $selector] == 3} { + # TBD - do we need to check [lindex $selector 0] is a RelOp? + if {[lindex $selector 1 0] eq "Identifier" && + [lindex $selector 1 1] eq [lindex $primary_expr 1]} { + lset selector 1 "SelectorContext" + } + if {[lindex $selector 2 0] eq "Identifier" && + [lindex $selector 2 1] eq [lindex $primary_expr 1]} { + lset selector 2 "SelectorContext" + } + return [list PostfixExpr $primary_expr [list Selector $selector] {*}[lrange $args 1 end]] + } + } + return [list PostfixExpr $primary_expr {*}$args] + } + + forward PrimaryExpr my _child + + forward BuiltIn my _child + + forward PostfixOp my _child + + method ColumnType {from to} { + return [string range $Script $from $to] + } + + method ColumnConstructor {from to coltype args} { + if {[lindex $args 0 0] ne "ColumnConstructorSize"} { + return [list ColumnConstructor $coltype {Number 0} {*}$args] + } else { + return [list ColumnConstructor $coltype [lindex $args 0 1] {*}[lrange $args 1 end]] + } + } + + method ColumnConstructorSize {from to size} { + return [list ColumnConstructorSize $size] + } + + method ColumnConstructorInit {from to args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } else { + return [list ColumnConstructorRange {*}$args] + } + } + + method ColumnConstructorExpr {from to child} { + return $child + } + + method ColumnConstructorRandom {from to args} { + return [list ColumnConstructorRandom {*}$args] + } + + method ColumnConstructorSeries {from to args} { + return [list ColumnConstructorSeries {*}$args] + } + + method TableConstructor {from to args} { + if {[llength $args] == 1} { + # A single arg may be the column definition list or the initializer + if {[lindex $args 0 0] eq "TableColumnDefs"} { + return [list TableConstructor [lindex $args 0 1] [list Sequence]] + } else { + return [list TableConstructor [list ] [lindex $args 0]] + } + } else { + # Both column definition list and initializer are present + return [list TableConstructor [lindex $args 0 1] [lindex $args 1]] + } + } + + method TableColumnDefs {from to args} { + return [list TableColumnDefs [concat {*}$args] ] + } + + method TableColumnDef {from to colname coltype} { + return [list [lindex $colname 1] $coltype] + } + + method Selector {from to child} { + return [list Selector $child] + } + + method FunctionCall {from to args} { + return [linsert $args 0 FunctionCall] + } + + method ArgumentList {from to args} { + return [list ArgumentList {*}$args] + } + + method Argument {from to args} { + return $args + } + + method Element {from to op child} { + return [list Element $child] + } + + method TableColumns {from to op {child {}}} { + return [linsert $child 0 TableColumns] + } + + method TableColumnList {from to args} { + return $args + } + + method ColumnIdentifier {from to child} { + return $child + } + + method ElementIdentifier {from to child} { + return $child + } + + forward UnaryOp my _extract UnaryOp + forward MulOp my _extract MulOp + forward AddOp my _extract AddOp + forward RelOp my _extract RelOp + forward BitAndOp my _extract BitAndOp + forward BitOrOp my _extract BitOrOp + forward BitXorOp my _extract BitXorOp + forward LogicalAndOp my _extract LogicalAndOp + forward LogicalOrOp my _extract LogicalOrOp + forward AssignOp my _extract AssignOp + forward ColumnOp my _extract ColumnOp + forward ElementOp my _extract ElementOp + + method SelectorContext {from to} { + return SelectorContext + } + + method ParameterIdentifier {from to} { + # TBD - why not forward this + return [string range $Script $from $to] + } + + method Identifier {from to} { + # TBD - why not forward this to _extract? + return [list Identifier [string range $Script $from $to]] + } + + method IndirectIdentifier {from to} { + return [list IndirectIdentifier [string range $Script [expr {1+$from}] $to]] + } + + method IndirectLiteral {from to child} { + return [list IndirectLiteral [lindex $child 1]] + } + + method OptionString {from to} { + # TBD - why not forward this to _extract? + return [list OptionString [string range $Script $from $to]] + } + + forward Number my _extract Number + + method String {from to child} { + return $child + } + + method PlainString {from to} { + return [list PlainString [subst -novariables -nocommands [string range $Script $from+1 $to-1]]] + } + + # We have to deal with TclStrings at run time because substitutions + # need to happen then + method TclString {from to} { + # TBD - Optimize - if no special chars then return as PlainString + # so as to not do unnecessary runtime processing + return [list TclString [string range $Script $from+1 $to-1]] + } + + method Sequence {from to {child {}}} { + return [linsert $child 0 Sequence] + } + + method SequenceContent {from to args} { + return $args + } + + method TclScriptBlock {from to child} { + return $child + } + + method TclScript {from to} { + return [list TclScript [string trim [string range $Script $from $to]]] + } + + method ListCast {from to child} { + return [list ListCast $child] + } + + method DictCast {from to child} { + return [list DictCast $child] + } + + method SortCommand {from to expr args} { + return [list SortCommand $expr {*}$args] + } + + method SortOptions {from to args} { + return [list SortOptions $args] + } + + method SortOption {from to} { + return "-[string range $Script $from $to]" + } + + method SearchCommand {from to expr args} { + return [list SearchCommand $expr {*}$args] + } + + method SearchTarget {from to expr} { + return [list SearchTarget $expr] + } + + method SearchOption {from to} { + return "-[string range $Script $from $to]" + } + + method BuiltInCall {from to args} { + return [list BuiltInCall {*}$args] + } + + method BuiltInFunction {from to} { + return [string range $Script $from $to] + } + + method FunctionDefinition {from to name params body} { + return [list FunctionDefinition [lindex $name 1] $params $body] + } + + method ParameterDefinitions {from to args} { + return $args + } + + method Parameter {from to args} { + return $args + } +} + +oo::class create xtal::Compiler { + variable Script Compilations SelectorNestingLevel IndentLevel + + constructor {use_oo_parser} { + namespace path ::xtal + xtal::Parser create parser $use_oo_parser + } + + forward print parser print + + method translate {script} { + if {[info exists Compilations($script)]} { + return $Compilations($script) + } + + set ir [parser translate $script] + + # Initialize the per-compile variables + set Script $script + set SelectorNestingLevel 0 + set IndentLevel 0 + set code {} + foreach stmt $ir { + # Disregard empty nodes (blank lines) + if {[llength $stmt] != 0} { + append code [my {*}$stmt]\n + } + } + + return [set Compilations($script) $code] + } + + method eval {script} { uplevel 1 [my translate $script] } + + method Indent {} {return [string repeat " " $IndentLevel]} + + method Statement {child} { + # If not an assignment operator, for example just a function call + # or variable name, need explicit return else we land up with + # something like {[set x]} as the compiled code + if {[lindex $child 0] in {= IfStatement WhileStatement ForRangeStatement ForEachStatement ForEachIndexedStatement ReturnStatement BreakStatement ContinueStatement FunctionDefinition TryStatement ThrowStatement}} { + return "[my Indent][my {*}$child]" + } else { + return "[my Indent]return -level 0 [my {*}$child]" + } + } + + method _clause_to_code {clause} { + incr IndentLevel + set code "" + foreach stmt $clause { + if {[llength $stmt]} { + append code "[my {*}$stmt]\n" + } + } + incr IndentLevel -1 + return $code + } + + method IfStatement {cond clause args} { + set code "if {\[xtal::rt::condition [my {*}$cond]\]} {\n[my _clause_to_code $clause][my Indent]}" + + foreach arg $args { + append code " [my {*}$arg]" + } + + append code \n + return $code + + set code "if {\[xtal::rt::condition [my {*}$cond]\]} {\n$then_code" + if {[llength $args] == 0} { + return "${code}[my Indent]\}" + } + + set else_code [my _clause_to_code [lindex $args end]] + return "${code}} {\n[my Indent]$else_code[my Indent]}" + #return "if {\[xtal::rt::condition [my {*}$cond]\]} {\n$then_code} {\n[my Indent]$else_code[my Indent]}" + } + + method ElseClause {clause} { + return "else {\n[my Indent][my _clause_to_code $clause][my Indent]}" + } + + method ElseifClause {cond clause} { + return "elseif {\[xtal::rt::condition [my {*}$cond]\]} {\n[my _clause_to_code $clause][my Indent]}" + } + + method ReturnStatement {expr} { + if {[llength $expr]} { + return "return [my {*}$expr]" + } else { + return "return" + } + } + + method BreakStatement {} { + return "break" + } + + method ContinueStatement {} { + return "continue" + } + + method WhileStatement {cond clause} { + return "while {\[xtal::rt::condition [my {*}$cond]\]} {\n[my _clause_to_code $clause][my Indent]}" + } + + method TryStatement {body args} { + set code "try {\n[my _clause_to_code $body]\n[my Indent]}" + foreach arg $args { + switch -exact -- [lindex $arg 0] { + OnHandler { + append code " on [lindex $arg 1] {[lindex $arg 2]} {\n[my _clause_to_code [lindex $arg 3]][my Indent]}" + } + TrapHandler { + append code " trap [my {*}[lindex $arg 1]] {[lindex $arg 2]} {\n[my _clause_to_code [lindex $arg 3]][my Indent]}" + } + FinallyClause { + append code " finally {\n[my _clause_to_code [lindex $arg 1]][my Indent]}" + } + } + } + return $code + } + + method ThrowStatement {args} { + if {[llength $args] > 1} { + return "throw [my Sequence {*}$args] [my {*}[lindex $args end]]" + } else { + return "error [my {*}[lindex $args 0]]" + } + } + + method ForRangeStatement {loopvar low high incr clause} { + if {[llength $high]} { + return "for {set $loopvar [my {*}$low]} {\[set $loopvar\] <= [my {*}$high]} {incr $loopvar [my {*}$incr]} {\n[my _clause_to_code $clause][my Indent]}" + } else { + # Make the conditional 1 since Tcl for does not allow empty cond + return "for {set $loopvar [my {*}$low]} {1} {incr $loopvar [my {*}$incr]} {\n[my _clause_to_code $clause][my Indent]}" + } + } + + method ForEachIndexedStatement {indexvar loopvar looptarget clause} { + # TBD - might the following be faster + # foreach {k v} [column/table range -dict 0 end] { + # clause + # } + # See comments for ForEachStatement + + append stmt "if {!\[info exists {$loopvar}\]} {set {$loopvar} {};unset {$loopvar}}\n" + append stmt [my Indent] + append stmt "if {!\[info exists {$indexvar}\]} {set {$indexvar} {};unset {$indexvar}}\n" + append stmt [my Indent] + append stmt "tarray::loop {$indexvar} {$loopvar} [my {*}$looptarget] {\n" + append stmt "[my _clause_to_code $clause][my Indent]}" + return $stmt + } + + method ForEachStatement {loopvar looptarget clause} { + # Creating the loop variable first, even if unset immediately + # marks it as a local in the current scope, considerably speeds + # up execution of the script - via miguel sofer on the chat + append stmt "if {!\[info exists {$loopvar}\]} {set {$loopvar} {};unset {$loopvar}}\n" + append stmt [my Indent] + append stmt "tarray::loop {$loopvar} [my {*}$looptarget] {\n" + append stmt "[my _clause_to_code $clause][my Indent]}" + return $stmt + } + + method = {lvalue rvalue} { + lassign $lvalue type ident indexexpr + switch -exact -- $type { + Identifier { + return "set $ident [my {*}$rvalue]" + } + LValueTarray { + # We are assigning to elements in a tarray. The elements + # to be assigned may be specified through a range or + # a general expression that results in an index or index list. + lassign $lvalue type ident indexexpr + switch -exact -- [lindex $indexexpr 0] { + Range { + return "xtal::rt::tarray_assign_range $ident [my {*}$rvalue] {*}[my {*}$indexexpr]" + } + Number { + # Single numeric index + return "xtal::rt::tarray_assign_element $ident [my {*}$rvalue] [my {*}$indexexpr]" + } + default { + # Index is general expression (including single vars) + # The actual operation depends on both the + # lvalue and the rvalue + set frag "xtal::rt::tarray_assign $ident [my {*}$rvalue] [my {*}$indexexpr]" + # TBD - optimize by only pushing context if selector has @@ + return [string map [list %IDENT% "\[set $ident\]" %FRAG% $frag] { + xtal::rt::push_selector_context %IDENT% + try { + return -level 0 [%FRAG%] + } finally { + xtal::rt::pop_selector_context + } + }] + } + } + } + LValueElement { + # Assigning to a single element within a dict/column/table + lassign $lvalue elemtype operand element indexexpr + set element [my Element $element] + + # Note - only tables and columns can have indices + # TBD - if $indexexpr is not "", it has to be a table? + # Because C.elem[index] does not make sense if C is a column + switch -exact -- [lindex $indexexpr 0] { + "" { + # T.c = .... + # No index + return "xtal::rt::assign_element $operand $element [my {*}$rvalue]" + } + Range { + # T.c[4:j] = ... + return "xtal::rt::table_column_assign_range $operand $element [my {*}$rvalue] {*}[my {*}$indexexpr]" + } + Number { + # Single numeric literal index + # T.c[0] = ... + return "xtal::rt::table_column_assign $operand $element [my {*}$rvalue] [my {*}$indexexpr]" + #return "tarray::table::vfill -columns \[list $element\] $operand [my {*}$rvalue] [my {*}$indexexpr]" + } + default { + # Index is general expression (including single vars) + # The actual operation depends on both the + # lvalue and the rvalue + set stmt "xtal::rt::table_column_assign $operand $element [my {*}$rvalue] [my {*}$indexexpr]" + return "xtal::rt::push_selector_context \[xtal::rt::element \[set $operand\] $element\]\ntry { $stmt\n} finally {\nxtal::rt::pop_selector_context\n}\n" + } + } + } + + LValueTableColumns { + lassign $lvalue type table columns indexexpr + # columns is {TableColumns colnode1....} + set collist [lmap column [lrange $columns 1 end] { + my Element $column + }] + + set collist [join $collist { }] + switch -exact -- [lindex $indexexpr 0] { + "" { + # T.(a,b) = ... + # No index -> whole columns to be operated + return "xtal::rt::table_columns_replace $table \[list $collist\] [my {*}$rvalue]" + } + Range { + return "xtal::rt::table_columns_assign_range $table \[list $collist\] [my {*}$rvalue] {*}[my {*}$indexexpr]" + } + Number { + # Single numeric index + # T.(a,b)[0] = ... + return "tarray::table::vfill -columns \[list $collist\] $table [my {*}$rvalue] [my {*}$indexexpr]" + } + default { + # Index is general expression (including single vars) + # The actual operation depends on both the + # lvalue and the rvalue + return "xtal::rt::table_columns_assign $table \[list $collist\] [my {*}$rvalue] [my {*}$indexexpr]" + } + } + } + + default { + error "Internal error: Unexpected node type [lindex $lvalue 0]" + } + } + } + + # TBD - optimizations + # _mathop, _relop, _strop result in switching on $op at runtime. Change to + # switch on $op during compile time (may be use _map_search_op etc.) + + method _mathop {op args} { + return "\[tarray::column::math $op [join [lmap arg $args { my {*}$arg }] { }]\]" + } + + forward + my _mathop + + forward - my _mathop - + forward * my _mathop * + forward / my _mathop / + forward | my _mathop | + forward & my _mathop & + forward ^ my _mathop ^ + + method _relop {op first second} { + return "\[xtal::rt::relop $op [my {*}$first] [my {*}$second]\]" + } + + forward == my _relop == + forward != my _relop != + forward < my _relop < + forward <= my _relop <= + forward > my _relop > + forward >= my _relop >= + + method _boolop {op args} { + # TBD - short circuit ? + set operands [lmap operand $args { + my {*}$operand + }] + return "\[xtal::rt::$op [join $operands { }]\]" + } + forward && my _boolop and + forward || my _boolop or + + method _strop {op first second} { + return "\[xtal::rt::strop $op [my {*}$first] [my {*}$second]\]" + } + forward =^ my _strop =^ + forward !^ my _strop !^ + forward ~ my _strop ~ + forward !~ my _strop !~ + forward ~^ my _strop ~^ + forward !~^ my _strop !~^ + # Next 4 are currently removed from the PEG grammar + # forward =* my _strop =* + # forward !* my _strop !* + # forward =*^ my _strop =*^ + # forward !*^ my _strop !*^ + + method UnaryExpr {op child} { + return "\[xtal::rt::unary $op [my {*}$child]\]" + } + + method SelectorGenerate {primary_expr selector_expr} { + set frag { + xtal::rt::push_selector_context %VALUE% + try { + return -level 0 [%COMMAND%] + } finally { + xtal::rt::pop_selector_context + } + } + set first_op [lindex $selector_expr 1 0] + incr SelectorNestingLevel + try { + if {$first_op eq "Range"} { + # Optimize C[range] + set range_high [lindex $selector_expr 1 2] + if {[llength $range_high]} { + set range_high [my {*}$range_high] + } else { + set range_high end + } + set command "xtal::rt::range \[xtal::rt::selector_context\] [my {*}[lindex $selector_expr 1 1]] $range_high" + } elseif {[lindex $selector_expr 1 1] eq "SelectorContext" && + [set searchop [xtal::_map_search_op $first_op]] ne ""} { + # Optimize C[@@ > 10] + set command "xtal::rt::search_@@ {{$first_op} {$searchop}} \[xtal::rt::selector_context\] [my {*}[lindex $selector_expr 1 2]]" + } elseif {[lindex $selector_expr 1 2] eq "SelectorContext" && + [set searchop [xtal::_map_search_op_reverse $first_op]] ne ""} { + # Optimize C[10 > @@] etc. + set reverse_op [xtal::_math_op_reverse $first_op] + set command "xtal::rt::search_@@ {{$reverse_op} {$searchop}} \[xtal::rt::selector_context\] [my {*}[lindex $selector_expr 1 1]]" + } + + if {![info exists command]} { + # No optimization matched. Use generic selector method + set command "xtal::rt::selector \[xtal::rt::selector_context\] [my {*}$selector_expr]" + } + set primary "\[[string map [list %VALUE% $primary_expr %COMMAND% $command] $frag]\]" + } finally { + incr SelectorNestingLevel -1 + } + return $primary + } + + method PostfixExpr {primary_expr args} { + if {[llength $args] == 0} { + return [my {*}$primary_expr] + } + + # For functions, we take identifier as the name of the function, + # not as a variable containing the name of a function. + if {[lindex $args 0 0] eq "FunctionCall"} { + switch -exact -- [lindex $primary_expr 0] { + IndirectLiteral - + Identifier { set primary [lindex $primary_expr 1] } + IndirectIdentifier { + set primary "\[xtal::rt::dereference [lindex $primary_expr 1]\]" + } + default { set primary [my {*}$primary_expr] } + } + } else { + set primary [my {*}$primary_expr] + } + + + foreach postexpr $args { + switch -exact -- [lindex $postexpr 0] { + Selector { + set primary [my SelectorGenerate $primary $postexpr] + } + FunctionCall { + set fnargs {} + set methods {} + # Each fnarg might be a method name, a plain argument + # or an option with value argument + foreach elem [lrange $postexpr 1 end] { + if {[lindex $elem 0] eq "Element"} { + lappend methods [my {*}$elem] + } else { + # ArgumentList + foreach argelem [lrange $elem 1 end] { + foreach fnarg $argelem { + lappend fnargs [my {*}$fnarg] + } + } + } + } + set primary "\[$primary [join $methods { }] [join $fnargs { }]\]" + } + Element { + set primary "\[xtal::rt::element $primary [my {*}$postexpr]\]" + } + TableColumns { + set primary "\[tarray::table::slice $primary [my {*}$postexpr]\]" + } + } + } + return "$primary" + } + + method Selector {child} { + return [my {*}$child] + } + + method Element {child} { + switch -exact -- [lindex $child 0] { + IndirectLiteral - + Identifier { return [lindex $child 1] } + IndirectIdentifier { + return "\[xtal::rt::dereference [lindex $child 1]\]" + } + default { return [my {*}$child] } + } + } + + method TableColumns {args} { + set cols [lmap colarg $args { + my Element $colarg + }] + return "\[list [join $cols]\]" + } + + method SelectorContext {} { + return "\[xtal::rt::selector_context\]" + } + + method ColumnConstructor {coltype size {inivalue {}}} { + if {[llength $inivalue]} { + if {[lindex $inivalue 0] eq "ColumnConstructorSeries"} { + # Note size is ignored for column series + return "\[xtal::rt::column_series $coltype [my {*}$inivalue]\]" + } elseif {[lindex $inivalue 0] eq "ColumnConstructorRandom"} { + return "\[tarray::column::random $coltype [my {*}$size] [my {*}$inivalue]\]" + } else { + return "\[xtal::rt::column_create $coltype [my {*}$inivalue] [my {*}$size]\]" + } + } else { + return "\[tarray::column::create $coltype {} [my {*}$size] \]" + } + } + + method ColumnConstructorSeries {start stop {step {Number 1}}} { + return "\[list [my {*}$start] [my {*}$stop] [my {*}$step]\]" + } + + method ColumnConstructorRandom {args} { + if {[llength $args] == 0} { + return "" + } elseif {[llength $args] == 1} { + return "[my {*}[lindex $args 0]]" + } else { + return "[my {*}[lindex $args 0]] [my {*}[lindex $args 1]]" + } + } + + method TableConstructor {coldefs inivalue} { + if {[llength $inivalue]} { + return "\[tarray::table::create {$coldefs} [my {*}$inivalue]\]" + } else { + return "\[tarray::table::create {$coldefs}\]" + } + } + + method Sequence {args} { + return "\[list [join [lmap arg $args { + my {*}$arg + }] { }]\]" + } + + method PlainString s {return "{$s}"} + method TclString s {return "\[xtal::rt::tclstring {$s}\]"} + method OptionString s {return "{$s}"} + method Number {n} {return $n} + method RangeEnd {} {return "end"} + method Range {low args} { + if {[llength $args]} { + set high [my {*}[lindex $args 0]] + } else { + set high "end" + } + if {$SelectorNestingLevel} { + return "\[xtal::rt::selector_range \[list [my {*}$low] $high\]\]" + } else { + return "\[list [my {*}$low] $high\]" + } + } + + method IndirectIdentifier {ident} { + return "\[xtal::rt::dereference2 $ident\]" + } + + method IndirectLiteral {lit} { + return "\[xtal::rt::dereference {$lit}\]" + } + + method Identifier {ident} { + return "\[set $ident\]" + } + + method TclScript s {return "\[try {\n$s\n}\]"} + + method ListCast {expr} { + return "\[xtal::rt::listcast [my {*}$expr]\]" + } + + method DictCast {expr} { + return "\[xtal::rt::dictcast [my {*}$expr]\]" + } + + method VSort {ident options} { + return "\[tarray::column::vsort $options {$ident}\]" + } + + method SortCommand {operand args} { + + set options {} + foreach arg $args { + if {[lindex $arg 0] eq "SortOptions"} { + set options [lindex $arg 1] + } else { + set target $arg + } + } + if {[info exists target]} { + return "\[xtal::rt::sort_indirect [my {*}$operand] [my {*}$target] {$options}\]" + } else { + return "\[xtal::rt::sort [my {*}$operand] {$options}\]" + } + } + + method SearchCommand {operand args} { + if {[lindex $args 0 0] eq "SearchTarget"} { + set search_col [my {*}[lindex $args 0]] + set op [xtal::_map_search_op [lindex $args 1 1]] + if {$op eq ""} { + error "Unknown relational operator [lindex $args 1 1]" + } + set search_val [my {*}[lindex $args 2]] + set opts "-among [my {*}$operand] [lrange $args 3 end]" + # return "\[xtal::rt::search [my {*}[lindex $args 0]] [xtal::_map_search_op [lindex $args 1 1]] [my {*}[lindex $args 2]] -among [my {*}$operand] [lrange $args 3 end]\]" + } else { + set search_col [my {*}$operand] + set op [xtal::_map_search_op [lindex $args 0 1]] + if {$op eq ""} { + error "Unknown relational operator [lindex $args 0 1]" + } + set search_val [my {*}[lindex $args 1]] + set opts "[lrange $args 2 end]" + # return "\[xtal::rt::search [my {*}$operand] [xtal::_map_search_op [lindex $args 0 1]] [my {*}[lindex $args 1]] [lrange $args 2 end]\]" + } + return "\[tarray::column::search $opts $op $search_col $search_val\]" + } + + method SearchTarget {postexpr} { + return [my {*}$postexpr] + } + + method BuiltInCall {fn arglist} { + set qfn [dict get { + delete xtal::rt::delete + fill xtal::rt::fill + inject xtal::rt::inject + insert xtal::rt::insert + lookup tarray::column::lookup + reverse xtal::rt::reverse + sum tarray::column::sum + } $fn] + set fnargs {} + foreach argelem [lrange $arglist 1 end] { + foreach fnarg $argelem { + if {($fn in {delete fill}) && [lindex $fnarg 0] eq "Range"} { + # Translate Range args like i:j to two separate args + lappend fnargs {*}[my {*}[lindex $fnarg 1]] + if {[llength $fnarg] == 3} { + lappend fnargs {*}[my {*}[lindex $fnarg 2]] + } else { + lappend fnargs "end" + } + } else { + lappend fnargs [my {*}$fnarg] + } + } + } + return "\[$qfn [join $fnargs { }]\]" + } + + method VBuiltInCall {fn arglist} { + set fnargs {} + foreach argelem [lrange $arglist 2 end] { + foreach fnarg $argelem { + if {($fn in {vdelete vfill}) && [lindex $fnarg 0] eq "Range"} { + # Translate Range args like i:j to two separate args + lappend fnargs {*}[my {*}[lindex $fnarg 1]] + if {[llength $fnarg] == 3} { + lappend fnargs {*}[my {*}[lindex $fnarg 2]] + } else { + lappend fnargs "end" + } + } else { + lappend fnargs [my {*}$fnarg] + } + } + } + return "\[xtal::rt::$fn {[lindex $arglist 1 0 1]} [join $fnargs { }]\]" + } + + method FunctionDefinition {name params body} { + set code [my _clause_to_code $body] + set arguments {} + foreach param $params { + if {[llength $param] == 2} { + lappend arguments "\[list [lindex $param 0] [my {*}[lindex $param 1]]\]" + } else { + lappend arguments [lindex $param 0] + } + } + return "proc {$name} \[list [join $arguments { }]\] {\n$code[my Indent]}" + } +} + +namespace eval xtal::rt { + variable _selector_contexts {} + + proc tclstring s { + return [uplevel 1 [list subst $s]] + } + + proc selector_context {} { + variable _selector_contexts + if {[llength $_selector_contexts]} { + return [lindex $_selector_contexts end] + } + error "Not in a selector context" + } + + proc is_selector_context {val} { + variable _selector_contexts + if {[llength $_selector_contexts]} { + return [::tarray::_same_tclobj $val [lindex $_selector_contexts end]] + } else { + return 0 + } + } + + proc push_selector_context {val} { + variable _selector_contexts + lappend _selector_contexts $val + } + + proc pop_selector_context {} { + variable _selector_contexts + # Fastest Pop list from http://wiki.tcl.tk/22619 + set r [lindex $_selector_contexts end] + set _selector_contexts [lreplace $_selector_contexts [set _selector_contexts end] end] ; # Make sure [lreplace] operates on unshared object + return $r + } + + proc column_create {type inival size} { + # TBD - why do we not generate code that directly calls + # column::create ? That will generate an error for tables anyways + return [switch -exact -- [lindex [tarray::types $inival] 0] { + table { error "Cannot convert a table to a column" } + "" { tarray::column::create $type $inival $size } + default { tarray::column::create $type $inival $size} + }] + } + + proc column_series {type range} { + # TBD check whether it would be faster to verify types before + # calling cast and if same, not call it at all. Note + # the column::create does that check anyways but calling into + # C is so slow, it might be faster to check in script first + return [tarray::column::create $type [tarray::column::series {*}$range]] + } + + proc tarray_assign_element {varname value index} { + # Assign a value to a single column or table element + upvar 1 $varname var + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + return [switch -exact -- [lindex [tarray::types $var] 0] { + table { tarray::table::vfill var $value $index } + "" { lset var $index $value } + default { tarray::column::vfill var $value $index } + }] + } + + proc tarray_assign_range {varname value low high} { + # varname is the name of a column or table variable (must exist) + # value is the value to be assigned + # [low high] is the range to assign to + + upvar 1 $varname var + + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + + lassign [tarray::types $var $value] vartype valuetype + + if {$high eq "end"} { + set high [operand_size $var] + incr high -1 + } + + set target_size [expr {$high - $low + 1}] + if {$target_size < 1} { + error "Range lower limit $low is greater than upper limit $high." + } + + + if {$vartype eq ""} { + # variable to be treated as a list + switch -exact -- $valuetype { + table { + set value_size [tarray::table::size $value] + set value [tarray::table::range $value 0 end] + } + "" { set value_size [llength $value] } + default { + set value_size [tarray::column::size $value] + set value [tarray::column::range -list $value 0 end] + } + } + if {$value_size != $target_size} { + error "Source size $value_size differs from target range $low:$high." + } + set lsize [llength $var] + if {$low > $lsize || $low < 0} { + # Note $low == $lsize is ok. Will extend the vector + error "Range lower limit $low is out of bounds." + } + # Need to workaround a Tcl lreplace bug/inconsistency + # see http://core.tcl.tk/tcl/tktview?name=47ac84309b or + # http://core.tcl.tk/tcl/tktview?name=578c2fd960 + if {$low == $lsize} { + lappend var {*}$value + } else { + set var [lreplace $var[set var ""] $low $high {*}$value] + } + return $var + } + + if {$vartype eq "table"} { + + # If the value is also a table, we assume each row in the value + # is to be assigned successively to the target range. Otherwise + # it is a value to be filled in the target range. + if {$valuetype eq "table"} { + set source_size [tarray::table::size $value] + } else { + if {$valuetype ne ""} { + error "Cannot assign a column to a table range." + } + # List of rows + set source_size [llength $value] + } + + # We have to use a put. Make sure the source range + # and target range match + if {$target_size != $source_size} { + error "Source size $source_size differs from target table range $low:$high." + } + return [tarray::table::vput var $value $low] + } + + # vartype is a column type + if {$valuetype eq "table"} { + # No possibility of conversion. But target might be + # of type any in which case we have to fill the range + error "Cannot assign a table to a column range." + } + + if {$valuetype eq ""} { + set source_size [llength $value] + } else { + set source_size [tarray::column::size $value] + if {$vartype ne $valuetype} { + set value [tarray::column::create $vartype $value] + } + } + + if {$target_size != $source_size} { + error "Source size $source_size differs from target column range $low:$high." + } + return [tarray::column::vput var $value $low] + } + + proc tarray_assign {varname value index} { + upvar 1 $varname var + # varname is the name of a column or table variable (must exist) + # value is the value to be assigned + # index is a general expression + # + + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + + lassign [tarray::types $var $value $index] vartype valuetype indextype + + if {$indextype eq "boolean"} { + set index_len [tarray::column::count $index 1] + } elseif {$indextype eq "int"} { + set index_len [tarray::column::size $index] + } elseif {$indextype eq ""} { + set index_len [llength $index] + # Special case - if a single index, treat as assignment of + # a single value + if {$index_len == 1} { + set value [list $value] + } + } else { + error "Index must be a integer, an integer list, or an index column." + } + if {$valuetype eq ""} { + set value_len [llength $value] + } elseif {$valuetype eq "table"} { + set value_len [tarray::table::size $value] + } else { + set value_len [tarray::column::size $value] + } + + # The vplace commands do not mind if source len is greater than + # target length but current xtal semantics do not allow this so + # explicitly check. + if {$index_len != $value_len} { + error "Number of indices ($index_len) not same as number of values ($value_len)." + } + if {$index_len == 0} { + return $var + } + + if {$vartype eq ""} { + # Assume var is a list + if {$indextype eq "boolean"} { + set index [tarray::column::range -list [tarray::column::search -eq -all $index 1] 0 end] + } elseif {$indextype eq "int"} { + set index [tarray::column::range -list $index 0 end] + } else { + if {$index_len == 1} { + lset var $index [lindex $value 0] + return $var + } + } + + if {$valuetype eq "table"} { + set value [tarray::table::range -list $value 0 end] + } elseif {$valuetype ne ""} { + set value [tarray::column::range -list $value 0 end] + } + + # Indices need to be in order else extending the list + # length will not work right. + set indirect_indices [lsort -indices -integer -increasing $index] + + # Also need to validate indices BEFORE making any modifications + if {[lindex $index [lindex $indirect_indices 0]] < 0} { + error "Invalid index ([lindex $index [lindex $indirect_indices 0]])." + } + set index_limit [llength $var] + foreach indirect_index $indirect_indices { + # Test in order of most likely + set i [lindex $index $indirect_index] + if {$i < $index_limit} continue + if {$i == $index_limit} { + incr index_limit + continue + } + # There is a gap in the indices while extending the list + error "Invalid index ($i)." + } + + # Now we are ready to update the var + foreach indirect_index $indirect_indices { + lset var [lindex $index $indirect_index] [lindex $value $indirect_index] + } + return $var + } + + # Variable is a table or column + + if {$indextype eq "" && $index_len == 1} { + # Treat as a single value + if {$vartype eq "table"} { + return [tarray::table::vfill var [lindex $value 0] $index] + } else { + return [tarray::column::vfill var [lindex $value 0] $index] + } + } + + if {$valuetype eq $vartype} { + # Both source and destination are same type. + if {$vartype eq "table"} { + return [tarray::table::vplace var $value $index] + } else { + return [tarray::column::vplace var $value $index] + } + } + + # Either value is not a tarray or is a tarray of a different type. + if {$vartype eq "table"} { + # In case of tables, there is no cast/conversion possible + # so just do the assignment. value must be a table of list + # of rows. No need to check because vplace will error out itself. + return [tarray::table::vplace var $value $index] + } + + # Variable is a column. Value is a column of a different type or + # a list of values. In the former case we need to cast. In the + # latter case vplace will convert the list itself. + if {$valuetype ne ""} { + set value [tarray::column::create $vartype $value] + } + return [tarray::column::vplace var $value $index] + } + + proc table_column_assign_range {varname colname value low high} { + # varname is the name of a table variable (must exist) + # colname is the name of the column to assign to + # value is the value to be assigned + # [low high] is the range to assign to + + upvar 1 $varname var + + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + lassign [tarray::types $var $value] vartype valuetype + + if {$vartype ne "table"} { + error "$varname is not a table." + } + + # TBD - does xtal permit the keyword end ? + if {$high eq "end"} { + set high [tarray::table size $var] + incr high -1 + } + + set target_size [expr {$high - $low + 1}] + if {$target_size < 1} { + error "Range lower limit $low is greater than upper limit $high." + } + + if {$valuetype eq "table"} { + set source_size [tarray::table::size $value] + } elseif {$valuetype eq ""} { + # Plain Tcl value + set source_size [llength $value] + # Convert the list of values to a list of rows + set value [lmap val $value { list $val }] + } else { + # If the specified value is a column, convert it to + # a table + set value [tarray::table::create2 [list $colname] [list $value]] + set source_size [tarray::table::size $value] + } + + # We were passed a value that was a table or could be converted to one + # We have to use a put. Make sure the source range + # and target range match + if {$target_size != $source_size} { + error "Source size $source_size differs from target table range $low:$high." + } + return [tarray::table::vput -columns [list $colname] var $value $low] + } + + proc table_column_assign {varname colname value index} { + # varname is the name of a table variable (must exist) + # colname is the column name + # value is the value to be assigned + # index is a general expression, might be a single integer value, + # an integer column, a list of integers or + # something else. + + upvar 1 $varname var + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + lassign [tarray::types $var $value $index] vartype valuetype indextype + if {$vartype ne "table"} { + error "$varname is not a table." + } + + if {$indextype eq ""} { + set index_len [llength $index] + # Special case - if a single index, treat as assignment of + # a single value + if {$index_len == 1} { + set value [list $value] + } + } elseif {$indextype ne "table"} { + set index_len [tarray::column::size $index] + } else { + error "Index must be a integer, an integer list, or an integer column." + } + if {$valuetype eq ""} { + set value_len [llength $value] + } elseif {$valuetype eq "table"} { + error "Cannot assign table to a column." + } else { + set value_len [tarray::column::size $value] + } + + if {0} { + This check is disabled because if the index column is a boolean + the size of the column will not be same as number of values. + TBD - for now leave out until we decide whether to allow + # The vplace commands do not mind if source len is greater than + # target length but current xtal semantics do not allow this so + # explicitly check. + if {$index_len != $value_len} { + error "Number of indices ($index_len) not same as number of values ($value_len)." + } + } + if {$index_len == 0} { + return $var + } + + # If the specified value is a column, convert it to a table + # else it will be a list of rows + if {$valuetype eq ""} { + # Need to make each elem in list a row + # TBD - likely to be slow. Need optimization + set value [lmap val $value { + list $val + }] + } elseif {$valuetype ne "table"} { + # It's a column + set value [tarray::table::create2 [list $colname] [list $value]] + } + + # If value is a table we use vplace to update the target array. + # In this case, the table dimensions and type must match and + # indexlist must be a int tarray or an int list else + # vplace will throw an error. + return [tarray::table::vplace -columns [list $colname] var $value $index] + } + + proc table_columns_replace {varname colnames value} { + # Replaces the specified columns. value must also be a table + upvar 1 $varname var + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + lassign [tarray::types $var $value] vartype valuetype + if {$vartype ne "table" || $valuetype ne "table"} { + error "Operand is not a tarray table" + } + + if {[tarray::table::width $value] != [llength $colnames]} { + error "Number of source and target columns differ." + } + + # TBD - check efficiency + set var2 $var; # Don't want to modify var in case or errors + + foreach colname $colnames newcol [tarray::table::columns $value] { + tarray::table::vcolumn var2 $colname $newcol + } + return [set var $var2] + } + + proc table_columns_assign_range {varname colnames value low high} { + # varname is the name of a table variable (must exist) + # colnames is the list of column names to assign to + # value is the value to be assigned + # [low high] is the range to assign to + + upvar 1 $varname var + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + + lassign [tarray::types $var $value] vartype valuetype + + if {$vartype ne "table"} { + error "$varname is not a table." + } + + if {$high eq "end"} { + set high [tarray::table size $var] + incr high -1 + } + + # TBD - does xtal permit the keyword end ? + set target_size [expr {$high - $low + 1}] + if {$target_size < 1} { + error "Range lower limit $low is greater than upper limit $high." + } + + if {$valuetype eq ""} { + set value_len [llength $value] + } elseif {$valuetype eq "table"} { + set value_len [tarray::table::size $value] + } else { + error "Cannot assign a column to a table." + } + + # We were passed a value that was a table or could be converted to one + # We have to use a put. Make sure the source range + # and target range match + if {$target_size != $value_len} { + error "Source size $value_len differs from target table range $low:$high." + } + + return [tarray::table::vput -columns $colnames var $value $low] + } + + proc table_columns_assign {varname colnames value index} { + # varname is the name of a table variable (must exist) + # colnames is a list of column names + # value is the value to be assigned + # index is a general expression - might be a single integer value, + # a list of integers or + # something else. For the first two, vplace/vfill do the right + # thing. For others, they will raise an error. + + upvar 1 $varname var + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + lassign [tarray::types $var $value $index] vartype valuetype indextype + if {$vartype ne "table"} { + error "$varname is not a table." + } + + if {$indextype eq ""} { + set index_len [llength $index] + # Special case - if a single index, treat as assignment of + # a single value + if {$index_len == 1} { + set value [list $value] + } + } elseif {$indextype eq "int"} { + set index_len [tarray::column::size $index] + } else { + error "Index must be a integer, an integer list, or an integer column." + } + if {$valuetype eq ""} { + set value_len [llength $value] + } elseif {$valuetype eq "table"} { + set value_len [tarray::table::size $value] + } else { + error "Cannot assign a column to a table" + } + + # The vplace commands do not mind if source len is greater than + # target length but current xtal semantics do not allow this so + # explicitly check. + if {$index_len != $value_len} { + error "Number of indices ($index_len) not same as number of values ($value_len)." + } + if {$index_len == 0} { + return $var + } + + + # In this case, the table dimensions and type must match and + # indexlist must be a int tarray or an int list else + # vplace will throw an error. + return [tarray::table::vplace -columns $colnames var $value $index] + } + + proc assign_element {varname elem value} { + # For a table sets entire column $elem to $value + # For a column assigns $value to index $elem + # Else treats as dictionary and assigns $value to key + upvar 1 $varname var + if {[info exists var]} { + switch -exact -- [lindex [tarray::types $var] 0] { + "" { return [dict set var $elem $value] } + "table" { return [tarray::table::vcolumn var $elem $value] } + default { + return [tarray::column::vfill var $value [tarray::column::search $var $elem]] + } + } + } else { + return [dict set var $elem $value] + } + } + + proc element {operand element} { + switch -exact -- [lindex [tarray::types $operand] 0] { + "" { return [dict get $operand $element] } + "table" { return [tarray::table::column $operand $element] } + default { + set index [tarray::column::search $operand $element] + if {$index < 0} { + error "Value \"$element\" not found in column" + } + return $index + } + } + } + + proc range {operand low high} { + switch -exact -- [lindex [tarray::types $operand] 0] { + "" { return [lrange $operand $low $high] } + "table" { return [tarray::table::range $operand $low $high] } + default { return [tarray::column::range $operand $low $high] } + } + } + + proc _relop_check {a b} { + lassign [tarray::types $a $b] atype btype + if {$atype eq "table" || $btype eq "table"} { + error "Tables cannot be operands for a relational operator." + } + return [list $atype $btype] + } + + # TBD - rewrite in C. Is this actually used anywhere? + # Returns a boolean column corresponding to an index column + proc _indices_to_boolcol {indices} { + # indices must be a sorted integer column + if {[::tarray::column size $indices] == 0} { + return [tarray::column::create boolean] + } else { + set n [::tarray::column::index $indices end] + return [tarray::column::bitmap0 [expr {$n+1}] $indices] + } + } + + proc relop {op a b} { + # Relational operators behave as follows depending on whether + # operands are columns, are lists that are the current selector + # context or scalars. + # + # When at least one operand is a column: + # 1 If both are columns, they are compared element by element + # returning a boolean column. + # 2 If one is a column, other is selector context, the latter + # is converted to a column of that type and compared as above + # 3 If one is a column, other is a (non-selector context) scalar, + # returns a boolean column based on comparison of each element + # with the scalar value + # + # When neither operand is a column: + # 4 If neither is a list selector context, returns a scalar + # as computed by expr + # 5 If only one is the selector context, returns a boolean + # column with element comparisons + # 6 If both are selector contexts, they refer to the same + # object so return a boolean column of all ones depending + # on the operation. + lassign [_relop_check $a $b] atype btype + + if {$atype ne ""} { + # Cases 1,2,3 + if {$btype eq "" && [is_selector_context $b]} { + # Case 2 - convert list to column of that type + set b [tarray::column create $atype $b] + } + return [tarray::column::math $op $a $b] + } elseif {$btype ne ""} { + # Cases 2,3 + if {[is_selector_context $a]} { + # Case 2 - convert list to column of that type + set a [tarray::column create $btype $a] + } + return [tarray::column::math $op $a $b] + } else { + # Cases 4,5,6 + if {[is_selector_context $a]} { + if {[is_selector_context $b]} { + # Case 6 - both are same operand + set n [llength $a] + set result [tarray::column::create boolean {} $n] + incr n -1 + if {$op in {== <= >=}} { + tarray::column::vfill result 1 0 $n + } elseif {$op in {!= < >}} { + tarray::column::vfill result 0 0 $n + } else { + error "Operation $op not supported between lists." + } + return $result + } else { + # Case 5 + return [matching_list_indices $op $a $b] + } + } else { + # a is pure scalar + if {[is_selector_context $b]} { + # Case 5 + set reverse_op [xtal::_math_op_reverse $op] + if {$reverse_op eq ""} { + error "The right hand operand of operator $op cannot be a vector." + } + return [matching_list_indices $reverse_op $b $a] + } else { + # Case 4 - both scalars. Note we do not use + # tcl::mathop::* here because those commands can be + # redefined while the expr operators cannot + return [expr "{$a} $op {$b}"] + } + } + } + } + + # TBD - is matching_column_indices actually used anywhere? + proc matching_column_indices {op haystack needle} { + return [switch -exact -- $op { + == { tarray::column::search -bitmap -eq $haystack $needle } + != { tarray::column::search -bitmap -not -eq $haystack $needle } + < { tarray::column::search -bitmap -lt $haystack $needle } + <= { tarray::column::search -bitmap -not -gt $haystack $needle } + > { tarray::column::search -bitmap -gt $haystack $needle } + >= { tarray::column::search -bitmap -not -lt $haystack $needle } + =^ { tarray::column::search -bitmap -nocase -eq $haystack $needle } + !^ { tarray::column::search -bitmap -nocase -not -eq $haystack $needle } + ~ { tarray::column::search -bitmap -re $haystack $needle } + !~ { tarray::column::search -bitmap -not -re $haystack $needle } + ~^ { tarray::column::search -bitmap -nocase -re $haystack $needle } + !~^ { tarray::column::search -bitmap -nocase -not -re $haystack $needle } + }] + } + + proc matching_list_elems {op haystack needle} { + # haystack must be a list, not column + # NOTE: Although we could lump many operations together by using + # $op, that affects byte compilation so list them out separately. + # Also note that for == and != we do not use lsearch since + # its semantics are different from expr (e.g. 0x10 == 16) + return [switch -exact -- $op { + == { + lmap hay $haystack { + if {$hay == $needle} {set hay} else continue + } + } + != { + lmap hay $haystack { + if {$hay != $needle} {set hay} else continue + } + } + < { + lmap hay $haystack { + if {$hay < $needle} {set hay} else continue + } + } + <= { + lmap hay $haystack { + if {$hay <= $needle} {set hay} else continue + } + } + > { + lmap hay $haystack { + if {$hay > $needle} {set hay} else continue + } + } + >= { + lmap hay $haystack { + if {$hay >= $needle} {set hay} else continue + } + } + =^ {lsearch -inline -all -nocase -exact $haystack $needle} + !^ {lsearch -inline -all -nocase -not -exact $haystack $needle} + ~ {lsearch -inline -all -regexp $haystack $needle} + !~ {lsearch -inline -all -not -regexp $haystack $needle} + ~^ {lsearch -inline -all -nocase -regexp $haystack $needle} + !~^ {lsearch -inline -all -nocase -not -regexp $haystack $needle} + }] + } + + proc matching_list_indices {op haystack needle} { + # haystack must be a list, not column + # NOTE: Although we could lump many operations together by using + # $op, that affects byte compilation so list them out separately. + # Also note that for == and != we do not use lsearch since + # its semantics are different from expr (e.g. 0x10 == 16) + set i -1 + set indices [switch -exact -- $op { + == { + lmap hay $haystack { + incr i + if {$hay == $needle} {set i} else continue + } + } + != { + lmap hay $haystack { + incr i + if {$hay != $needle} {set i} else continue + } + } + < { + lmap hay $haystack { + incr i + if {$hay < $needle} {set i} else continue + } + } + <= { + lmap hay $haystack { + incr i + if {$hay <= $needle} {set i} else continue + } + } + > { + lmap hay $haystack { + incr i + if {$hay > $needle} {set i} else continue + } + } + >= { + lmap hay $haystack { + incr i + if {$hay >= $needle} {set i} else continue + } + } + =^ {lsearch -all -nocase -exact $haystack $needle} + !^ {lsearch -all -nocase -not -exact $haystack $needle} + ~ {lsearch -all -regexp $haystack $needle} + !~ {lsearch -all -not -regexp $haystack $needle} + ~^ {lsearch -all -nocase -regexp $haystack $needle} + !~^ {lsearch -all -nocase -not -regexp $haystack $needle} + }] + + return [tarray::column::bitmap0 [llength $haystack] $indices] + } + + # Called for string operators like ~, ^= etc. Not for ==, != + proc strop {op a b} { + lassign [_relop_check $a $b] atype btype + if {$atype eq ""} { + if {[is_selector_context $a]} { + # $a is the selector context and so treat as a list + if {$btype ne "" || [is_selector_context $b]} { + error "Operator $op not supported between columns or columns and lists" + } + # Return an int column containing matching indices + return [matching_list_indices $op $a $b] + } + # $a is not a column and not a selector context (i.e. scalar) + if {$btype eq ""} { + if {[is_selector_context $b]} { + # a is scalar, b is not. Only permit equality/inequality + if {$op in {=^ !^}} { + return [matching_list_indices $op $b $a] + } + error "The right hand operand of operator $op cannot be a vector." + } + # a and b are both scalars + return [switch -exact -- $op { + =^ {string equal -nocase $a $b} + !^ {expr {![string equal -nocase $a $b]}} + ~ {regexp -- $b $a} + !~ {expr {![regexp -- $b $a]}} + ~^ {regexp -nocase -- $b $a} + !~^ {expr {![regexp -nocase -- $b $a]}} + }] + } else { + # a is scalar, b is column. Only permit equality/inequality + return [switch -exact -- $op { + =^ { tarray::column::search -bitmap -nocase -eq $b $a } + !^ { tarray::column::search -bitmap -nocase -not -eq $b $a } + default {error "The right hand operand of operator $op cannot be a vector."} + }] + } + } else { + # a is a column + if {$btype ne "" || [is_selector_context $b]} { + error "Operator $op not supported between columns or columns and lists" + } + # a column, b scalar + return [switch -exact -- $op { + =^ { tarray::column::search -bitmap -nocase -eq $b $a } + !^ { tarray::column::search -bitmap -nocase -not -eq $b $a } + ~ { tarray::column::search -bitmap -re $a $b } + !~ { tarray::column::search -bitmap -not -re $a $b } + ~^ { tarray::column::search -bitmap -nocase -re $a $b } + !~^ { tarray::column::search -bitmap -nocase -not -re $a $b } + }] + } + } + + proc unary {op a} { + set type [lindex [tarray::types $a] 0] + switch -exact -- $type { + "" { + if {$op eq "%"} { + return [llength $a] + } else { + return [expr "$op\$a"] + } + } + "table" { + if {$op eq "%"} { + return [tarray::table::size $a] + } + error "Unary op $op not implemented for tables" + } + default { + # TBD - replace these with column::unary calls when implemented + switch -exact -- $op { + "%" { return [tarray::column::size $a] } + "-" { return [tarray::column::math - 0 $a] } + "+" { + if {$type in {byte int uint wide double}} { + return $a + } + } + "~" { + if {$type in {boolean byte int uint wide}} { + return [tarray::column::math ^ $a [dict get {boolean 1 byte 0xff int -1 uint 0xffffffff wide 0xffffffffffffffff} $type]] + } + } + } + error "Unary op $op not implemented for columns of type $type" + } + } + + + if {$type eq ""} { + return [expr "$op\$a"] + } else { + # TBD + error "Unary op $op not implemented for columns and tables" + return [tarray::column::unary $op $a] + } + } + + proc and {args} { + set result [_and2 [lindex $args 0] [lindex $args 1]] + foreach arg [lrange $args 2 end] { + set result [_and2 $result $arg] + } + return $result + } + + proc _and2 {a b} { + lassign [tarray::types $a $b] atype btype + + if {$atype eq "" && $btype eq ""} { + # Neither is a tarray + return [expr {$a && $b}] + } + + if {$atype eq "table" || $btype eq "table"} { + error "Tables cannot be used as operands of a logical operator." + } + + # At least one is a column + return [tarray::column::math && $a $b] + } + + proc or {args} { + set result [_or2 [lindex $args 0] [lindex $args 1]] + foreach arg [lrange $args 2 end] { + set result [_or2 $result $arg] + } + return $result + } + + proc _or2 {a b} { + lassign [tarray::types $a $b] atype btype + + if {$atype eq "" && $btype eq ""} { + # Neither is a tarray + return [expr {$a || $b}] + } + + if {$atype eq "table" || $btype eq "table"} { + error "Tables cannot be used as operands of a logical operator." + } + + # At least one is a column + return [tarray::column::math || $a $b] + } + + proc selector {a selexpr} { + lassign [tarray::types $a $selexpr] atype seltype + + if {$seltype eq "" && [string is integer -strict $selexpr]} { + # Not a column, treat as an index + return [switch -exact -- $atype { + "" { + set n [llength $a] + if {$selexpr < 0 || $selexpr >= $n} { + error "list index out of range" + } + lindex $a $selexpr + } + table { tarray::table::index $a $selexpr } + default { tarray::column::index $a $selexpr } + }] + } + + # Either operand is not a list or index is not a simple integer + return [switch -exact -- $atype { + "" { + # Operand is a list + set n [llength $a] + set l {} + if {$seltype eq ""} { + set l [lmap pos $selexpr { + if {$pos < 0 || $pos >= $n} { + error "list index out of range" + } + lindex $a $pos + }] + } elseif {$seltype eq "boolean"} { + ::tarray::loop i b $selexpr { + if {$i >= $n} { + error "list index out of range" + } + if {$b} {lappend l [lindex $a $i]} + } + } else { + if {$seltype ni {byte int uint wide}} { + error "Invalid index expression." + } + ::tarray::loop pos $selexpr { + if {$pos < 0 || $pos >= $n} { + error "list index out of range" + } + lappend l [lindex $a $pos] + } + } + set l + } + table { tarray::table::get $a $selexpr } + default { tarray::column::get $a $selexpr } + }] + } + + # Returns a boolean index column + proc selector_range {range} { + lassign $range low high + if {$low < 0} { + set low 0 + } + set n [operand_size [selector_context]] + # $high may be integer or "end" + if {[string is integer -strict $high]} { + if {$high >= $n} { + set high [expr {$n-1}] + } + } + return [::tarray::column::fill [::tarray::column::bitmap0 $n] 1 $low $high] + } + + proc operand_size {val} { + return [switch -exact -- [lindex [tarray::types $val] 0] { + "" { llength $val } + table { tarray::table::size $val } + default { tarray::column::size $val } + }] + } + + proc dereference {varname} { + upvar 1 $varname var + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + # Avoid shimmering of columns and tables + if {[lindex [tarray::types $var] 0] ne ""} { + error "Dereferencing of columns and tables not permitted." + } + return $var + } + + proc dereference2 {varname} { + upvar 1 $varname var + if {![info exists var]} { + error "can't read \"$varname\": no such variable" + } + # Avoid shimmering of columns and tables + if {[lindex [tarray::types $var] 0] ne ""} { + error "Dereferencing of columns and tables not permitted." + } + upvar 1 $var var2 + return $var2 + } + + proc condition {expr} { + switch -exact -- [lindex [tarray::types $expr] 0] { + "" { return $expr } + table { return [expr {[tarray::table::size $expr] > 0}] } + default { return [expr {[tarray::column::size $expr] > 0}] } + } + } + + proc listcast {val} { + return [switch -exact -- [lindex [tarray::types $val] 0] { + table { tarray::table::range -list $val 0 end } + "" { error "Operand of @list must be a column or table" } + default { tarray::column::range -list $val 0 end } + }] + } + + proc dictcast {val} { + return [switch -exact -- [lindex [tarray::types $val] 0] { + table { tarray::table::range -dict $val 0 end } + "" { error "Operand of @dict must be a column or table" } + default { tarray::column::range -dict $val 0 end } + }] + } + + proc throwerror {errorcode} { + # Assumes last element of errorcode is the message + return -code error -level 2 -errorcode $errorcode [lindex $errorcode end] + } + + proc sort {operand options} { + return [switch -exact -- [lindex [tarray::types $operand] 0] { + table { + # TBD - check in C source that $target is not a column or + # table to prevent shimmering + tarray::table::Sort {*}$options $operand 0 + } + "" { error "Operand of @sort must be a column or table" } + default { tarray::column::Sort {*}$options $operand} + }] + } + + proc sort_indirect {operand target options} { + return [switch -exact -- [lindex [tarray::types $operand] 0] { + table { + # TBD - check in C source that $target is not a column or + # table to prevent shimmering + tarray::table::Sort {*}$options $operand $target + } + "" { error "Operand of @sort must be a column or table" } + default { tarray::column::Sort -indirect $target {*}$options $operand} + }] + } + + proc delete {operand args} { + return [switch -exact -- [lindex [tarray::types $operand] 0] { + table { tarray::table::delete $operand {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::delete $operand {*}$args } + }] + } + + proc vdelete {ident args} { + upvar 1 $ident var + if {![info exists var]} { + error "can't read \"$ident\": no such variable" + } + return [switch -exact -- [lindex [tarray::types $var] 0] { + table { tarray::table::vdelete var {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::vdelete var {*}$args } + }] + } + + proc fill {operand args} { + return [switch -exact -- [lindex [tarray::types $operand] 0] { + table { tarray::table::fill $operand {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::fill $operand {*}$args } + }] + } + + proc vfill {ident args} { + upvar 1 $ident var + if {![info exists var]} { + error "can't read \"$ident\": no such variable" + } + return [switch -exact -- [lindex [tarray::types $var] 0] { + table { tarray::table::vfill var {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::vfill var {*}$args } + }] + } + + proc inject {operand args} { + return [switch -exact -- [lindex [tarray::types $operand] 0] { + table { tarray::table::inject $operand {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::inject $operand {*}$args } + }] + } + + proc vinject {ident args} { + upvar 1 $ident var + if {![info exists var]} { + error "can't read \"$ident\": no such variable" + } + return [switch -exact -- [lindex [tarray::types $var] 0] { + table { tarray::table::vinject var {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::vinject var {*}$args } + }] + } + + proc insert {operand args} { + return [switch -exact -- [lindex [tarray::types $operand] 0] { + table { tarray::table::insert $operand {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::insert $operand {*}$args } + }] + } + + proc vinsert {ident args} { + upvar 1 $ident var + if {![info exists var]} { + error "can't read \"$ident\": no such variable" + } + return [switch -exact -- [lindex [tarray::types $var] 0] { + table { tarray::table::vinsert var {*}$args } + "" { error "Operand is not a column or able" } + default { tarray::column::vinsert var {*}$args } + }] + } + + proc reverse {operand} { + return [switch -exact -- [lindex [tarray::types $operand] 0] { + table { tarray::table::reverse $operand } + "" { lreverse $operand } + default { tarray::column::reverse $operand } + }] + } + + proc vreverse {ident} { + upvar 1 $ident var + if {![info exists var]} { + error "can't read \"$ident\": no such variable" + } + return [switch -exact -- [lindex [tarray::types $var] 0] { + table { tarray::table::vreverse var } + "" { error "Operand is not a column or able" } + default { tarray::column::vreverse var } + }] + } + + proc search_@@ {ops haystack needle} { + # $ops is a pair containing the math version and the equivalent + # column version of the comparison operator e.g {!= {-not -eq}} + lassign $ops math_op search_op + return [switch -exact -- [lindex [tarray::types $haystack] 0] { + table { error "Tables cannot be used as search operands" } + "" { + # Assume lists + matching_list_elems $math_op $haystack $needle + } + default { tarray::column::search -inline -all {*}$search_op $haystack $needle } + }] + } +} + +# Pick up ancillary support functions +# Commented out because critcl now renames and sources them itself +# source [file join [file dirname [info script]] ptast.tcl] +# source [file join [file dirname [info script]] ptutil.tcl] +# source [file join [file dirname [info script]] shell.tcl] + +# Local Variables: +# compile-command: "envset x64 && tclsh build.tcl extension -config ../src/tarray.cfg -keep -target win32-dev64" +# End: diff --git a/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/xtaltest.tcl b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/xtaltest.tcl new file mode 100644 index 00000000..4f219921 --- /dev/null +++ b/src/vfs/punk9win.vfs/lib_tcl9/xtal2.0a1/xtaltest.tcl @@ -0,0 +1,167 @@ +namespace path [list tarray xtal] +proc xtal::testconstexpr {expr desc} { + set t [xtal $expr] + set e [expr $expr] + if {$t != $e} { + puts stderr "$desc failed for <$expr>. $t != $e" + } +} +catch {tp destroy} +catch {tc destroy} +if {1} { + xtal::Parser create tp $::xtal::_use_oo_parser + xtal::Compiler create tc $::xtal::_use_oo_parser + set I [column create int {10 20 30 40 50}] + set J [column create int {100 200 300 400 500}] + set T [table create {i int s string} {{10 ten} {200 twenty} {3000 thirty}}] +} +if {1} { + catch {table slice $T $T}; # Caused crash due to shimmering, now should return error + proc getI {} {return $::I} + xtal::xtal {I[@@ < 30]} + xtal::xtal {I.20} + xtal::xtal {I. "10"} + xtal::xtal {I[I < 30]} + xtal::xtal {getI()[@@ > 30]} + set x i + xtal::xtal {T[T.i < 35]} + xtal::xtal {T[T.$x < 45]} + xtal::xtal {T.(i,s)[@@.i > 40]} + xtal::xtal {K = J} + xtal::xtal {K[0:] = I[0:]} + xtal::xtal {K[0:1] = J[0:1]} + xtal::xtal {K[2:4] = {99,100,101}} + xtal::xtal {K[1:] = lrepeat(%K-1, 999)} + xtal::xtal {K[{3,4}] = I[{4,3}]} + xtal::xtal {T.i[0:1] = I[3:4]} + xtal::xtal {T.(s,i)} + xtal::xtal {T.s. thirty} + xtal::xtal {T.s. "thirty"} + xtal::xtal {T.i[@@ < 400] = 10*T.i[@@ < 400]} + set col s + xtal::xtal {T.$col[0:1] = {'abc', "cba"} } + xtal::xtal {T.$col[1:] = lrepeat(%T-1, 'def')} + xtal::xtal {% I} + xtal::xtal {% {1,2,3}} + + namespace eval xtal { + testconstexpr {4-2+2} "+- Left associativity" + testconstexpr {4-2-2} "- Left associativity" + testconstexpr {1+2*3} "+* Operator precedence" + testconstexpr {1||0&&0} "Logical operator precedence" + } + catch {C destroy} + oo::class create C { method m {args} {puts [join $args ,]} } + set o [C new] + xtal::xtal {a = 'b' ; b = 99; $a} + xtal::xtal {$o.m('abc', 10)} + xtal::xtal {$o.m( + 'abci' + , + 10 + )} + set d {a 1 b 2 c 3} + xtal::xtal { d.b } + set x c + xtal::xtal {d.$x} + set a 0 ; set b 1 + xtal::xtal { < expr {$a > $b} > } + xtal::xtal { $b}>} + xtal::xtal { < + expr {$a > $b} + > } + xtal::xtal { + a = 1 ; b = 2 + < + puts [expr {$a > $b}] + > + } + xtal::xtal { + + a = b + } + + xtal::xtal { a = } + xtal::xtal { a = ; } + xtal::xtal { a = ;} + xtal::xtal { a = ; c = a} + xtal::xtal { a = < + clock seconds> ; b = a + } + + xtal::xtal { @table () } + xtal::xtal { @table () {} } + xtal::xtal { @table (i int) } + xtal::xtal { @table (i int) {{2}}} + xtal::xtal { @table (i int, s string) } + xtal::xtal { @table (i int, s string ) {{2, 'two'}, {3, 'three'}} } + xtal::xtal { @table (i + int, + s string + ) { + {2, 'two'}, + {3, 'three'} + } } + + set "variable with spaces" "value of variable with spaces" + xtal::xtal { + puts($"variable with spaces") + var = "variable with spaces" + puts($var) + } + + xtal::xtal { + function fn () {puts( "Function fn")} + function fn2 (a, b=5+6) {return a+b} + fn() + fn2( 1, 2) + fn2 (10 ) + } + fn + fn2 1 2 + fn2 10 + xtal::xtal { + try { + a = 1 + } on error {puts('error')} finally {puts('finally')} + } + + xtal::xtal { + try { + throw 'TSCRIPT', 'TEST', "Just a test" + } on error res opts { + puts(res) + puts (opts) + } finally { + puts('finally') + } + } + + xtal::xtal { + try { + nosuchvar + } trap {'TCL', 'XXX'} { + puts("Should not trigger") + } trap {'TCL', 'LOOKUP'} res opts { + + + } finally { + puts('finally') + } + } + + xtal::xtal { + Rainfall = @double { + 11.0, 23.3, 18.4, 14.7, 70.3, 180.5, 210.2, 205.8, 126.4, 64.9, 33.1, 19.2 + } + Emps = @table ( + Name string, Salary uint, Age uint, Location string + ) { + {'Sally', 70000, 32, 'Boston'}, + {'Tom', 65000, 36, 'Boston'}, + {'Dick', 80000, 40, "New York"}, + {'Harry', 45000, 37, "New York"}, + {'Amanda', 48000, 35, 'Seattle'} + } + } +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl new file mode 100644 index 00000000..7829e612 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl @@ -0,0 +1 @@ + package ifneeded TclCurl 8.15.0 "[list load [file join $dir tcl9TclCurl8150.dll] Tclcurl]; [list source [file join $dir tclcurl.tcl]]" diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll new file mode 100644 index 00000000..042e6b22 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html new file mode 100644 index 00000000..b803d528 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html @@ -0,0 +1,3151 @@ +Manpage of TclCurl + +

TclCurl

+Section: Easy inteface (3)
Updated: 03 October 2011
+  +
+

NAME

+ +TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP, +LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax. +  +

SYNOPSIS

+ +curl::init + +

+curlHandle configure ?options? + +

+curlHandle perform + +

+curlHandle getinfo curlinfo_option + +

+curlhandle cleanup + +

+curlhandle reset + +

+curlHandle duhandle + +

+curlHandle pause + +

+curlHandle resume + +

+curl::transfer ?options? + +

+curl::version + +

+curl::escape url + +

+curl::unescape url + +

+curl::curlConfig option + +

+curl::versioninfo option + +

+curl::easystrerror errorCode + +

+  +

DESCRIPTION

+ +The TclCurl extension gives Tcl programmers access to the libcurl +library written by Daniel Stenberg, with it you can download urls, +upload them and many other neat tricks. + +  +

curl::init

+ +This procedure must be the first one to call, it returns a +curlHandle + +that you need to use to invoke TclCurl procedures. The init calls intializes +curl and this call MUST have a corresponding call to +cleanup + +when the operation is completed. +You should perform all your sequential file transfers using the same +curlHandle. This enables TclCurl to use persistant connections when +possible. +

+RETURN VALUE + +

+curlHandle + +to use. +  +

curlHandle configure ?options?

+ +

+configure + +is called to set the options for the transfer. Most operations in TclCurl +have default actions, and by using the appropriate options you can +make them behave differently (as documented). All options are set with +the option followed by a parameter. +

+Notes: + +the options set with this procedure are valid for the +forthcoming data transfers that are performed when you invoke +perform + +

+The options are not reset between transfers (except where noted), so if +you want subsequent transfers with different options, you must change them +between the transfers. You can optionally reset all options back to the internal +default with curlHandle reset. +

+curlHandle + +is the return code from the +curl::init + +call. +

+

+OPTIONS + +

+  +

Behaviour options

+ +

+

+
-verbose + +
+Set the parameter to 1 to get the library to display a lot of verbose +information about its operations. Very useful for libcurl and/or protocol +debugging and understanding. +

+You hardly ever want this set in production use, you will almost always want +this when you debug/report problems. Another neat option for debugging is +-debugproc + +

+

-header + +
+A 1 tells the extension to include the headers in the body output. This is +only relevant for protocols that actually have headers preceding the data (like HTTP). +

+

-noprogress + +
+A 1 tells the extension to turn on the progress meter +completely. It will also prevent the progessproc from getting called. +

+

-nosignal + +
+A 1 tells TclCurl not use any functions that install signal +handlers or any functions that cause signals to be sent to the process. This +option is mainly here to allow multi-threaded unix applications to still +set/use all timeout options etc, without risking getting signals. +

+If this option is set and libcurl has been built with the standard name resolver, +timeouts will not occur while the name resolve takes place. Consider building +libcurl with c-ares support to enable asynchronous DNS lookups, which enables +nice timeouts for name resolves without signals. +

+Setting nosignal to 1 makes libcurl NOT ask the system to ignore +SIGPIPE signals, which otherwise are sent by the system when trying to send +data to a socket which is closed in the other end. libcurl makes an effort to +never cause such SIGPIPEs to trigger, but some operating systems have no way +to avoid them and even on those that have there are some corner cases when +they may still happen, contrary to our desire. In addition, using +ntlm_Wb authentication could cause a SIGCHLD signal to be raised. +

+

-wildcard + +
+Set this option to 1 if you want to transfer multiple files according to a +file name pattern. The pattern can be specified as part of the +-url option, using an fnmatch-like pattern (Shell Pattern +Matching) in the last part of URL (file name). +

+By default, TClCurl uses its internal wildcard matching implementation. You +can provide your own matching function by the -fnmatchproc option. +

+This feature is only supported by the FTP download for now. +

+A brief introduction of its syntax follows: +

+
+
* - ASTERISK
+ftp://example.com/some/path/*.txt (for all txt's from the root directory) +
+
+ +
+
+
? - QUESTION MARK
+Question mark matches any (exactly one) character. +

+ftp://example.com/some/path/photo?.jpeg +

+
+ +
+
+
[ - BRACKET EXPRESSION
+The left bracket opens a bracket expression. The question mark and asterisk have +no special meaning in a bracket expression. Each bracket expression ends by the +right bracket and matches exactly one character. Some examples follow: +

+[a-zA-Z0-9] or [f-gF-G] - character interval +

+[abc] - character enumeration +

+[^abc] or [!abc] - negation +

+[[:name:]] class expression. Supported classes are +alnum,lower, space, alpha, digit, print, +upper, blank, graph, xdigit. +

+[][-!^] - special case - matches only '-', ']', '[', '!' or '^'. These +characters have no special purpose. +

+[\[\]\\] - escape syntax. Matches '[', ']' or '\'. +

+Using the rules above, a file name pattern can be constructed: +

+ftp://example.com/some/path/[a-z[:upper:]\\].jpeg +

+
+ +
+

+ +

+  +

Callback options

+ +

+

+
-writeproc + +
+Use it to set a Tcl procedure that will be invoked by TclCurl as soon as +there is received data that needs to be saved. The procedure will receive +a single parameter with the data to be saved. +

+NOTE: you will be passed as much data as possible in all invokes, but you +cannot possibly make any assumptions. It may be nothing if the file is +empty or it may be thousands of bytes. +

+

-file + +
+File in which the transfered data will be saved. +

+

-readproc + +
+Sets a Tcl procedure to be called by TclCurl as soon as it needs to read +data in order to send it to the peer. The procedure has to take one +parameter, which will contain the maximun numbers of bytes to read. It +should return the actual number of bytes read, or '0' if you want to +stop the transfer. +

+If you stop the current transfer by returning 0 "pre-maturely" (i.e before +the server expected it, like when you've said you will upload N bytes and +you upload less than N bytes), you may experience that the server "hangs" +waiting for the rest of the data that won't come. +

+Bugs: when doing TFTP uploads, you must return the exact amount of data +that the callback wants, or it will be considered the final packet by the +server end and the transfer will end there. +

+

-infile + +
+File from which the data will be transfered. +

+

-progressproc + +
+Name of the Tcl procedure that will invoked by TclCurl with a frequent +interval during operation (roughly once per second or sooner), no matter if data +is being transfered or not. Unknown/unused +argument values passed to the callback will be set to zero (like if you +only download data, the upload size will remain 0), the prototype of the +procedure must be: +

+proc ProgressCallback {dltotal dlnow ultotal ulnow} + +

+In order to this option to work you have to set the noprogress +option to '0'. Setting this option to the empty string will restore the +original progress function. +

+If you transfer data with the multi interface, this procedure will not be +called during periods of idleness unless you call the appropriate procedure +that performs transfers. +

+You can pause and resume a transfer from within this procedure using the +pause and resume commands. +

+

-writeheader + +
+Pass a the file name to be used to write the header part of the received data to. +The headers are guaranteed to be written one-by-one to this file and +only complete lines are written. Parsing headers should be easy enough using +this. +

+See also the headervar option to get the headers into an array. +

+

-debugproc + +
+Name of the procedure that will receive the debug data produced by the +-verbose + +option, it should match the following prototype: +

+debugProc {infoType data} + +

+where infoType specifies what kind of information it is (0 text, +1 incoming header, 2 outgoing header, 3 incoming data, 4 outgoing data, +5 incoming SSL data, 6 outgoing SSL data). +

+

-chunkbgnproc + +
+Name of the procedure that will be called before a file will be transfered by +ftp, it should match the following prototype: +

+ChunkBgnProc {remains} + +

+

+Where remains is the number of files left to be transfered (or skipped) +

+This callback makes sense only when using the -wildcard option. +

+

-chunkbgnvar + +
+Name of the variable in the global scope that will contain the data of the file about +to be transfered. If you don't use this option '::fileData' will be used. +

+The available data is: filename, filetype (file, directory, symlink, device block, device char, +named pipe, socket, door or error if it couldn't be identified), time, perm, uid, gid, +size, hardlinks and flags. +

+

-chunkendproc + +
+Name of the procedure that will be called after a file is transfered (or skipped) +by ftp, it should match the following prototype: +

+ChunkEndProc {} + +

+It should return '0' if everyhting is fine and '1' if some error occurred. +

+

-fnmatchProc + +
+Name of the procedure that will be called instead of the internal wildcard +matching function, it should match the following prototype: +

+FnMatchProc {pattern string} + +

+Returns '0' if it matches, '1' if it doesn't. +

+

+  +

Error Options

+ +

+

+
-errorbuffer + +
+Pass a variable name where TclCurl may store human readable error +messages in. This may be more helpful than just the return code from the +command. +

+

-stderr + +
+Pass a file name as parameter. This is the stream to use internally instead +of stderr when reporting errors. +
-failonerror + +
+A 1 parameter tells the extension to fail silently if the HTTP code +returned is equal or larger than 400. The default action would be to return +the page normally, ignoring that code. +

+This method is not fail-safe and there are occasions where non-successful response +codes will slip through, especially when authentication is involved +(response codes 401 and 407). +

+You might get some amounts of headers transferred before this situation is detected, +like for when a "100-continue" is received as a response to a POST/PUT and a 401 +or 407 is received immediately afterwards. +

+

+  +

Network options

+ +

+

+
-url + +
+The actual URL to deal with. +

+If the given URL lacks the protocol part ("http://" or "ftp://" etc), it will +attempt to guess which protocol to use based on the given host name. If the +given protocol of the set URL is not supported, TclCurl will return the +unsupported protocol error when you call perform. Use +curl::versioninfo for detailed info on which protocols are supported. +

+Starting with version 7.22.0, the fragment part of the URI will not be send as +part of the path, which was the case previously. +

+NOTE: this is the one option required to be set before perform is called. +

+

-protocols + +
+Pass a list in lowecase of protocols to limit what protocols TclCurl may use in the transfer. This +allows you to have a TclCurl built to support a wide range of protocols but still limit +specific transfers to only be allowed to use a subset of them. +

+Accepted protocols are 'http', 'https', 'ftp', 'ftps', 'scp', 'sftp', 'telnet', 'ldap', + +and 'all'. +

+

-redirprotocols + +
+Pass a list in lowercase of accepted protocols to limit what protocols TclCurl may use in a transfer +that it follows to in a redirect when -followlocation is enabled. This allows you +to limit specific transfers to only be allowed to use a subset of protocols in redirections. +

+By default TclCurl will allow all protocols except for FILE and SCP. This is a difference +compared to pre-7.19.4 versions which unconditionally would follow to all protocols supported. +

+

-proxy + +
+If you need to use a http proxy to access the outside world, set the +proxy string with this option. To specify port number in this string, +append :[port] to the end of the host name. The proxy string may be +prefixed with [protocol]:// since any such prefix will be ignored. +

+When you tell the extension to use a HTTP proxy, TclCurl will +transparently convert operations to HTTP even if you specify a FTP +URL etc. This may have an impact on what other features of the library +you can use, such as +quote + +and similar FTP specifics that will not work unless you tunnel through +the HTTP proxy. Such tunneling is activated with +proxytunnel + +

+TclCurl respects the environment variables http_proxy, ftp_proxy, +all_proxy etc, if any of those are set. The use of this option does +however override any possibly set environment variables. +

+Setting the proxy string to "" (an empty string) will explicitly disable +the use of a proxy, even if there is an environment variable set for it. +

+The proxy host string can be specified the exact same way as the proxy +environment variables, include protocol prefix (http://) and embedded +user + password. +

+Since 7.22.0, the proxy string may be specified with a protocol:// prefix to +specify alternative proxy protocols. Use socks4://, socks4a://, socks5:// or +socks5h:// (the last one to enable socks5 and asking the proxy to do the resolving) +to request the specific SOCKS version +to be used. No protocol specified, http:// and all others will be treated as +HTTP proxies. +

+

-proxyport + +
+Use this option to set the proxy port to use unless it is specified in +the proxy string by -proxy. If not specified, TclCurl will default +-to using port 1080 for proxies. +

+

-proxytype + +
+Pass the type of the proxy. Available options are 'http', 'http1.0', 'socks4', 'socks4a', +
man2html: unable to open or read file + +
+ +

+If you set it to http1.0, it will only affect how libcurl speaks to a proxy +when CONNECT is used. The HTTP version used for "regular" HTTP requests is instead +controled with httpversion. +

+

-noproxy + +
+Pass a string, a comma-separated list of hosts which do not use a proxy, if one +is specified. The only wildcard is a single * character, which matches all hosts, +and effectively disables the proxy. Each name in this list is matched as either +a domain which contains the hostname, or the hostname itself. For example, local.com +would match local.com, local.com:80, and www.local.com, but not http://www.notlocal.com. +

+

-httpproxytunnel + +
+Set the parameter to 1 to get the extension to tunnel all non-HTTP +operations through the given HTTP proxy. Do note that there is a big +difference between using a proxy and tunneling through it. If you don't know what +this means, you probably don't want this tunnel option. +

+

-socks5gssapiservice + +
+Pass thee name of the service. The default service name for a SOCKS5 server is +rcmd/server-fqdn. This option allows you to change it. +

+

-socks5gssapinec + +
+Pass a 1 to enable or 0 to disable. As part of the gssapi negotiation a protection +mode is negotiated. The rfc1961 says in section 4.3/4.4 it should be protected, but +the NEC reference implementation does not. If enabled, this option allows the +unprotected exchange of the protection mode negotiation. +

+

-interface + +
+Pass the interface name to use as outgoing +network interface. The name can be an interface name, an IP address or a host +name. +

+

-localport + +
+This sets the local port number of the socket used for connection. This can +be used in combination with -interface and you are recommended to use +localportrange as well when this is set. Valid port numbers +are 1 - 65535. +

+

-localportrange + +
+This is the number of attempts TclCurl should do to find a working local port +number. It starts with the given -localport and adds +one to the number for each retry. Setting this value to 1 or below will make +TclCurl do only one try for each port number. Port numbers by nature +are a scarce resource that will be busy at times so setting this value to something +too low might cause unnecessary connection setup failures. +

+

-dnscachetimeout + +
+Pass the timeout in seconds. Name resolves will be kept in memory for this number +of seconds. Set to '0' to completely disable caching, or '-1' to make the +cached entries remain forever. By default, TclCurl caches this info for 60 seconds. +

+The name resolve functions of various libc implementations don't re-read name +server information unless explicitly told so (for example, by calling +
 res_init(3)). This may cause TclCurl to keep using the older server even +if DHCP has updated the server info, and this may look like a DNS cache issue. +

+

-dnsuseglobalcache + +
+If the value passed is 1, it tells TclCurl to use a global DNS cache that +will survive between curl handles creations and deletions. This is not thread-safe +as it uses a global varible. +

+WARNING: this option is considered obsolete. Stop using it. Switch over +to using the share interface instead! See tclcurl_share. +

+

-buffersize + +
+Pass your prefered size for the receive buffer in TclCurl. The main point of this +would be that the write callback gets called more often and with smaller chunks. +This is just treated as a request, not an order. You cannot be guaranteed to +actually get the given size. +

+

-port + +
+

+Pass the number specifying what remote port to connect to, instead of the one specified +in the URL or the default port for the used protocol. +

+

-tcpnodelay + +
+

+Pass a number to specify whether the TCP_NODELAY option should be set or cleared (1 = set, 0 = clear). +The option is cleared by default. This will have no effect after the connection has been established. +

+Setting this option will disable TCP's Nagle algorithm. The purpose of this algorithm is to try to +minimize the number of small packets on the network (where "small packets" means TCP segments less +than the Maximum Segment Size (MSS) for the network). +

+Maximizing the amount of data sent per TCP segment is good because it amortizes the overhead of the +send. However, in some cases (most notably telnet or rlogin) small segments may need to be sent without +delay. This is less efficient than sending larger amounts of data at a time, and can contribute to +congestion on the network if overdone. +

+

-addressscope + +
+Pass a number specifying the scope_id value to use when connecting to IPv6 link-local or site-local +addresses. +

+

+  +

Names and Passwords options

+ +

+

+
-netrc + +
+A 1 parameter tells the extension to scan your +~/.netrc + +file to find user name and password for the remote site you are about to +access. Do note that TclCurl does not verify that the file has the correct +properties set (as the standard unix ftp client does), and that only machine +name, user name and password is taken into account (init macros and similar +things are not supported). +

+You can set it to the following values: +

+
+
optional + +
+The use of your ~/.netrc file is optional, and information in the URL is to +be preferred. The file will be scanned with the host and user name (to find +the password only) or with the host only, to find the first user name and +password after that machine, which ever information is not specified in +the URL. +

+Undefined values of the option will have this effect. +

ignored + +
+The extension will ignore the file and use only the information in the URL. +This is the default. +
required + +
+This value tells the library that use of the file is required, to ignore +the information in the URL, and to search the file with the host only. +
+
+ +

+

-netrcfile + +
+Pass a string containing the full path name to the file you want to use as .netrc +file. For the option to work, you have to set the netrc option to +required. If this option is omitted, and netrc is set, TclCurl +will attempt to find the a .netrc file in the current user's home directory. +

+

-userpwd + +
+Pass a string as parameter, which should be [username]:[password] to use for +the connection. Use -httpauth to decide authentication method. +

+When using NTLM, you can set domain by prepending it to the user name and +separating the domain and name with a forward (/) or backward slash (\). Like +this: "domain/user:password" or "domain\user:password". Some HTTP servers (on +Windows) support this style even for Basic authentication. +

+When using HTTP and -followlocation, TclCurl might perform several +requests to possibly different hosts. TclCurl will only send this user and +password information to hosts using the initial host name (unless +-unrestrictedauth is set), so if TclCurl follows locations to other +hosts it will not send the user and password to those. This is enforced to +prevent accidental information leakage. +

+

-proxyuserpwd + +
+Pass a string as parameter, which should be [username]:[password] to use for +the connection to the HTTP proxy. +

+

-username + +
+Pass a string with the user name to use for the transfer. It sets the user name +to be used in protocol authentication. You should not use this option together +with the (older) -userpwd option. +

+In order to specify the password to be used in conjunction with the user name +use the -password option. +

+

-password + +
+Pass a string with the password to use for the transfer. +

+It should be used in conjunction with the -username option. +

+

-proxyusername + +
+Pass a string with the user name to use for the transfer while connecting to Proxy. +

+It should be used in same way as the -proxyuserpwd is used, except that it +allows the username to contain a colon, like in the following example: +"sip:user@example.com". +

+Note the -proxyusername option is an alternative way to set the user name +while connecting to Proxy. It doesn't make sense to use them together. +

+

-proxypassword + +
+Pass a string with the password to use for the transfer while connecting to Proxy. It +is meant to use together with -proxyusername. +

+

-httpauth + +
+Set to the authentication method you want, the available ones are: +
+
+
basic + +
+HTTP Basic authentication. This is the default choice, and the only +method that is in widespread use and supported virtually everywhere. +It sends the user name and password over the network in plain text, +easily captured by others. +

+

digest + +
+HTTP Digest authentication. Digest authentication is a more secure +way to do authentication over public networks than the regular +old-fashioned Basic method. +

+

digestie + +
+HTTP Digest authentication with an IE flavor. TclCurl will use a special +"quirk" that IE is known to have used before version 7 and that some +servers require the client to use. +

+

gssnegotiate + +
+HTTP GSS-Negotiate authentication. The GSS-Negotiate method, also known as +plain "Negotiate",was designed by Microsoft and is used in their web +applications. It is primarily meant as a support for Kerberos5 authentication +but may be also used along with another authentication methods. +

+

ntlm + +
+HTTP NTLM authentication. A proprietary protocol invented and used by Microsoft. +It uses a challenge-response and hash concept similar to Digest, to prevent the +password from being eavesdropped. +

+

ntlmwb + +
+NTLM delegating to winbind helper. Authentication is performed by a separate +binary application that is executed when needed. The name of the application is +specified at libcurl's compile time but is typically /usr/bin/ntlm_auth. +

+Note that libcurl will fork when necessary to run the winbind application and kill +it when complete, calling waitpid() to await its exit when done. On POSIX operating +systems, killing the process will cause a SIGCHLD signal to be raised +(regardless of whether -nosignal is set). This behavior is subject to change +in future versions of libcurl. +

+

any + +
+TclCurl will automatically select the one it finds most secure. +

+

anysafe + +
+It may use anything but basic, TclCurl will automaticly select the +one it finds most secure. +
+
+ +

+

Use it to tell TclCurl which authentication method(s) you want it to use for TLS authentication.
+
+
+
tlsauthsrp + +
+
+TLS-SRP authentication. Secure Remote Password authentication for TLS is +defined in RFC 5054 and provides mutual authentication if both sides have a +shared secret. To use TLS-SRP, you must also set the +-tlsauthusername and -tlsauthpassword options. +

+You need to build libcurl with GnuTLS or OpenSSL with TLS-SRP support for this +to work. +

+
+ +

+

-tlsauthusername + +
+Pass a string with the username to use for the TLS authentication method specified +with the -tlsauthtype option. Requires that the -tlsauthpassword option +also be set. +

+

-tlsauthpassword + +
+Pass a string with the password to use for the TLS authentication method specified +with the -tlsauthtype option. Requires that the -tlsauthusername option +also be set. +

+

-proxyauth + +
+Use it to tell TclCurl which authentication method(s) you want it to use for +your proxy authentication. Note that for some methods, this will induce an +extra network round-trip. Set the actual name and password with the +proxyuserpwd option. +

+The methods are those listed above for the httpauth option. As of this +writing, only Basic and NTLM work. +

+

+  +

HTTP options

+ +

+

+
-autoreferer + +
+Pass an 1 parameter to enable this. When enabled, TclCurl will +automatically set the Referer: field in requests where it follows a Location: +redirect. +

+

-encoding + +
+Sets the contents of the Accept-Encoding: header sent in an HTTP +request, and enables decoding of a response when a Content-Encoding: +header is received. Three encodings are supported: identity, +which does nothing, deflate which requests the server to +compress its response using the zlib algorithm, and gzip which +requests the gzip algorithm. Use all to send an +Accept-Encoding: header containing all supported encodings. +

+This is a request, not an order; the server may or may not do it. This +option must be set or else any unsolicited +encoding done by the server is ignored. See the special file +lib/README.encoding in libcurl docs for details. +

+

-transferencoding + +
+Adds a request for compressed Transfer Encoding in the outgoing HTTP +request. If the server supports this and so desires, it can respond with the +HTTP resonse sent using a compressed Transfer-Encoding that will be +automatically uncompressed by TclCurl on receival. +

+Transfer-Encoding differs slightly from the Content-Encoding you ask for with +-encoding in that a Transfer-Encoding is strictly meant to +be for the transfer and thus MUST be decoded before the data arrives in the +client. Traditionally, Transfer-Encoding has been much less used and supported +by both HTTP clients and HTTP servers. +

+

-followlocation + +
+An 1 tells the library to follow any +Location: header + +that the server sends as part of a HTTP header. +

+This means that the extension will re-send the same request on the new location +and follow new Location: headers all the way until no more such headers are +returned. -maxredirs can be used to limit the number of redirects +TclCurl will follow. +

+Since 7.19.4, TclCurl can limit what protocols it will automatically follow. +The accepted protocols are set with -redirprotocols and it excludes the FILE +protocol by default. +

+

-unrestrictedauth + +
+An 1 parameter tells the extension it can continue +to send authentication (user+password) when following +locations, even when hostname changed. Note that this +is meaningful only when setting -followlocation. +

+

-maxredirs + +
+Sets the redirection limit. If that many redirections have been followed, +the next redirect will cause an error. This option only makes sense if the +-followlocation option is used at the same time. Setting the limit +to 0 will make libcurl refuse any redirect. Set it to -1 for an infinite +number of redirects (which is the default) +

+

-post301 + +
+Controls how TclCurl acts on redirects after POSTs that get a 301 or 302 response back. +A "301" as parameter tells the TclCurl to respect RFC 2616/10.3.2 and not convert POST +requests into GET requests when following a 301 redirection. Passing a "302" makes +TclCurl maintain the request method after a 302 redirect. "all" is a convenience string +that activates both behaviours. +

+The non-RFC behaviour is ubiquitous in web browsers, so the extension does the conversion +by default to maintain consistency. However, a server may require a POST to remain a POST +after such a redirection. +

+This option is meaningful only when setting -followlocation +

+ +

-put + +
+An 1 parameter tells the extension to use HTTP PUT a file. The file to put +must be set with -infile and -infilesize. +

+This option is deprecated starting with version 0.12.1, you should use -upload. +

+This option does not limit how much data TclCurl will actually send, as that is +controlled entirely by what the read callback returns. +

+

-post + +
+An 1 parameter tells the library to do a regular HTTP post. This is a +normal application/x-www-form-urlencoded kind, which is the most commonly used +one by HTML forms. See the -postfields option for how to specify the +data to post and -postfieldsize about how to set the data size. +

+Use the -postfields option to specify what data to post and -postfieldsize +to set the data size. Optionally, you can provide data to POST using the -readproc +options. +

+You can override the default POST Content-Type: header by setting your own with +-httpheader. +

+Using POST with HTTP 1.1 implies the use of a "Expect: 100-continue" header. +You can disable this header with -httpheader as usual. +

+If you use POST to a HTTP 1.1 server, you can send data without knowing the +size before starting the POST if you use chunked encoding. You enable this +by adding a header like "Transfer-Encoding: chunked" with -httpheader. +With HTTP 1.0 or without chunked transfer, you must specify the size in the +request. +

+When setting post to an 1 value, it will automatically set +nobody to 0. +

+NOTE: if you have issued a POST request and want to make a HEAD or GET instead, you must +explicitly pick the new request type using -nobody or -httpget or similar. +

+

-postfields + +
+Pass a string as parameter, which should be the full data to post in a HTTP +POST operation. You must make sure that the data is formatted the way you +want the server to receive it. TclCurl will not convert or encode it for you. +Most web servers will assume this data to be url-encoded. +

+This is a normal application/x-www-form-urlencoded kind, +which is the most commonly used one by HTML forms. +

+If you want to do a zero-byte POST, you need to set +-postfieldsize explicitly to zero, as simply setting +-postfields to NULL or "" just effectively disables the sending +of the specified string. TclCurl will instead assume that the POST +data will be send using the read callback! +

+Using POST with HTTP 1.1 implies the use of a "Expect: 100-continue" header. +You can disable this header with -httpheader as usual. +

+Note: to make multipart/formdata posts (aka rfc1867-posts), check out +-httppost option. +

+

-postfieldsize + +
+If you want to post data to the server without letting TclCurl do a strlen() +to measure the data size, this option must be used. Also, when this option is +used, you can post fully binary data which otherwise is likely to fail. If +this size is set to zero, the library will use strlen() to get the data +size. +

+

-httppost + +
+Tells TclCurl you want a multipart/formdata HTTP POST to be made and you +instruct what data to pass on to the server through a +Tcl list. + +

+This is the only case where the data is reset after a transfer. +

+First, there are some basics you need to understand about multipart/formdata +posts. Each part consists of at least a NAME and a CONTENTS part. If the part +is made for file upload, there are also a stored CONTENT-TYPE and a +FILENAME. Below, we'll discuss on what options you use to set these +properties in the parts you want to add to your post. +

+The list must contain a 'name' tag with the name of the section followed +by a string with the name, there are three tags to indicate the value of +the section: 'value' followed by a string with the data to post, 'file' +followed by the name of the file to post and 'contenttype' with the +type of the data (text/plain, image/jpg, ...), you can also indicate a false +file name with 'filename', this is useful in case the server checks if the given +file name is valid, for example, by testing if it starts with 'c:\' as any real file +name does or if you want to include the full path of the file to post. You can also post +the content of a variable as if it were a file with the options 'bufferName' and +'buffer' or use 'filecontent' followed by a file name to read that file and +use the contents as data. +

+Should you need to specify extra headers for the form POST section, use +'contentheader' followed by a list with the headers to post. +

+Please see 'httpPost.tcl' and 'httpBufferPost.tcl' for examples. +

+If TclCurl can't set the data to post an error will be returned: +

+
+
1 + +
+If the memory allocation fails. +
2 + +
+If one option is given twice for one form. +
3 + +
+If an empty string was given. +
4 + +
+If an unknown option was used. +
5 + +
+If the some form info is not complete (or error) +
6 + +
+If an illegal option is used in an array. +
7 + +
+TclCurl has no http support. +
+
+ +

+

-referer + +
+Pass a string as parameter. It will be used to set the +referer + +header in the http request sent to the remote server. This can be used to +fool servers or scripts. You can also set any custom header with +-httpheader. + +

+

-useragent + +
+Pass a string as parameter. It will be used to set the +user-agent: + +header in the http request sent to the remote server. This can be used to fool +servers or scripts. You can also set any custom header with +-httpheader. + +

+

-httpheader + +
+Pass a +list + +with the HTTP headers to pass to the server in your request. +If you add a header that is otherwise generated +and used by TclCurl internally, your added one will be used instead. If you +add a header with no contents as in 'Accept:', the internally used header will +just get disabled. Thus, using this option you can add new headers, replace +and remove internal headers. +

+The headers included in the linked list must not be CRLF-terminated, because +TclCurl adds CRLF after each header item. Failure to comply with this will +result in strange bugs because the server will most likely ignore part of the +headers you specified. +

+The first line in a request (containing the method, usually a GET or POST) is +not a header and cannot be replaced using this option. Only the lines +following the request-line are headers. Adding this method line in this list +of headers will only cause your request to send an invalid header. +

+NOTE:The most commonly replaced headers have "shortcuts" in the options: +cookie, useragent, + +and +referer. + +

+

-http200aliases + +
+Pass a list of aliases to be treated as valid HTTP 200 responses. Some servers +respond with a custom header response line. For example, IceCast servers respond +with "ICY 200 OK". By including this string in your list of aliases, the +response will be treated as a valid HTTP header line such as "HTTP/1.0 200 OK". +

+NOTE:The alias itself is not parsed for any version strings. Before version +7.16.3, TclCurl used the value set by option httpversion, but starting with +7.16.3 the protocol is assumed to match HTTP 1.0 when an alias matched. +

+

-cookie + +
+Pass a string as parameter. It will be used to +set a cookie in the http request. The format of the string should be + +what the cookie should contain. +

+If you need to set mulitple cookies, you need to set them all using +a single option and thus you need to concatenate them all in one single string. +Set multiple cookies in one string like this: "name1=content1; name2=content2;" +etc. +

+This option sets the cookie header explictly in the outgoing request(s). +If multiple requests are done due to authentication, followed redirections or similar, +they will all get this cookie passed on. +

+Using this option multiple times will only make the latest string override +the previous ones. +

+

-cookiefile + +
+Pass a string as parameter. It should contain the name of your file holding +cookie data. The cookie data may be in netscape cookie data format or just +regular HTTP-style headers dumped to a file. +

+Given an empty or non-existing file, this option will enable cookies for this +curl handle, making it understand and parse received cookies and then use +matching cookies in future requests. +

+If you use this option multiple times, you add more files to read. +

+

-cookiejar + +
+Pass a file name in which TclCurl will dump all internally known cookies +when +curlHandle cleanup + +is called. If no cookies are known, no file will be created. +Specify "-" to have the cookies written to stdout. +

+Using this option also enables cookies for this session, so if you, for +example, follow a location it will make matching cookies get sent accordingly. +

+TclCurl will not and cannot report an error for this. Using 'verbose' +will get a warning to display, but that is the only visible feedback you get +about this possibly lethal situation. +

+

-cookiesession + +
+Pass an 1 to mark this as a new cookie "session". It will +force TclCurl to ignore all cookies it is about to load that are "session +cookies" from the previous session. By default, TclCurl always stores and +loads all cookies, independent of whether they are session cookies are not. +Session cookies are cookies without expiry date and they are meant to be +alive and existing for this "session" only. +

+

-cookielist + +
+Pass a string with a cookie. The cookie can be either in Netscape / Mozilla +format or just regular HTTP-style header (Set-Cookie: ...) format. If the +cookie engine was not enabled it will be enabled. Passing a +magic string "ALL" will erase all known cookies while "FLUSH" will write +all cookies known by TclCurl to the file specified by -cookiejar. +

+

-httpget + +
+If set to 1 forces the HTTP request to get back to GET, usable if +POST, PUT or a custom request have been used previously with the +same handle. +

+When setting httpget to 1, nobody will automatically be set to 0. +

+

-httpversion + +
+Set to one of the values decribed below, they force TclCurl to use the +specific http versions. It should only be used if you really MUST do +that because of a silly remote server. +
+
+
none + +
+We do not care about what version the library uses. TclCurl will use whatever +it thinks fit. +
1.0 + +
+Enforce HTTP 1.0 requests. +
1.1 + +
+Enforce HTTP 1.1 requests. +
2.0 + +
+Enforce HTTP version 2 requests. +
2TLS + +
+Enforce version 2 requests for HTTPS, version 1.1 for HTTP. +
2_PRIOR_KNOWLEDGE + +
+Enforce HTTP 2 requests without performing HTTP/1.1 Upgrade first. +
+
+ +

+

-ignorecontentlength + +
+Ignore the Content-Length header. This is useful for Apache 1.x (and similar +servers) which will report incorrect content length for files over 2 +gigabytes. If this option is used, TclCurl will not be able to accurately +report progress, and will simply stop the download when the server ends the +connection. +

+

-httpcontentdecoding + +
+Set to zero to disable content decoding. If set to 1 it is enabled. Note however +that TclCurl has no default content decoding but requires you to use encoding for that. +

+

-httptransferencoding + +
+Set to zero to disable transfer decoding, if set to 1 it is enabled (default). TclCurl does +chunked transfer decoding by default unless this option is set to zero. +

+

+  +

SMTP options

+ +

+

+
-mailfrom + +
+Pass a string to specify the sender address in a mail when sending an SMTP mail with TclCurl. +

+

-mailrcpt + +
+Pass a list of recipients to pass to the server in your SMTP mail request. +

+Each recipient in SMTP lingo is specified with angle brackets (<>), but should you not use an +angle bracket as first letter, TclCurl will assume you provide a single email address only and +enclose that with angle brackets for you. +

+

+  +

TFTP option

+ +

+

+
tftpblksize + +
+

+Specify the block size to use for TFTP data transmission. Valid range as per RFC 2348 is 8-65464 bytes. +The default of 512 bytes will be used if this option is not specified. The specified block size will +only be used pending support by the remote server. If the server does not return an option acknowledgement +or returns an option acknowledgement with no blksize, the default of 512 bytes will be used. +

+

+  +

FTP options

+ +

+

+
-ftpport + +
+Pass a string as parameter. It will be used to +get the IP address to use for the ftp PORT instruction. The PORT instruction +tells the remote server to connect to our specified IP address. The string may +be a plain IP address, a host name, a network interface name (under unix) or +just a '-' to let the library use your systems default IP address. Default FTP +operations are passive, and thus will not use PORT. +

+The address can be followed by a ':' to specify a port, optionally followed by a '-' +o specify a port range. If the port specified is 0, the operating system will pick +a free port. If a range is provided and all ports in the range are not available, +libcurl will report CURLE_FTP_PORT_FAILED for the handle. Invalid port/range settings +are ignored. IPv6 addresses followed by a port or portrange have to be in brackets. +IPv6 addresses without port/range specifier can be in brackets. +

+Examples with specified ports: +

+
  eth0:0   192.168.1.2:32000-33000   curl.se:32123   [::1]:1234-4567 +

+You disable PORT again and go back to using the passive version by setting this option to +an empty string. +

+

-quote + +
+Pass a list list with the FTP or SFTP commands to pass to the server prior to your +ftp request. This will be done before any other FTP commands are issued (even +before the CWD command).If you do not want to transfer any files, set +nobody to '1' and header to '0'. +

+Prefix the command with an asterisk (*) to make TclCurl continue even if the command +fails as by default TclCurl will stop. +

+Disable this operation again by setting an empty string to this option. +

+Keep in mind the commands to send must be 'raw' ftp commands, for example, to +create a directory you need to send mkd Test, not mkdir Test. +

+Valid SFTP commands are: chgrp, chmod, chown, ln, mkdir, pwd, rename, rm, +rmdir and symlink. +

+

-postquote + +
+Pass a list with the FTP commands to pass to the server after your +ftp transfer request. If you do not want to transfer any files, set +nobody to '1' and header to '0'. +

+

-prequote + +
+Pass a list of FTP or SFTP commands to pass to the server after the +transfer type is set. +

+

-dirlistonly + +
+A 1 tells the library to just list the names of files in a +directory, instead of doing a full directory listing that would include file +sizes, dates etc. It works with both FTP and SFTP urls. +

+This causes an FTP NLST command to be sent. Beware that some FTP servers list +only files in their response to NLST, they might not include subdirectories +and symbolic links. +

+Setting this option to 1 also implies a directory listing even if the URL +doesn't end with a slash, which otherwise is necessary. +

+Do NOT use this option if you also use -wildcardmatch as it will +effectively break that feature. +

+

-append + +
+A 1 parameter tells the extension to append to the remote file instead of +overwriting it. This is only useful when uploading to a ftp site. +

+

-ftpusepret + +
+Set to 1 to tell TclCurl to use the EPRT (and LPRT) command when doing +active FTP downloads (which is enabled by 'ftpport'). Using EPRT means +that it will first attempt to use EPRT and then LPRT before using PORT, if +you pass zero to this option, it will not try using EPRT or LPRT, only plain PORT. +

+

-ftpuseepvs + +
+Set to one to tell TclCurl to use the EPSV command when doing passive FTP +downloads (which it always does by default). Using EPSV means that it will +first attempt to use EPSV before using PASV, but if you pass a zero to this +option, it will not try using EPSV, only plain PASV. +

+

-ftpusepret + +
+

+Set to one to tell TclCurl to send a PRET command before PASV (and EPSV). Certain +FTP servers, mainly drftpd, require this non-standard command for directory listings +as well as up and downloads in PASV mode. Has no effect when using the active FTP +transfers mode. +

+

-ftpcreatemissingdirs + +
+If set to 1, TclCurl will attempt to create any remote directory that it +fails to CWD into. CWD is the command that changes working directory. +

+This setting also applies to SFTP-connections. TclCurl will attempt to create +the remote directory if it can't obtain a handle to the target-location. The +creation will fail if a file of the same name as the directory to create +already exists or lack of permissions prevents creation. +

+If set to 2, TclCurl will retry the CWD command again if the subsequent MKD +command fails. This is especially useful if you're doing many simultanoeus +connections against the same server and they all have this option enabled, +as then CWD may first fail but then another connection does MKD before this +connection and thus MKD fails but trying CWD works +

+

-ftpresponsetimeout + +
+Causes TclCurl to set a timeout period (in seconds) on the amount of time that +the server is allowed to take in order to generate a response message for a +command before the session is considered hung. Note that while TclCurl is waiting +for a response, this value overrides timeout. It is recommended that if used +in conjunction with timeout, you set it to a value smaller than timeout. +

+

-ftpalternativetouser + +
+Pass a string which will be used to authenticate if the usual FTP "USER user" and +"PASS password" negotiation fails. This is currently only known to be required when +connecting to Tumbleweed's Secure Transport FTPS server using client certificates for +authentication. +

+

-ftpskippasvip + +
+If set to 1, it instructs TclCurl not to use the IP address the +server suggests in its 227-response to TclCurl's PASV command when TclCurl +connects the data connection. Instead TclCurl will re-use the same IP address +it already uses for the control connection. But it will use the port number +from the 227-response. +

+This option has no effect if PORT, EPRT or EPSV is used instead of PASV. +

+

-ftpsslauth + +
+

+Pass TclCurl one of the values from below, to alter how TclCurl issues +"AUTH TLS" or "AUTH SSL" when FTP over SSL is activated (see -ftpssl). +

+You may need this option because of servers like BSDFTPD-SSL +which won't work properly when "AUTH SSL" is issued +(although the server responds fine and everything) but requires "AUTH TLS" +instead. +

+

+
+
default + +
+Allows TclCurl to decide. +
ssl + +
+Try "AUTH SSL" first, and only if that fails try "AUTH TLS". +
tls + +
+Try "AUTH TLS" first, and only if that fails try "AUTH SSL". +
+
+ +

+

-ftpsslccc + +
+Set it to make TclCurl use CCC (Clear Command Channel). It shuts down the +SSL/TLS layer after authenticating. The rest of the control channel +communication will be unencrypted. This allows NAT routers to follow the +FTP transaction. Possible values are: +

+

+
+
none + +
+Do not attempt to use CCC. +
passive + +
+Do not initiate the shutdown, wait for the server to do it. Do not send a reply. +
active + +
+Initiate the shutdown and wait for a reply. +
+
+ +

+

-ftpaccount + +
+Pass string (or "" to disable). When an FTP server asks for "account data" after +user name and password has been provided, this data is sent off using the ACCT +command. +

+

-ftpfilemethod + +
+It allows three values: +
+
+
multicwd + +
+The default, TclCurl will do a single CWD operation for each path part in the given +URL. For deep hierarchies this means very many commands. This is how RFC1738 says it +should be done. +
nocwd + +
+No CWD at all is done, TclCurl will do SIZE, RETR, STOR, etc and give a full path to +the server. +
singlecwd + +
+Make one CWD with the full target directory and then operate on the file "normally". +This is somewhat more standards compliant than 'nocwd' but without the full penalty of 'multicwd'. +
+
+ +

+

+  +

Protocol options

+ +

+

+
-transfertext + +
+A 1 tells the extension to use ASCII mode for ftp transfers, +instead of the default binary transfer. For win32 systems it does not set the +stdout to binary mode. This option can be usable when transferring text data +between systems with different views on certain characters, such as newlines +or similar. +

+NOTE: TclCurl does not do a complete ASCII conversion when doing ASCII +transfers over FTP. This is a known limitation/flaw that nobody has +rectified. TclCurl simply sets the mode to ascii and performs a standard +transfer. +

+

-proxytransfermode + +
+If set to 1, TclCurl sets the transfer mode (binary or ASCII) for FTP transfers +done via an HTTP proxy, by appending ;type=a or ;type=i to the URL. +Without this setting, or it being set to 0, the default, -transfertext has +no effect when doing FTP via a proxy. Beware that not all proxies support this feature. +

+

-crlf + +
+If set to '1', TclCurl converts Unix newlines to CRLF newlines on transfers. Disable +this option again by setting the value to '0'. +

+

-range + +
+Pass a string as parameter, which should contain the specified range you +want. It should be in the format +X-Y + +, where X or Y may be left out. HTTP +transfers also support several intervals, separated with commas as in +X-Y,N-M + +Using this kind of multiple intervals will cause the HTTP server to send the +response document in pieces (using standard MIME separation techniques). +

+Ranges only work on HTTP, FTP and FILE transfers. +

+

-resumefrom + +
+Pass the offset in number of bytes that you want the transfer to start from. +Set this option to 0 to make the transfer start from the beginning +(effectively disabling resume). +

+For FTP, set this option to -1 to make the transfer start from the end of the +target file (useful to continue an interrupted upload). +

+When doing uploads with FTP, the resume position is where in the local/source +file TclCurl should try to resume the upload from and it will then append the +source file to the remote target file. +

+

-customrequest + +
+Pass a string as parameter. It will be used instead of GET or HEAD when doing +the HTTP request. This is useful for doing DELETE or other more obscure HTTP +requests. Do not do this at will, make sure your server supports the command first. +

+Note that TclCurl will still act and assume the keyword it would use if you +do not set your custom and it will act according to that. Thus, changing this +to a HEAD when TclCurl otherwise would do a GET might cause TclCurl to act funny, +and similar. To switch to a proper HEAD, use -nobody, to switch to a proper +POST, use -post or -postfields and so on. +

+

-filetime + +
+If you pass a 1, TclCurl will attempt to get the +modification date of the remote document in this operation. This requires that +the remote server sends the time or replies to a time querying command. The +getinfo procedure with the +filetime + +argument can be used after a transfer to extract the received time (if any). +

+

-nobody + +
+A 1 tells the library not to include the body-part in the +output. This is only relevant for protocols that have a separate header and +body part. On HTTP(S) servers, this will make TclCurl do a HEAD request. +

+To change request to GET, you should use httpget. Change request +to POST with post etc. +

+

-infilesize + +
+When uploading a file to a remote site, this option should be used to tell +TclCurl what the expected size of the infile is. +

+This option is mandatory for uploading using SCP. +

+

-upload + +
+A 1 tells the library to prepare for an upload. The +-infile and -infilesize options are also interesting for uploads. +If the protocol is HTTP, uploading means using the PUT request unless you tell +TclCurl otherwise. +

+Using PUT with HTTP 1.1 implies the use of a "Expect: 100-continue" header. +You can disable this header with -httpheader as usual. +

+If you use PUT to a HTTP 1.1 server, you can upload data without knowing the +size before starting the transfer if you use chunked encoding. You enable this +by adding a header like "Transfer-Encoding: chunked" with -httpheader. +With HTTP 1.0 or without chunked transfer, you must specify the size. +

+

-maxfilesize + +
+This allows you to specify the maximum size (in bytes) of a file to download. +If the file requested is larger than this value, the transfer will not start +and error 'filesize exceeded' (63) will be returned. +

+NOTE: The file size is not always known prior to download, and for such files +this option has no effect even if the file transfer ends up being larger than +this given limit. This concerns both FTP and HTTP transfers. +

+

-timecondition + +
+This defines how the timevalue value is treated. You can set this +parameter to ifmodsince or ifunmodsince. This feature applies to +HTTP, FTP and FILE. +

+

-timevalue + +
+This should be the time in seconds since 1 jan 1970, and the time will be +used in a condition as specified with timecondition. +

+

+

+  +

Connection options

+ +

+

+
-timeout + +
+Pass the maximum time in seconds that you allow +the TclCurl transfer operation to take. Do note that normally, name lookups +may take a considerable time and that limiting the operation to less than a +few minutes risks aborting perfectly normal operations. This option will +cause libcurl to use the SIGALRM to enable time-outing system calls. +

+In unix-like systems, this might cause signals to be used unless +-nosignal is used. +

+

-timeoutms + +
+Like timeout but takes a number of milliseconds instead. If libcurl is +built to use the standard system name resolver, that part will still use +full-second resolution for timeouts. +

+

-lowspeedlimit + +
+Pass the speed in bytes per second that the transfer should be below during +lowspeedtime + +seconds for the extension to consider it too slow and abort. +

+

-lowspeedtime + +
+Pass the time in seconds that the transfer should be below the +lowspeedlimit + +for the extension to consider it too slow and abort. +

+

-maxsendspeed + +
+Pass a speed in bytes per seconds. If an upload exceeds this speed on cumulative +average during the transfer, the transfer will pause to keep the average rate less +than or equal to the parameter value. Defaults to unlimited speed. +

+

-maxrecvspeed + +
+Pass a speed in bytes per second. If a download exceeds this speed on cumulative +average during the transfer, the transfer will pause to keep the average rate less +than or equal to the parameter value. Defaults to unlimited speed. +

+

-maxconnects + +
+Sets the persistant connection cache size in all the protocols that support +persistent conecctions. The set amount will be the maximum amount of simultaneous +connections that TclCurl may cache in this easy handle. Default is 5, and there +isn't much point in changing this value unless you are perfectly aware of how this +work and changes TclCurl's behaviour. +

+When reaching the maximum limit, TclCurl closes the oldest connection in the cache +to prevent the number of open connections to increase. +

+Note: if you have already performed transfers with this curl handle, +setting a smaller +maxconnects + +than before may cause open connections to unnecessarily get closed. +

+If you add this easy handle to a multi handle, this setting is not +being acknowledged, instead you must configure the multi handle its own +maxconnects option. +

+

-connecttimeout + +
+Maximum time in seconds that you allow the +connection to the server to take. This only limits the connection phase, once +it has connected, this option is of no more use. Set to zero to disable +connection timeout (it will then only timeout on the internal timeouts). +

+In unix-like systems, this might cause signals to be used unless +-nosignal is set. +

+

-connecttimeoutms + +
+Like connecttimeout but takes a number of milliseconds instead. If libcurl +is built to use the standard system name resolver, that part will still use +full-second resolution for timeouts. +

+

-ipresolve + +
+Allows an application to select what kind of IP addresses to use when +resolving host names. This is only interesting when using host names +that resolve addresses using more than one version of IP. The allowed +values are: +
+
+
whatever + +
+Default, resolves addresses to all IP versions that your system allows. +
v4 + +
+Resolve to ipv4 addresses. +
v6 + +
+Resolve to ipv6 addresses. +
+
+ +

+

-resolve + +
+Pass a list of strings with host name resolve information to use for requests with +this handle. +

+Each single name resolve string should be written using the format +HOST:PORT:ADDRESS where HOST is the name TclCurl will try to resolve, PORT is +the port number of the service where TclCurl wants to connect to the HOST and +ADDRESS is the numerical IP address. If libcurl is built to support IPv6, +ADDRESS can be either IPv4 or IPv6 style addressing. +

+This option effectively pre-populates the DNS cache with entries for the +host+port pair so redirects and everything that operations against the +HOST+PORT will instead use your provided ADDRESS. +

+You can remove names from the DNS cache again, to stop providing these fake +resolves, by including a string in the linked list that uses the format +"-HOST:PORT". The host name must be prefixed with a dash, and the host name +and port number must exactly match what was already added previously. +

+

-usessl + +
+Pass a one of the values from below to make TclCurl use your desired level of SSL for the transfer. +This is for enabling SSL/TLS when you use FTP, SMTP, POP3, IMAP etc. +

+You can use ftps:// URLs to explicitly switch on SSL/TSL for the control +connection and the data connection. +

+Alternatively you can set the option to one of these values: +

+

+
+
nope + +
+Do not attempt to use SSL +
try + +
+Try using SSL, proceed anyway otherwise. +
control + +
+Use SSL for the control conecction or fail with "use ssl failed" (64). +
all + +
+Use SSL for all communication or fail with "use ssl failed" (64). +
+
+ +

+

+  +

SSL and security options

+ +

+

+
-sslcert + +
+Pass a string as parameter. The string should be the file name of your certificate. +The default format is "PEM" and can be changed with -sslcerttype. +

+With NSS this is the nickname of the certificate you wish to authenticate with. +If you want to use a file from the current directory, please precede it with the +"./" prefix, in order to avoid confusion with a nickname. +

+

-sslcerttype + +
+Pass a string as parameter. The string should be the format of your certificate. +Supported formats are "PEM" and "DER". +

+

-sslkey + +
+Pass a pointer to a zero terminated string as parameter. The string should be +the file name of your private key. The default format is "PEM" and can be +changed with -sslkeytype. +

+

-sslkeytype + +
+Pass a pointer to a zero terminated string as parameter. The string should be +the format of your private key. Supported formats are "PEM", "DER" and "ENG" +

+NOTE:The format "ENG" enables you to load the private key from a crypto +engine. in this case -sslkey is used as an identifier passed to +the engine. You have to set the crypto engine with -sslengine. The "DER" +format key file currently does not work because of a bug in OpenSSL. +

+

-keypasswd + +
+Pass a string as parameter. It will be used as the password required to use the +-sslkey or -sshprivatekeyfile private key. +

+You never need a pass phrase to load a certificate but you need one to load you +private key. +

+This option used to be known as -sslkeypasswd and -sslcertpasswd. +

+

-sslengine + +
+Pass a string as parameter. It will be used as the identifier for the crypto +engine you want to use for your private key. +

+NOTE:If the crypto device cannot be loaded, an error will be returned. +

+

-sslenginedefault + +
+Pass a 1 to set the actual crypto engine as the default for (asymmetric) crypto operations. +

+NOTE:If the crypto device cannot be set, an error will be returned. +

+

-sslversion + +
+Use it to set what version of SSL/TLS to use. The available options are: +
+
+
default + +
+The default action. This will attempt to figure out the remote SSL protocol version, +i.e. either SSLv3 or TLSv1 (but not SSLv2, which became disabled by default with 7.18.1). +
tlsv1 + +
+Force TLSv1 +
sslv2 + +
+Force SSLv2 +
sslv3 + +
+Force SSLv3 +
+
+ +

+

-sslverifypeer + +
+This option determines whether TclCurl verifies the authenticity of the peer's certificate. +A 1 means it verifies; zero means it doesn't. The default is 1. +

+When negotiating an SSL connection, the server sends a certificate indicating its identity. +TclCurl verifies whether the certificate is authentic, i.e. that you can trust that the +server is who the certificate says it is. This trust is based on a chain of digital signatures, +rooted in certification authority (CA) certificates you supply. +

+TclCurl uses a default bundle of CA certificates that comes with libcurl but you can specify +alternate certificates with the -cainfo or the -capath options. +

+When -sslverifypeer is nonzero, and the verification fails to prove that the certificate +is authentic, the connection fails. When the option is zero, the peer certificate verification +succeeds regardless. +

+Authenticating the certificate is not by itself very useful. You typically want to ensure +that the server, as authentically identified by its certificate, is the server you mean to +be talking to, use -sslverifyhost to control that. The check that the host name in +the certificate is valid for the host name you're connecting to is done +independently of this option. +

+

-cainfo + +
+Pass a file naming holding the certificate to verify the peer with. This only +makes sense when used in combination with the -sslverifypeer option, if +it is set to zero -cainfo need not even indicate an accessible file. +

+This option is by default set to the system path where libcurl's cacert bundle +is assumed to be stored, as established at build time. +

+When built against NSS this is the directory that the NSS certificate database +resides in. +

+

-issuercert + +
+Pass a string naming a file holding a CA certificate in PEM format. If the option +is set, an additional check against the peer certificate is performed to verify +the issuer is indeed the one associated with the certificate provided by the option. +This additional check is useful in multi-level PKI where one need to enforce the peer +certificate is from a specific branch of the tree. +
  +This option makes sense only when used in combination with the -sslverifypeer +option. Otherwise, the result of the check is not considered as failure. +

+

-capath + +
+Pass the directory holding multiple CA certificates to verify the peer with. +If libcurl is built against OpenSSL, the certificate directory must be prepared +using the openssl c_rehash utility. +This only makes sense when used in combination with the -sslverifypeer +option, if it is set to zero, -capath need not even indicate an accessible +path. +

+This option apparently does not work in Windows due to some limitation in openssl. +

+This option is OpenSSL-specific and does nothing if libcurl is built to use GnuTLS. +NSS-powered libcurl provides the option only for backward compatibility. +

+

-crlfile + +
+Pass a string naming a file with the concatenation of CRL (in PEM format) to use in +the certificate validation that occurs during the SSL exchange. +
  +When libcurl is built to use NSS or GnuTLS, there is no way to influence the use of +CRL passed to help in the verification process. When built with OpenSSL support, +X509_V_FLAG_CRL_CHECK and X509_V_FLAG_CRL_CHECK_ALL are both set, requiring CRL +check against all the elements of the certificate chain if a CRL file is passed. +
  +This option makes sense only when used in combination with the -sslverifypeer +option. +

+A specific error code (CURLE_SSL_CRL_BADFILE) is defined with the option. It is returned +when the SSL exchange fails because the CRL file cannot be loaded. A failure in certificate +verification due to a revocation information found in the CRL does not trigger this specific +error. +

+

-sslverifyhost + +
+This option determines whether TclCurl verifies that the server claims to be +who you want it to be. +

+When negotiating an SSL connection, the server sends a certificate +indicating its identity. +

+When -sslverifyhost is set to 2, that certificate must indicate +that the server is the server to which you meant to connect, or the +connection fails. +

+TclCurl considers the server the intended one when the Common Name field +or a Subject Alternate Name field in the certificate matches the host +name in the URL to which you told Curl to connect. +

+When set to 1, the certificate must contain a Common Name field, +but it does not matter what name it says. (This is not ordinarily a +useful setting). +

+When the value is 0, the connection succeeds regardless of the names in +the certificate. +

+The default value for this option is 2. +

+This option controls the identity that the server claims. The server +could be lying. To control lying, see -sslverifypeer. If libcurl is built +against NSS and -verifypeer is zero, -verifyhost is ignored. +

+

-certinfo + +
+Set to '1' to enable TclCurl's certificate chain info gatherer. With this enabled, TclCurl +(if built with OpenSSL) will extract lots of information and data about the certificates +in the certificate chain used in the SSL connection. This data can then be to extracted +after a transfer using the getinfo command and its option certinfo. +

+

-randomfile + +
+Pass a file name. The file will be used to read from to seed the random engine +for SSL. The more random the specified file is, the more secure the SSL +connection becomes. +

+

-egdsocket + +
+Pass a path name to the Entropy Gathering Daemon socket. It will be used to seed +the random engine for SSL. +

+

-sslcypherlist + +
+Pass a string holding the ciphers to use for the SSL connection. The list must +consists of one or more cipher strings separated by colons. Commas or spaces +are also acceptable separators but colons are normally used, , - and + can be +used as operators. +

+For OpenSSL and GnuTLS valid examples of cipher lists include 'RC4-SHA', 'SHA1+DES', + +

+You will find more details about cipher lists on this URL: +
    http://www.openssl.org/docs/apps/ciphers.html +

+For NSS valid examples of cipher lists include 'rsa_rc4_128_md5', 'rsa_aes_128_sha', +etc. With NSS you don't add/remove ciphers. If you use this option then all known +ciphers are disabled and only those passed in are enabled. +
  +You'll find more details about the NSS cipher lists on this URL: +
    http://directory.fedora.redhat.com/docs/mod_nss.html +

+

-sslsessionidcache + +
+Pass a 0 to disable TclCurl's use of SSL session-ID caching or a 1 to enable it. +By default all transfers are done using the cache. While nothing ever +should get hurt by attempting to reuse SSL session-IDs, there seem to be broken SSL +implementations in the wild that may require you to disable this in order for you to +succeed. +

+

-krblevel + +
+Set the kerberos security level for FTP, this also enables kerberos awareness. +This is a string, 'clear', 'safe', 'confidential' or 'private'. If the string +is set but does not match one of these, 'private' will be used. Set the string +to NULL to disable kerberos4. Set the string to "" to disable kerberos +support for FTP. +

+

-gssapidelegation + +
+Set the option to 'flag' to allow unconditional GSSAPI credential delegation. The delegation +is disabled by default since 7.21.7. Set the parameter to 'policyflag' to delegate only if +the OK-AS-DELEGATE flag is set in the service ticket in case this feature is supported by the +GSSAPI implementation and the definition of GSS_C_DELEG_POLICY_FLAG was available at compile-time. +

+

+

+  +

SSH options

+ +

+

+
-sshauthtypes + +
+The allowed types are: +

+

+
+
publickey + +
+
password + +
+
host + +
+
keyboard + +
+
any + +
+To let TclCurl pick one +
+
+ +

+

-sshhostpublickeymd5 + +
+Pass a string containing 32 hexadecimal digits. The string should be the 128 +bit MD5 cheksum of the remote host public key, and TclCurl will reject the +connection to the host unless the md5sums match. This option is only for SCP +and SFTP transfers. +

+

-publickeyfile + +
+Pass the file name for your public key. If not used, TclCurl defaults to using $HOME/.ssh/id_dsa.pub. +HOME environment variable is set, and just id_dsa in the current directory if not. +

+

-privatekeyfile + +
+Pass the file name for your private key. If not used, TclCurl defaults to using $HOME/.ssh/id_dsa.pub. +HOME environment variable is set, and just id_dsa in the current directory if not. +If the file is password-protected, set the password with -keypasswd. +

+

-sshknownhosts + +
+Pass a string holding the file name of the known_host file to use. The known_hosts +file should use the OpenSSH file format as supported by libssh2. If this file is +specified, TclCurl will only accept connections with hosts that are known and present +in that file, with a matching public key. Use -sshkeyproc to alter the default +behavior on host and key (mis)matching. +

+

-sshkeyproc + +
+Pass a the name of the procedure that will be called when the known_host matching has +been done, to allow the application to act and decide for TclCurl how to proceed. The +callback will only be called if -knownhosts is also set. +

+It gets passed a list with three elements, the first one is a list with the type of the +key from the known_hosts file and the key itself, the second is another list with +the type of the key from the remote site and the key itslef, the third tells you +what TclCurl thinks about the matching status. +

+The known key types are: "rsa", "rsa1" and "dss", in any other case "unknown" is given. +

+TclCurl opinion about how they match may be: "match", "mismatch", "missing" or "error". +

+The procedure must return: +

+
+
0 + +
+The host+key is accepted and TclCurl will append it to the known_hosts file before +continuing with the connection. This will also add the host+key combo to the known_host +pool kept in memory if it wasn't already present there. The adding of data to +the file is done by completely replacing the file with a new copy, so the permissions of +the file must allow this. +
1 + +
+The host+key is accepted, TclCurl will continue with the connection. This will also add +the host+key combo to the known_host pool kept in memory if it wasn't already present +there. +
2 + +
+The host+key is rejected. TclCurl will close the connection. +
3 + +
+The host+key is rejected, but the SSH connection is asked to be kept alive. This feature +could be used when the app wants to somehow return back and act on the host+key situation +and then retry without needing the overhead of setting it up from scratch again. +
+
+ +

+Any other value will cause the connection to be closed. +

+

+  +

Other options

+ +

+

+
-headervar + +
+Name of the Tcl array variable where TclCurl will store the headers returned +by the server. +

+

-bodyvar + +
+Name of the Tcl variable where TclCurl will store the file requested, the file +may contain text or binary data. +

+

-canceltransvar + +
+Name of a Tcl variable, in case you have defined a procedure to call with +-progressproc setting this variable to '1' will cancel the transfer. +

+

-command + +
+Executes the given command after the transfer is done, since it only works +with blocking transfers, it is pretty much useless. +

+

-share + +
+Pass a share handle as a parameter. The share handle must have been created by +a previous call to curl::shareinit. Setting this option, will make this +handle use the data from the shared handle instead of keeping the data to itself. +See tclcurl_share for details. +

+

-newfileperms + +
+Pass a number as a parameter, containing the value of the permissions that will +be assigned to newly created files on the remote server. The default value is 0644, +but any valid value can be used. The only protocols that can use this are sftp://, +scp:// and file://. +

+

-newdirectoryperms + +
+Pass a number as a parameter, containing the value of the permissions that will be +assigned to newly created directories on the remote server. The default value is 0755, +but any valid value can be used. The only protocols that can use this are sftp://, scp:// +and file://. +

+

+  +

Telnet options

+ +

+

+
-telnetoptions + +
+Pass a list with variables to pass to the telnet negotiations. The variables should be in +the format <option=value>. TclCurl supports the options 'TTYPE', 'XDISPLOC' and 'NEW_ENV'. +See the TELNET standard for details. +

+

+  +

NOT SUPPORTED

+ +Some of the options libcurl offers are not supported, I don't think them +worth supporting in TclCurl but if you need one of them don't forget to +complain: +

+CURLOPT_FRESH_CONNECT, CURLOPT_FORBID_REUSE, CURLOPT_PRIVATE, + +CURLOPT_SSL_CTX_FUNCTION, CURLOPT_SSL_CTX_DATA, CURLOPT_SSL_CTX_FUNCTION and + +CURLOPT_CONNECT_ONLY, CURLOPT_OPENSOCKETFUNCTION, CURLOPT_OPENSOCKETDATA. + +

+  +

curlHandle perform

+ +This procedure is called after the +init + +and all the +configure + +calls are made, and will perform the transfer as described in the options. +

+It must be called with the same +curlHandle curl::init call returned. +You can do any amount of calls to perform while using the same handle. If you +intend to transfer more than one file, you are even encouraged to do +so. TclCurl will then attempt to re-use the same connection for the following +transfers, thus making the operations faster, less CPU intense and using less +network resources. Just note that you will have to use +configure + +between the invokes to set options for the following perform. +

+You must never call this procedure simultaneously from two places using the +same handle. Let it return first before invoking it another time. If +you want parallel transfers, you must use several curl handles. +

+
RETURN VALUE + +
+ +errorbuffer + +was set with +configure + +there will be a readable error message. +The error codes are: +
1
+Unsupported protocol. This build of TclCurl has no support for this protocol. +
2
+Very early initialization code failed. This is likely to be and internal error +or a resource problem where something fundamental couldn't get done at init time. +
3
+URL malformat. The syntax was not correct. +
4
+A requested feature, protocol or option was not found built-in in this libcurl +due to a build-time decision. This means that a feature or option was not +enabled or explicitly disabled when libcurl was built and in order to get it +to function you have to get a rebuilt libcurl. +
5
+Couldn't resolve proxy. The given proxy host could not be resolved. +
6
+Couldn't resolve host. The given remote host was not resolved. +
7
+Failed to connect to host or proxy. +
8
+FTP weird server reply. The server sent data TclCurl couldn't parse. +The given remote server is probably not an OK FTP server. +
9
+We were denied access to the resource given in the URL. For FTP, this occurs +while trying to change to the remote directory. +
11
+FTP weird PASS reply. TclCurl couldn't parse the reply sent to the PASS request. +
13
+FTP weird PASV reply, TclCurl couldn't parse the reply sent to the PASV or EPSV +request. +
14
+FTP weird 227 format. TclCurl couldn't parse the 227-line the server sent. +
15
+FTP can't get host. Couldn't resolve the host IP we got in the 227-line. +
17
+FTP couldn't set type. Couldn't change transfer method to either binary or +ascii. +
18
+Partial file. Only a part of the file was transfered, this happens when +the server first reports an expected transfer size and then delivers data +that doesn't match the given size. +
19
+FTP couldn't RETR file, we either got a weird reply to a 'RETR' command or +a zero byte transfer. +
21
+Quote error. A custom 'QUOTE' returned error code 400 or higher (for FTP) or +otherwise indicated unsuccessful completion of the command. +
22
+HTTP returned error. This return code only appears if -failonerror is +used and the HTTP server returns an error code that is 400 or higher. +
23
+Write error. TclCurl couldn't write data to a local filesystem or an error +was returned from a write callback. +
25
+Failed upload failed. For FTP, the server typcially denied the STOR +command. The error buffer usually contains the server's explanation to this. +
26
+Read error. There was a problem reading from a local file or an error was returned +from the read callback. +
27
+Out of memory. A memory allocation request failed. This should never happen unless +something weird is going on in your computer. +
28
+Operation timeout. The specified time-out period was reached according to the +conditions. +
30
+The FTP PORT command failed, not all FTP servers support the PORT command, +try doing a transfer using PASV instead!. +
31
+FTP couldn't use REST. This command is used for resumed FTP transfers. +
33
+Range error. The server doesn't support or accept range requests. +
34
+HTTP post error. Internal post-request generation error. +
35
+SSL connect error. The SSL handshaking failed, the error buffer may have +a clue to the reason, could be certificates, passwords, ... +
36
+The download could not be resumed because the specified offset was out of the +file boundary. +
37
+A file given with FILE:// couldn't be read. Did you checked the permissions? +
38
+LDAP cannot bind. LDAP bind operation failed. +
39
+LDAP search failed. +
41
+A required zlib function was not found. +
42
+Aborted by callback. An application told TclCurl to abort the operation. +
43
+Internal error. A function was called with a bad parameter. +
45
+Interface error. A specified outgoing interface could not be used. +
47
+Too many redirects. When following redirects, TclCurl hit the maximum amount, set +your limit with --maxredirs +
48
+An option passed to TclCurl is not recognized/known. Refer to the appropriate +documentation. This is most likely a problem in the program that uses +TclCurl. The error buffer might contain more specific information about which +exact option it concerns. +
49
+A telnet option string was illegally formatted. +
51
+The remote peer's SSL certificate or SSH md5 fingerprint wasn't ok +
52
+The server didn't reply anything, which here is considered an error. +
53
+The specified crypto engine wasn't found. +
54
+Failed setting the selected SSL crypto engine as default! +
55
+Failed sending network data. +
56
+Failure with receiving network data. +
58
+Problem with the local client certificate. +
59
+Couldn't use specified SSL cipher. +
60
+Peer certificate cannot be authenticated with known CA certificates. +
61
+Unrecognized transfer encoding. +
62
+Invalid LDAP URL. +
63
+Maximum file size exceeded. +
64
+SSL use failed. +
65
+Sending the data requires a rewind that failed, since TclCurl should +take care of it for you, it means you found a bug. +
66
+Failed to initialise ssl engine. +
67
+Failed to login, user password or similar was not accepted. +
68
+File not found on TFTP server. +
69
+There is a permission problem with the TFTP request. +
70
+The remote server has run out of space. +
71
+Illegal TFTP operation. +
72
+Unknown transfer ID. +
73
+TFTP file already exists and will not be overwritten. +
74
+No such user in the TFTP server and good behaving TFTP servers +should never return this. +
75
+Character conversion failed. +
77
+Problem with reading the SSL CA cert (path? access rights?). +
78
+Remote file not found +
79
+Error from the SSH layer +
80
+Failed to shut down the SSL connection +
82
+Failed to load CRL file +
83
+Issuer check failed +
84
+The FTP server does not understand the PRET command at all or does not support +the given argument. Be careful when using -customrequest, a +custom LIST command will be sent with PRET CMD before PASV as well. +
85
+Mismatch of RTSP CSeq numbers. +
86
+Mismatch of RTSP Session Identifiers. +
87
+Unable to parse FTP file list (during FTP wildcard downloading). +
88
+Chunk callback reported error. +

+

+  +

curlHandle getinfo option

+ +Request internal information from the curl session with this procedure. +This procedure is intended to get used *AFTER* a performed transfer, +and can be relied upon only if the perform returns 0. Use +this function AFTER a performed transfer if you want to get +transfer-oriented data. +

+The following information can be extracted: +

+

+
effectiveurl + +
+Returns the last used effective URL. +

+

responsecode + +
+Returns the last received HTTP or FTP code. This will be zero if no server +response code has been received. Note that a proxy's CONNECT response should +be read with httpconnectcode and not this. +

+

httpconnectcode + +
+Returns the last received proxy response code to a CONNECT request. +

+

filetime + +
+Returns the remote time of the retrieved document (in number of seconds +since 1 jan 1970 in the GMT/UTC time zone). If you get -1, +it can be because of many reasons (unknown, the server hides it or the +server doesn't support the command that tells document time etc) and the time +of the document is unknown. +

+In order for this to work you have to set the -filetime option before +the transfer. +

+

namelookuptime + +
+Returns the time, in seconds, it took from the start until the name resolving +was completed. +

+

connecttime + +
+Returns the time, in seconds, it took from the start until the connect to the +remote host (or proxy) was completed. +

+

appconnecttime + +
+Returns the time, in seconds, it took from the start until the SSL/SSH +connect/handshake to the remote host was completed. This time is most often very +near to the PRETRANSFER time, except for cases such as HTTP pippelining where the +pretransfer time can be delayed due to waits in line for the pipeline and more. +

+

pretransfertime + +
+Returns the time, in seconds, it took from the start until the file transfer +is just about to begin. This includes all pre-transfer commands and +negotiations that are specific to the particular protocol(s) involved. +

+

starttransfertime + +
+Returns the time, in seconds, it took from the start until the first byte +is just about to be transfered. This includes the pretransfertime, +and also the time the server needs to calculate the result. +

+

totaltime + +
+Returns the total transaction time, in seconds, for the previous transfer, +including name resolving, TCP connect etc. +

+

redirecturl + +
+Returns the URL a redirect would take you to if you enable followlocation. +This can come very handy if you think using the built-in libcurl redirect logic +isn't good enough for you but you would still prefer to avoid implementing all +the magic of figuring out the new URL. +

+

redirecttime + +
+Returns the total time, in seconds, it took for all redirection steps +including name lookup, connect, pretransfer and transfer before +the final transaction was started, it returns the complete execution +time for multiple redirections, so it returns zero if no redirections +were needed. +

+

redirectcount + +
+Returns the total number of redirections that were actually followed. +

+

numconnects + +
+Returns how many new connections TclCurl had to create to achieve the +previous transfer (only the successful connects are counted). Combined +with redirectcount you are able to know how many times TclCurl +successfully reused existing connection(s) or not. See the Connection +Options of setopt to see how TclCurl tries to make persistent +connections to save time. +

+

primaryip + +
+Returns the IP address of the most recent connection done with this handle. +This string may be IPv6 if that's enabled. +

+

primaryport + +
+Returns the destination port of the most recent connection done with this handle. +

+

localip + +
+Returns the local (source) IP address of the most recent connection done +with this handle. This string may be IPv6 if that's enabled. +

+

localport + +
+Returns the local (source) port of the most recent connection done with this handle. +

+

sizeupload + +
+Returns the total amount of bytes that were uploaded. +

+

sizedownload + +
+Returns the total amount of bytes that were downloaded. The amount is only +for the latest transfer and will be reset again for each new transfer. +

+

speeddownload + +
+Returns the average download speed, measured in bytes/second, for the complete download. +

+

speedupload + +
+Returns the average upload speed, measured in bytes/second, for the complete upload. +

+

headersize + +
+Returns the total size in bytes of all the headers received. +

+

requestsize + +
+Returns the total size of the issued requests. This is so far only for HTTP +requests. Note that this may be more than one request if followLocation is true. +

+

sslverifyresult + +
+Returns the result of the certification verification that was requested +(using the -sslverifypeer option to configure). +

+

sslengines + +
+Returns a list of the OpenSSL crypto-engines supported. Note that engines are +normally implemented in separate dynamic libraries. Hence not all the returned +engines may be available at run-time. +

+

contentlengthdownload + +
+Returns the content-length of the download. This is the value read from the +Content-Length: + +field. If the size isn't known, it returns -1. +

+

contentlengthupload + +
+Returns the specified size of the upload. +

+

contenttype + +
+Returns the content-type of the downloaded object. This is the value +read from the Content-Type: field. If you get an empty string, it means +the server didn't send a valid Content-Type header or that the protocol +used doesn't support this. +

+

httpauthavail + +
+Returns a list with the authentication method(s) available. +

+

proxyauthavail + +
+Returns a list with the authentication method(s) available for your +proxy athentication. +

+

oserrno + +
+Returns the errno value from a connect failure. This value is only set on +failure, it is no reset after a successfull operation. +

+

cookielist + +
+Returns a list of all cookies TclCurl knows (expired ones, too). If there +are no cookies (cookies for the handle have not been enabled or simply +none have been received) the list will be empty. +

+

ftpentrypath + +
+Returns a string holding the path of the entry path. That is the initial path +TclCurl ended up in when logging on to the remote FTP server. Returns an empty +string if something is wrong. +

+

certinfo + +
+Returns list with information about the certificate chain, assuming you had the +-certinfo option enabled when the previous request was done. The list +first item reports how many certs it found and then you can extract info for each +of those certs by following the list. The info chain is provided in a series of data +in the format "name:content" where the content is for the specific named data. +

+NOTE: this option is only available in libcurl built with OpenSSL support. +

+

conditionunmet + +
+Returns the number 1 if the condition provided in the previous request +didn't match (see timecondition), you will get a zero if the condition +instead was met. +

+

+  +

curlHandle cleanup

+ +This procedure must be the last one to call for a curl session. It is the +opposite of the +curl::init + +procedure and must be called with the same +curlhandle + +as input as the curl::init call returned. +This will effectively close all connections TclCurl has used and possibly +has kept open until now. Don't call this procedure if you intend to transfer +more files. +

+  +

curlHandle reset

+ +

+Re-initializes all options previously set on a specified handle to the +default values. +

+This puts back the handle to the same state as it was in when it was just +created with curl::init. +

+It does not change the following information kept in the handle: live +connections, the Session ID cache, the DNS cache, the cookies and shares. +

+  +

curlHandle duphandle

+ +This procedure will return a new curl handle, a duplicate, +using all the options previously set in the input curl handle. +Both handles can subsequently be used independently and +they must both be freed with +cleanup. + +The new handle will not inherit any state information, +connections, SSL sessions or cookies. +
+
RETURN VALUE + +
+A new curl handle or an error message if the copy fails. +

+

+  +

curlHandle pause

+ +You can use this command from within a progress callback procedure +to pause the transfer. +

+  +

curlHandle resume

+ +Resumes a transfer paused with curlhandle pause +

+  +

curl::transfer

+ +In case you do not want to use persistant connections you can use this +command, it takes the same arguments as the curlHandle configure +and will init, configure, perform and cleanup a connection for you. +

+You can also get the getinfo information by using -infooption variable +pairs, after the transfer variable will contain the value that would have +been returned by $curlHandle getinfo option. +

+
RETURN VALUE + +
+The same error code perform would return. +

+

+  +

curl::version

+ +Returns a string with the version number of tclcurl, libcurl and some of +its important components (like OpenSSL version). +
+
RETURN VALUE + +
+The string with the version info. +

+

+  +

curl::escape url

+ +This procedure will convert the given input string to an URL encoded string and +return that. All input characters that are not a-z, +A-Z or 0-9 will be converted to their "URL escaped" version (%NN where NN is a +two-digit hexadecimal number) +
+
RETURN VALUE + +
+The converted string. +
+  +

curl::unescape url

+ +This procedure will convert the given URL encoded input string to a "plain +string" and return that. All input characters that +are URL encoded (%XX where XX is a two-digit hexadecimal number) will be +converted to their plain text versions. +
+
RETURN VALUE + +
+The string unencoded. +

+

+  +

curl::curlConfig option

+ +Returns some information about how you have +cURL + +installed. +

+

+
-prefix + +
+Returns the directory root where you installed +cURL + +
-feature + +
+Returns a list containing particular main features the installed +libcurl + +was built with. The list may include SSL, KRB4 or IPv6, do not +assume any particular order. +
-vernum + +
+Outputs version information about the installed libcurl, in +numerical mode. This outputs the version number, in hexadecimal, +with 8 bits for each part; major, minor, patch. So that libcurl +7.7.4 would appear as 070704 and libcurl 12.13.14 would appear as +0c0d0e... +

+

+  +

curl::versioninfo option

+ +Returns information about various run-time features in TclCurl. +

+Applications should use this information to judge if things are possible to do +or not, instead of using compile-time checks, as dynamic/DLL libraries can be +changed independent of applications. +

+

+
-version + +
+Returns the version of libcurl we are using. +

+

-versionnum + +
+Retuns the version of libcurl we are using in hexadecimal with 8 bits for each +part; major, minor, patch. So that libcurl 7.7.4 would appear as 070704 and +libcurl 12.13.14 would appear as 0c0d0e... Note that the initial zero might be +omitted. +

+

-host + +
+Returns a string with the host information as discovered by a configure +script or set by the build environment. +

+

-features + +
+Returns a list with the features compiled into libcurl, the possible elements are: +
+
+
ASYNCHDNS + +
+Libcurl was built with support for asynchronous name lookups, which allows +more exact timeouts (even on Windows) and less blocking when using the multi +interface. +
CONV + +
+Libcurl was built with support for character conversions. +
DEBUG + +
+Libcurl was built with extra debug capabilities built-in. This is mainly of +interest for libcurl hackers. +
GSSNEGOTIATE + +
+Supports HTTP GSS-Negotiate. +
IDN + +
+Supports IDNA, domain names with international letters. +
IPV6 + +
+Supports IPv6. +
KERBEROS4 + +
+Supports kerberos4 (when using FTP). +
LARGEFILE + +
+Libcurl was built with support for large files. +
LIBZ + +
+Supports HTTP deflate using libz. +
NTML + +
+Supports HTTP NTLM +
SPNEGO + +
+Libcurl was built with support for SPNEGO authentication (Simple and Protected +GSS-API Negotiation Mechanism, defined in RFC 2478) +
SSL + +
+Supports SSL (HTTPS/FTPS) +
SSPI + +
+Libcurl was built with support for SSPI. This is only available on Windows and +makes libcurl use Windows-provided functions for NTLM authentication. It also +allows libcurl to use the current user and the current user's password without +the app having to pass them on. +
TLSAUTH_SRP + +
+Libcurl was built with support for TLS-SRP. +NTLM_WB + +Libcurl was built with support for NTLM delegation to a winbind helper. +
+
+ +Do not assume any particular order. +

+

-sslversion + +
+Returns a string with the OpenSSL version used, like OpenSSL/0.9.6b. +

+

-sslversionnum + +
+Returns the numerical OpenSSL version value as defined by the OpenSSL project. +If libcurl has no SSL support, this is 0. +

+

-libzversion + +
+Returns a string, there is no numerical version, for example: 1.1.3. +

+

-protocols + +
+Lists what particular protocols the installed TclCurl was built to support. +At the time of writing, this list may include HTTP, HTTPS, FTP, FTPS, +FILE, TELNET, LDAP, DICT. Do not assume any particular order. The protocols +will be listed using uppercase. There may be none, one or several protocols +in the list. +

+

+  +

curl::easystrerror errorCode

+ +This procedure returns a string describing the error code passed in the argument. +

+  +

SEE ALSO

+ +curl, The art of HTTP scripting, RFC 2396, + +

+ +

+ 

Index

+
+
NAME
+
SYNOPSIS
+
DESCRIPTION
+
curl::init
+
curlHandle configure ?options?
+
Behaviour options
+
Callback options
+
Error Options
+
Network options
+
Names and Passwords options
+
HTTP options
+
SMTP options
+
TFTP option
+
FTP options
+
Protocol options
+
Connection options
+
SSL and security options
+
SSH options
+
Other options
+
Telnet options
+
NOT SUPPORTED
+
curlHandle perform
+
curlHandle getinfo option
+
curlHandle cleanup
+
curlHandle reset
+
curlHandle duphandle
+
curlHandle pause
+
curlHandle resume
+
curl::transfer
+
curl::version
+
curl::escape url
+
curl::unescape url
+
curl::curlConfig option
+
curl::versioninfo option
+
curl::easystrerror errorCode
+
SEE ALSO
+
+
+This document was created by man2html, using the manual pages.
+ + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl new file mode 100644 index 00000000..3cb25968 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl @@ -0,0 +1,143 @@ +################################################################################ +################################################################################ +#### tclcurl.tcl +################################################################################ +################################################################################ +## Includes the tcl part of TclCurl +################################################################################ +################################################################################ +## (c) 2001-2011 Andres Garcia Garcia. fandom@telefonica.net +## See the file "license.terms" for information on usage and redistribution +## of this file and for a DISCLAIMER OF ALL WARRANTIES. +################################################################################ +################################################################################ + +namespace eval curl { + +################################################################################ +# configure +# Invokes the 'curl-config' script to be able to know what features have +# been compiled in the installed version of libcurl. +# Possible options are '-prefix', '-feature' and 'vernum' +################################################################################ +proc ::curl::curlConfig {option} { + + if {$::tcl_platform(platform)=="windows"} { + error "This command is not available in Windows" + } + + switch -exact -- $option { + -prefix { + return [exec curl-config --prefix] + } + -feature { + set featureList [exec curl-config --feature] + regsub -all {\\n} $featureList { } featureList + return $featureList + } + -vernum { + return [exec curl-config --vernum] + } + -ca { + return [exec curl-config --ca] + } + default { + error "bad option '$option': must be '-prefix', '-feature', '-vernum' or '-ca'" + } + } + return +} + +################################################################################ +# transfer +# The transfer command is used for simple transfers in which you don't +# want to request more than one file. +# +# Parameters: +# Use the same parameters you would use in the 'configure' command to +# configure the download and the same as in 'getinfo' with a 'info' +# prefix to get info about the transfer. +################################################################################ +proc ::curl::transfer {args} { + variable getInfo + variable curlBodyVar + + set i 0 + set newArgs "" + catch {unset getInfo} + + if {[llength $args]==0} { + puts "No transfer configured" + return + } + + foreach {option value} $args { + set noPassOption 0 + set block 1 + switch -regexp -- $option { + -info.* { + set noPassOption 1 + regsub -- {-info} $option {} option + set getInfo($option) $value + } + -block { + set noPassOption 1 + set block $value + } + -bodyvar { + upvar $value curlBodyVar + set value curlBodyVar + } + -headervar { + upvar $value curlHeaderVar + set value curlHeaderVar + } + -errorbuffer { + upvar $value curlErrorVar + set value curlErrorVar + } + } + if {$noPassOption==0} { + lappend newArgs $option $value + } + } + + if {[catch {::curl::init} curlHandle]} { + error "Could not init a curl session: $curlHandle" + } + + if {[catch {eval $curlHandle configure $newArgs} result]} { + $curlHandle cleanup + error $result + } + + if {$block==1} { + if {[catch {$curlHandle perform} result]} { + $curlHandle cleanup + error $result + } + if {[info exists getInfo]} { + foreach {option var} [array get getInfo] { + upvar $var info + set info [eval $curlHandle getinfo $option] + } + } + if {[catch {$curlHandle cleanup} result]} { + error $result + } + } else { + # We create a multiHandle + set multiHandle [curl::multiinit] + + # We add the easy handle to the multi handle. + $multiHandle addhandle $curlHandle + + # So now we create the event source passing the multiHandle as a parameter. + curl::createEventSource $multiHandle + + # And we return, it is non blocking after all. + } + return 0 +} + +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html new file mode 100644 index 00000000..02b23614 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html @@ -0,0 +1,320 @@ +Manpage of TclCurl + +

TclCurl

+Section: TclCurl Multi Interface (3)
Updated: 03 September 2011
+ +  +

NAME

+ +TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP, +LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax. +  +

SYNOPSIS

+ +curl::multiinit + +

+multiHandle addhandle + +

+multiHandle removehandle + +

+multiHandle configure + +

+multiHandle perform + +

+multiHandle active + +

+multiHandle getinfo + +

+multihandle cleanup + +

+multihandle auto + +

+curl::multistrerror errorCode + +

+  +

DESCRIPTION

+ +TclCurl's multi interface introduces several new abilities that the easy +interface refuses to offer. They are mainly: +
    +
  • Enable a "pull" interface. The application that uses TclCurl decides where +and when to get/send data.

    +
  • Enable multiple simultaneous transfers in the same thread without making it +complicated for the application.

    +
  • Keep Tk GUIs 'alive' while transfers are taking place.

    +
+

+ +  +

Blocking

+ +A few areas in the code are still using blocking code, even when used from the +multi interface. While we certainly want and intend for these to get fixed in +the future, you should be aware of the following current restrictions: +
    +
  • Name resolves on non-windows unless c-ares is used. + +
  • GnuTLS SSL connections. + +
  • Active FTP connections. + +
  • HTTP proxy CONNECT operations. + +
  • SCP and SFTP connections. + +
  • SFTP transfers. + +
  • TFTP transfers + +
  • file:// transfers. +
+ +

+  +

curl::multiinit

+ +This procedure must be the first one to call, it returns a multiHandle +that you need to use to invoke TclCurl procedures. The init MUST have a +corresponding call to cleanup when the operation is completed. +

+RETURN VALUE + +

+multiHandle + +to use. +

+  +

multiHandle addhandle ?easyHandle?

+ +

+Each single transfer is built up with an 'easy' handle, the kind we have been +using so far with TclCurl, you must create them and setup the appropriate +options for each of them. Then we add them to the 'multi stack' using the +addhandle command. +

+If the easy handle is not set to use a shared or global DNS cache, it will be made +to use the DNS cache that is shared between all easy handles within the multi handle. +

+When an easy handle has been added to a multi stack, you can not and you must not use +perform on that handle! +

+

+multiHandle + +is the return code from the curl::multiinit call. +

+RETURN VALUE + +The possible return values are: +

+
-1
+Handle added to the multi stack, please call +perform + +soon +
0
+Handle added ok. +
1
+Invalid multi handle. +
2
+Invalid 'easy' handle. It could mean that it isn't an easy handle at all, or possibly that +the handle already is in used by this or another multi handle. +
3
+Out of memory, you should never get this. +
4
+You found a bug in TclCurl. +

+

+  +

multiHandle removehandle ?easyHandle?

+ +

+When a transfer is done or if we want to stop a transfer before it is completed, +we can use the removehandle command. Once removed from the multi handle, +we can again use other easy interface functions on it. +

+Please note that when a single transfer is completed, the easy handle is still +left added to the multi stack. You need to remove it and then close or, possibly, +set new options to it and add it again to the multi handle to start another transfer. +

+

+RETURN VALUE + +The possible return values are: +

+
0
+Handle removed ok. +
1
+Invalid multi handle. +
2
+Invalid 'easy' handle. +
3
+Out of memory, you should never get this. +
4
+You found a bug in TclCurl. +

+

+  +

multiHandle configure

+ +So far the only option is: +
+
-pipelining + +
+Pass a 1 to enable or 0 to disable. Enabling pipelining on a multi handle will +make it attempt to perform HTTP Pipelining as far as possible for transfers using +this handle. This means that if you add a second request that can use an already +existing connection, the second request will be "piped" on the same connection +rather than being executed in parallel. +
-maxconnects + +
+Pass a number which will be used as the maximum amount of simultaneously open +connections that TclCurl may cache. Default is 10, and TclCurl will enlarge +the size for each added easy handle to make it fit 4 times the number of added +easy handles. +

+By setting this option, you can prevent the cache size to grow beyond the limit +set by you. When the cache is full, curl closes the oldest one in the cache to +prevent the number of open connections to increase. +

+This option is for the multi handle's use only, when using the easy interface you should instead use it's own maxconnects option. +

+

+  +

multiHandle perform

+ +Adding the easy handles to the multi stack does not start any transfer. +Remember that one of the main ideas with this interface is to let your +application drive. You drive the transfers by invoking +perform. + +TclCurl will then transfer data if there is anything available to transfer. +It'll use the callbacks and everything else we have setup in the individual +easy handles. It'll transfer data on all current transfers in the multi stack +that are ready to transfer anything. It may be all, it may be none. +

+When you call perform and the amount of Irunning handles is +changed from the previous call (or is less than the amount of easy handles +you added to the multi handle), you know that there is one or more +transfers less "running". You can then call getinfo to +get information about each individual completed transfer. +

+RETURN VALUE + +If everything goes well, it returns the number of running handles, '0' if all +are done. In case of error, it will return the error code. +

+  +

multiHandle active

+ +In order to know if any of the easy handles are ready to transfer data before +invoking +perform + +you can use the +active + +command, it will return the number of transfers currently active. +

+RETURN VALUE + +The number of active transfers or '-1' in case of error. +

+  +

multiHandle getinfo

+ +This procedure returns very simple information about the transfers, you +can get more detail information using the getinfo +command on each of the easy handles. +

+

+RETURN VALUE + +A list with the following elements: +

+
easyHandle about which the info is about.
+
state of the transfer, '1' if it is done.
+
exit code of the transfer, '0' if there was no error,...
+
Number of messages still in the info queue.
+
In case there are no messages in the queue it will return {"" 0 0 0}.
+

+

+  +

multiHandle cleanup

+ +This procedure must be the last one to call for a multi stack, it is the opposite of the +curl::multiinit + +procedure and must be called with the same +multiHandle + +as input as the +curl::multiinit + +call returned. +

+  +

multiHandle auto ?-command command?

+ +Using this command Tcl's event loop will take care of periodically invoking perform +for you, before using it, you must have already added at least one easy handle to +the multi handle. +

+The command option allows you to specify a command to invoke after all the easy +handles have finished their transfers, even though I say it is an option, the truth is +you must use this command to cleanup all the handles, otherwise the transfered files +may not be complete. +

+This support is still in a very experimental state, it may still change without warning. +Any and all comments are welcome. +

+You can find a couple of examples at tests/multi. +

+  +

curl::multistrerror errorCode

+ +This procedure returns a string describing the error code passed in the argument. +

+  +

SEE ALSO

+ +tclcurl, curl. + +

+ +

+ 

Index

+
+
NAME
+
SYNOPSIS
+
DESCRIPTION
+
Blocking
+
curl::multiinit
+
multiHandle addhandle ?easyHandle?
+
multiHandle removehandle ?easyHandle?
+
multiHandle configure
+
multiHandle perform
+
multiHandle active
+
multiHandle getinfo
+
multiHandle cleanup
+
multiHandle auto ?-command command?
+
curl::multistrerror errorCode
+
SEE ALSO
+
+
+This document was created by man2html, using the manual pages.
+ + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html new file mode 100644 index 00000000..8f3d8389 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html @@ -0,0 +1,112 @@ +Manpage of TclCurl + +

TclCurl

+Section: TclCurl share data api (3)
Updated: 03 October 2011
+ +  +

NAME

+TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP, +LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax. +  +

SYNOPSIS

+ +curl::shareinit + +

+shareHandle share ?data? + +

+shareHandle unshare ?data? + +

+shareHandle cleanup + +

+curl::sharestrerror errorCode + +

+

+  +

DESCRIPTION

+ +

+With the share API, you can have two or more 'easy' handles sharing data +among them, so far they can only share cookies and DNS data. +

+  +

curl::shareinit

+ +This procedure must be the first one to call, it returns a shareHandle +that you need to use to share data among handles using the -share option +to the configure command. The init MUST have a corresponding call to +cleanup when the operation is completed. +

+RETURN VALUE + +

+shareHandle to use. +

+  +

shareHandle share ?data?

+ +

+The parameter specifies a type of data that should be shared. This may be set +to one of the values described below: +

+

+
+
cookies + +
+Cookie data will be shared across the easy handles using this shared object. +

+

dns + +
+Cached DNS hosts will be shared across the easy handles using this shared object. +
+
+ +

+  +

shareHandle unshare ?data?

+ +This command does the opposite of share. The specified parameter will no +longer be shared. Valid values are the same as those for share. +

+  +

sharehandle cleanup

+ +

+Deletes a shared object. The share handle cannot be used anymore after this +function has been called. +

+  +

curl::sharestrerror errorCode

+ +Returns a string describing the error code passed in the argument. +

+  +

SEE ALSO

+ +curl, TclCurl + +

+ +

+ 

Index

+
+
NAME
+
SYNOPSIS
+
DESCRIPTION
+
curl::shareinit
+
shareHandle share ?data?
+
shareHandle unshare ?data?
+
sharehandle cleanup
+
curl::sharestrerror errorCode
+
SEE ALSO
+
+
+This document was created by man2html, using the manual pages.
+ + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl new file mode 100644 index 00000000..84c74113 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl @@ -0,0 +1,386 @@ +# +# Critcl - build C extensions on-the-fly +# +# Copyright (c) 2001-2007 Jean-Claude Wippler +# Copyright (c) 2002-2007 Steve Landers +# +# See http://wiki.tcl.tk/critcl +# +# This is the Critcl runtime that loads the appropriate +# shared library when a package is requested +# + +namespace eval ::critcl::runtime {} + +proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} { + # XXX At least parts of this can be done by the package generator, + # XXX like listing the Tcl files to source. The glob here allows + # XXX code-injection after-the-fact, by simply adding a .tcl in + # XXX the proper place. + set path [file join $dir [MapPlatform $mapping]] + set ext [info sharedlibextension] + set lib [file join $path $libname$ext] + set provide [list] + + # Now the runtime equivalent of a series of 'preFetch' commands. + if {[llength $args]} { + set preload [file join $path preload$ext] + foreach p $args { + set prelib [file join $path $p$ext] + if {[file readable $preload] && [file readable $prelib]} { + lappend provide [list load $preload];# XXX Move this out of the loop, do only once. + lappend provide [list ::critcl::runtime::preload $prelib] + } + } + } + + lappend provide [list load $lib $initfun] + foreach t $tsrc { + lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]" + } + lappend provide "package provide $package $version" + package ifneeded $package $version [join $provide "\n"] + return +} + +proc ::critcl::runtime::preFetch {path ext dll} { + set preload [file join $path preload$ext] + if {![file readable $preload]} return + + set prelib [file join $path $dll$ext] + if {![file readable $prelib]} return + + load $preload ; # Defines next command. + ::critcl::runtime::preload $prelib + return +} + +proc ::critcl::runtime::Fetch {dir t} { + # The 'Ignore' disables compile & run functionality. + + # Background: If the regular critcl package is already loaded, and + # this prebuilt package uses its defining .tcl file also as a + # 'tsources' then critcl might try to collect data and build it + # because of the calls to its API, despite the necessary binaries + # already being present, just not in the critcl cache. That is + # redundant in the best case, and fails in the worst case (no + # compiler), preventing the use o a perfectly fine package. The + # 'ignore' call now tells critcl that it should ignore any calls + # made to it by the sourced files, and thus avoids that trouble. + + # The other case, the regular critcl package getting loaded after + # this prebuilt package is irrelevant. At that point the tsources + # were already run, and used the dummy procedures defined in the + # critcl-rt.tcl, which ignore the calls by definition. + + set t [file join $dir tcl $t] + ::critcl::Ignore $t + uplevel #0 [list source $t] + return +} + +proc ::critcl::runtime::precopy {dll} { + # This command is only used on Windows when preloading out of a + # VFS that doesn't support direct loading (usually, a Starkit) + # - we preserve the dll name so that dependencies are satisfied + # - The critcl::runtime::preload command is defined in the supporting + # "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c" + + global env + if {[info exists env(TEMP)]} { + set dir $env(TEMP) + } elseif {[info exists env(TMP)]} { + set dir $env(TMP) + } elseif {[file exists $env(HOME)]} { + set dir $env(HOME) + } else { + set dir . + } + set dir [file join $dir TCL[pid]] + set i 0 + while {[file exists $dir]} { + append dir [incr i] + } + set new [file join $dir [file tail $dll]] + file mkdir $dir + file copy $dll $new + return $new +} + +proc ::critcl::runtime::MapPlatform {{mapping {}}} { + # A sibling of critcl::platform that applies the platform mapping + + set platform [::platform::generic] + set version $::tcl_platform(osVersion) + if {[string match "macosx-*" $platform]} { + # "normalize" the osVersion to match OSX release numbers + set v [split $version .] + set v1 [lindex $v 0] + set v2 [lindex $v 1] + incr v1 -4 + set version 10.$v1.$v2 + } else { + # Strip trailing non-version info + regsub -- {-.*$} $version {} version + } + foreach {config map} $mapping { + if {![string match $config $platform]} continue + set minver [lindex $map 1] + if {[package vcompare $version $minver] < 0} continue + set platform [lindex $map 0] + break + } + return $platform +} + +# Dummy implementation of the critcl package, if not present +if {![llength [info commands ::critcl::Ignore]]} { + namespace eval ::critcl {} + proc ::critcl::Ignore {args} { + namespace eval ::critcl::v {} + set ::critcl::v::ignore([file normalize [lindex $args 0]]) . + } +} +if {![llength [info commands ::critcl::api]]} { + namespace eval ::critcl {} + proc ::critcl::api {args} {} +} +if {![llength [info commands ::critcl::at]]} { + namespace eval ::critcl {} + proc ::critcl::at {args} {} +} +if {![llength [info commands ::critcl::cache]]} { + namespace eval ::critcl {} + proc ::critcl::cache {args} {} +} +if {![llength [info commands ::critcl::ccode]]} { + namespace eval ::critcl {} + proc ::critcl::ccode {args} {} +} +if {![llength [info commands ::critcl::ccommand]]} { + namespace eval ::critcl {} + proc ::critcl::ccommand {args} {} +} +if {![llength [info commands ::critcl::cdata]]} { + namespace eval ::critcl {} + proc ::critcl::cdata {args} {} +} +if {![llength [info commands ::critcl::cdefines]]} { + namespace eval ::critcl {} + proc ::critcl::cdefines {args} {} +} +if {![llength [info commands ::critcl::cflags]]} { + namespace eval ::critcl {} + proc ::critcl::cflags {args} {} +} +if {![llength [info commands ::critcl::cheaders]]} { + namespace eval ::critcl {} + proc ::critcl::cheaders {args} {} +} +if {![llength [info commands ::critcl::check]]} { + namespace eval ::critcl {} + proc ::critcl::check {args} {return 0} +} +if {![llength [info commands ::critcl::cinit]]} { + namespace eval ::critcl {} + proc ::critcl::cinit {args} {} +} +if {![llength [info commands ::critcl::clibraries]]} { + namespace eval ::critcl {} + proc ::critcl::clibraries {args} {} +} +if {![llength [info commands ::critcl::compiled]]} { + namespace eval ::critcl {} + proc ::critcl::compiled {args} {return 1} +} +if {![llength [info commands ::critcl::compiling]]} { + namespace eval ::critcl {} + proc ::critcl::compiling {args} {return 0} +} +if {![llength [info commands ::critcl::config]]} { + namespace eval ::critcl {} + proc ::critcl::config {args} {} +} +if {![llength [info commands ::critcl::cproc]]} { + namespace eval ::critcl {} + proc ::critcl::cproc {args} {} +} +if {![llength [info commands ::critcl::csources]]} { + namespace eval ::critcl {} + proc ::critcl::csources {args} {} +} +if {![llength [info commands ::critcl::debug]]} { + namespace eval ::critcl {} + proc ::critcl::debug {args} {} +} +if {![llength [info commands ::critcl::done]]} { + namespace eval ::critcl {} + proc ::critcl::done {args} {return 1} +} +if {![llength [info commands ::critcl::failed]]} { + namespace eval ::critcl {} + proc ::critcl::failed {args} {return 0} +} +if {![llength [info commands ::critcl::framework]]} { + namespace eval ::critcl {} + proc ::critcl::framework {args} {} +} +if {![llength [info commands ::critcl::include]]} { + namespace eval ::critcl {} + proc ::critcl::include {args} {} +} +if {![llength [info commands ::critcl::ldflags]]} { + namespace eval ::critcl {} + proc ::critcl::ldflags {args} {} +} +if {![llength [info commands ::critcl::license]]} { + namespace eval ::critcl {} + proc ::critcl::license {args} {} +} +if {![llength [info commands ::critcl::load]]} { + namespace eval ::critcl {} + proc ::critcl::load {args} {return 1} +} +if {![llength [info commands ::critcl::make]]} { + namespace eval ::critcl {} + proc ::critcl::make {args} {} +} +if {![llength [info commands ::critcl::meta]]} { + namespace eval ::critcl {} + proc ::critcl::meta {args} {} +} +if {![llength [info commands ::critcl::platform]]} { + namespace eval ::critcl {} + proc ::critcl::platform {args} {} +} +if {![llength [info commands ::critcl::preload]]} { + namespace eval ::critcl {} + proc ::critcl::preload {args} {} +} +if {![llength [info commands ::critcl::source]]} { + namespace eval ::critcl {} + proc ::critcl::source {args} {} +} +if {![llength [info commands ::critcl::tcl]]} { + namespace eval ::critcl {} + proc ::critcl::tcl {args} {} +} +if {![llength [info commands ::critcl::tk]]} { + namespace eval ::critcl {} + proc ::critcl::tk {args} {} +} +if {![llength [info commands ::critcl::tsources]]} { + namespace eval ::critcl {} + proc ::critcl::tsources {args} {} +} +if {![llength [info commands ::critcl::userconfig]]} { + namespace eval ::critcl {} + proc ::critcl::userconfig {args} {} +} + +# Define a clone of platform::generic, if needed +if {![llength [info commands ::platform::generic]]} { + namespace eval ::platform {} + proc ::platform::generic {} { + global tcl_platform + + set plat [string tolower [lindex $tcl_platform(os) 0]] + set cpu $tcl_platform(machine) + + switch -glob -- $cpu { + sun4* { + set cpu sparc + } + intel - + ia32* - + i*86* { + set cpu ix86 + } + x86_64 { + if {$tcl_platform(wordSize) == 4} { + # See Example <1> at the top of this file. + set cpu ix86 + } + } + ppc - + "Power*" { + set cpu powerpc + } + "arm*" { + set cpu arm + } + ia64 { + if {$tcl_platform(wordSize) == 4} { + append cpu _32 + } + } + } + + switch -glob -- $plat { + windows { + if {$tcl_platform(platform) eq "unix"} { + set plat cygwin + } else { + set plat win32 + } + if {$cpu eq "amd64"} { + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 + } + } + sunos { + set plat solaris + if {[string match "ix86" $cpu]} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } elseif {![string match "ia64*" $cpu]} { + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + darwin { + set major [lindex [split $tcl_platform(osVersion) .] 0] + if {$major > 19} { + set plat macos + } else { + set plat macosx + } + # Correctly identify the cpu when running as a 64bit + # process on a machine with a 32bit kernel + if {$cpu eq "ix86"} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } + } + aix { + set cpu powerpc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + hp-ux { + set plat hpux + if {![string match "ia64*" $cpu]} { + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + osf1 { + set plat tru64 + } + default { + set plat [lindex [split $plat _-] 0] + } + } + + return "${plat}-${cpu}" + } +} + + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/license.terms b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/license.terms new file mode 100644 index 00000000..6975e4c9 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/license.terms @@ -0,0 +1 @@ +<> diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl new file mode 100644 index 00000000..cdb609a9 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 9.0]} {return} +package ifneeded ankh 1.1 "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "ankh$ext"] ; load $lib Ankh ; ::critcl::runtime::Fetch $dir policy_1.tcl ; package provide ankh 1.1 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]" diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl new file mode 100644 index 00000000..6c7192de --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl @@ -0,0 +1,47 @@ +# -*- tcl -*- +## Ankh - Andreas Kupries Hashes +## (c) 2021-2024 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries + +# Generate the public ensemble structure from the low-level hash commands. + +# # ## ### ##### ######## ############# + +foreach hash { + aich + blake2b blake2s + btih + ed2k + edonr/224 edonr/256 edonr/384 edonr/512 + gost12/256 gost12/512 + gost94 + has160 + md4 + md5 + ripemd160 + sha1 + sha2/224 sha2/256 sha2/384 sha2/512 + sha3/224 sha3/256 sha3/384 sha3/512 + snefru/128 snefru/256 + tiger + tth + whirlpool +} { + namespace eval ::ak::hash [list namespace export $hash] + # All the aggregated commands are defined as cprocs and cconsts. + namespace eval ::ak::hash::${hash} { + namespace export path channel string size references + namespace ensemble create + } +} + +namespace eval ::ak::hash { + namespace export list version + namespace ensemble create +} +namespace eval ::ak { + namespace export hash + namespace ensemble create +} + +# # ## ### ##### ######## ############# +return diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/teapot.txt b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/teapot.txt new file mode 100644 index 00000000..cd2b1d9c --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/teapot.txt @@ -0,0 +1,17 @@ +Package ankh 1.1 +Meta platform win32-x86_64 +Meta build::date 2025-12-14 +Meta generated::by {critcl 3.3.1} ashok +Meta generated::date critcl +Meta require critcl::cutil +Meta license Under a BSD license. +Meta author {Andreas Kupries} +Meta summary Commands for using a variety of cryptographically secure +Meta summary hash functions +Meta description This package provides a number of commands giving +Meta description access to a variety of cryptographically secure hash +Meta description functions, old and new. +Meta subject hash {cryptographically secure hash} {secure hash} md4 md5 +Meta subject sha1 sha2 sha3 haval ripemd +Meta included tcl/policy_1.tcl critcl-rt.tcl win32-x86_64/ankh.dll +Meta entrytclcommand {eval "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "ankh$ext"] ; load $lib Ankh ; ::critcl::runtime::Fetch $dir policy_1.tcl ; package provide ankh 1.1 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll new file mode 100644 index 00000000..60046247 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/HSB.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/HSB.tcl new file mode 100644 index 00000000..49139b1f --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/HSB.tcl @@ -0,0 +1,202 @@ +package provide HSB 1.3 + +## HSB.tcl +## +## utilities for color processing +## RGB <--> HSB NOTE: HSB == HSV +## RGB <--> HSL +## HSBblend +## HSLblend +## +## +## This library is free software; you can use, modify, and redistribute it +## for any purpose, provided that existing copyright notices are retained +## in all copies and that this notice is included verbatim in any +## distributions. +## + +# HSB h s b ?a? --> 0xAARRGGBB +# RGB2HSB 0xAARRGGBB --> { h s b a } +# HSBblend {h1 s1 b1 ?a1?} {h2 s2 b2 ?a2?} --> {h s b a} +# +# HSL h s l ?a? --> 0XAARRGGBB +# RGB2HSL 0xAARRGGBB --> { h s l a } +# HSLblend {h1 s1 l1 ?a1?} {h2 s2 l2 ?a2?} --> {h s l a} + + # General info + # + # h (hue) is a 0.0..360.0 angle + # s (saturation) is 0.0 .. 1.0 + # b (brigthess) is 0.0 .. 1.0 ( 0 is black, 1 is white ) + # + # alpha is 0.0 .. 1.0 + +namespace eval HSx { + namespace export \ + HSB RGB2HSB HSBblend\ + HSL RGB2HSL HSLblend + + + # hue: any angle in degrees (internally normalized to 0.0..360) + # sat: 0.0 .. 1.0 + # brigthness: 0.0 .. 1.0 + # + # returns: + # a 32bit ARGB color as 0xAARRGGBB + + proc HSB {hue sat val {alpha 1.0}} { + set alpha [expr {round($alpha*255.0)}] + set v [expr {round(255.0*$val)}] + if {$sat == 0.0} { + return [expr {$alpha<<24 | $v<<16 | $v<<8 | $v}] + } + while { $hue < 0 } { + set hue [expr {$hue+360.0}] + } + set hue [expr {fmod($hue,360.0)}] + set hueSector [expr {$hue/60.0}] ;# result is 0.0...5.999 + set i [expr {int($hueSector)}] + set f [expr {$hueSector-$i}] + set p [expr {round(255.0*$val*(1 - $sat))}] + set q [expr {round(255.0*$val*(1 - ($sat*$f)))}] + set t [expr {round(255.0*$val*(1 - ($sat*(1 - $f))))}] + switch $i { + 0 {return [expr {$alpha<<24 | $v<<16 | $t<<8 | $p}]} + 1 {return [expr {$alpha<<24 | $q<<16 | $v<<8 | $p}]} + 2 {return [expr {$alpha<<24 | $p<<16 | $v<<8 | $t}]} + 3 {return [expr {$alpha<<24 | $p<<16 | $q<<8 | $v}]} + 4 {return [expr {$alpha<<24 | $t<<16 | $p<<8 | $v}]} + 5 {return [expr {$alpha<<24 | $v<<16 | $p<<8 | $q}]} + } + } + + # input is + # a 32bit ARGB color as 0xAARRGGBB + # + # returns a list { hue sat brightness alpha } + # hue: 0.0 .. 360.0 + # sat: 0.0 .. 1.0 + # brightness: 0.0 .. 1.0 + # alpha: 0.0 .. 1.0 + proc RGB2HSB { aarrggbb } { + set alpha [expr {$aarrggbb>>24 & 0xFF}] + set red [expr {$aarrggbb>>16 & 0xFF}] + set green [expr {$aarrggbb>>8 & 0xFF}] + set blue [expr {$aarrggbb & 0xFF}] + + if {$red > $green} { + set max $red + set min $green + } else { + set max $green + set min $red + } + if {$blue > $max} { + set max $blue + } else { + if {$blue < $min} { + set min $blue + } + } + set range [expr {double($max-$min)}] + if {$max == 0.0} { + set sat 0.0 + } else { + set sat [expr {$range/$max}] + } + if {$sat == 0.0} { + set hue 0.0 + } else { + set rc [expr {($max - $red)/$range}] + set gc [expr {($max - $green)/$range}] + set bc [expr {($max - $blue)/$range}] + if {$red == $max} { + set hue [expr {60.0*($bc - $gc)}] + } else { + if {$green == $max} { + set hue [expr {60*(2 + $rc - $bc)}] + } else { + set hue [expr {.166667*(4 + $gc - $rc)}] + } + } + if {$hue < 0.0} { + set hue [expr {$hue + 360.0}] + } + } + return [list $hue $sat [expr {$max/255.0}] [expr {$alpha/255.0}]] + } + + # --- Color interpolation in HSB color space + + # h is a float number .. should be normalized in 0..360 + # normalize 90 --> 90.0 + # normalize 721.1 -> 1.1 + # normalize -90 -> 270.0 + # normalize -721.1 -> 358.9 + proc normalize360 {h} { + set h [expr {fmod($h,360)}] + while { $h < 0 } { + set h [expr {fmod($h+360,360)}] + } + return $h + } + + proc clamp {v a b} { expr {$v<$a ? $a : ($v<$b ? $v :$b)} } + proc lerp {x0 x1 t} { expr {$x0+($x1-$x0)*$t} } + + # t must be [0...1] + proc lerpHue { h1 h2 t } { + set h1 [normalize360 $h1] + set h2 [normalize360 $h2] + # NOTE: Calculate the shortest arc between h1 and h2 + set delta_h [expr {$h2 - $h1}] + if {$delta_h > 180} { + set delta_h [expr {$delta_h - 360}] + } elseif {$delta_h < -180} { + set delta_h [expr {$delta_h + 360}] + } + set h [expr {$h1 + $t * $delta_h}] + set h [normalize360 $h] + return $h + } + + proc HSBblend {hsb1 hsb2 t} { + set hsb {} + set t [clamp $t 0 1] + lassign $hsb1 h1 s1 b1 a1 + if {$a1 ==""} { set a1 1.0 } + lassign $hsb2 h2 s2 b2 a2 + if {$a2 ==""} { set a2 1.0 } + return [list [lerpHue $h1 $h2 $t] [lerp $s1 $s2 $t] [lerp $b1 $b2 $t] [lerp $a1 $a2 $t]] + } + + + # --- HSL ----------------------------------------------------------------- + + proc HSL {h s l {alpha 1.0}} { + set v [expr {$l+$s*min($l,1-$l)}] + set sat [expr {$v==0 ? 0.0 : 2*(1-$l/$v)}] + HSB $h $sat $v $alpha + } + + # input is + # a 32bit ARGB color as 0xAARRGGBB + # + # returns a list { hue sat lightness alpha } + # hue: 0.0 .. 360.0 + # sat: 0.0 .. 1.0 + # lightness: 0.0 .. 1.0 + # alpha: 0.0 .. 1.0 + proc RGB2HSL { aarrggbb } { + lassign [RGB2HSB $aarrggbb] hue sat val alpha + set l [expr {$val*(1-$sat/2.0)}] + set satL [expr {($l==0.0 || $l ==1.0) ? 0.0 : ($val-$l)/min($l,1-$l)}] + return [list $hue $satL $l $alpha] + } + + proc HSLblend {hsl1 hsl2 t} { + tailcall HSBblend $hsl1 $hsl2 $t + } +} + +namespace import HSx::* diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/Mtx.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/Mtx.tcl new file mode 100644 index 00000000..caeb7bd2 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/Mtx.tcl @@ -0,0 +1,242 @@ +# extracted from https://wiki.tcl-lang.org/page/Affine+transforms+on+a+canvas + +# Affine Matrices +# Affine transformations on 2D, can be performed with some particular 3x3 matrices, +# here called Affine Matrices. +# An Affine Matrix is a 3x3 matrix whose last column is fixed 0 0 1 +# a b 0 +# c d 0 +# e f 1 +# Given this rule it is convenient to express such matrices as a list of 6 numbers +# { a b c d e f } instead of 9 numbers. + + +namespace eval Mtx {} + +proc Mtx::identity {} {list 1 0 0 1 0 0} + + # --------------------------------------------------------------------------- + # Basic operations: + # MxM: Matrix x Matrix x ... --> Matrix + # determinant Matrix --> number + # invert Matrix --> Matrix (or error) + + # PxM: Point x Matrix --> Point + # multiPxM: ListOfPoints x Matrix --> ListOfPoints + # P-P: Point - Point --> Vector + # VxM: Vector x Matrix --> Vector + # --------------------------------------------------------------------------- + +proc Mtx::MxM {M1 M2} { + lassign $M1 a00 a01 a10 a11 a20 a21 + lassign $M2 b00 b01 b10 b11 b20 b21 + list \ + [expr {$a00*$b00+$a01*$b10}] [expr {$a00*$b01+$a01*$b11}] \ + [expr {$a10*$b00+$a11*$b10}] [expr {$a10*$b01+$a11*$b11}] \ + [expr {$a20*$b00+$a21*$b10+$b20}] [expr {$a20*$b01+$a21*$b11+$b21}] +} + +proc Mtx::determinant {M} { + lassign $M m00 m01 m10 m11 m20 m21 + expr {double($m00*$m11-$m01*$m10)} +} + +proc Mtx::invert {M} { + set d [determinant $M] + if { $d == 0.0 } { + error "Matrix is not invertible" + } + lassign $M m00 m01 m10 m11 m20 m21 + set t00 [expr {$m11/$d}] + set t01 [expr {-$m01/$d}] + set t10 [expr {-$m10/$d}] + set t11 [expr {$m00/$d}] + + list \ + $t00 $t01 \ + $t10 $t11 \ + [expr {-($m20*$t00+$m21*$t10)}] [expr {-($m20*$t01+$m21*$t11)}] +} + + # map a Point +proc Mtx::PxM {P M} { + lassign $P px py + lassign $M m00 m01 m10 m11 m20 m21 + + list [expr {$px*$m00+$py*$m10+$m20}] [expr {$px*$m01+$py*$m11+$m21}] +} + + # map a list of Points +proc Mtx::multiPxM {Points M} { + lassign $M m00 m01 m10 m11 m20 m21 + + set L {} + foreach P $Points { + lassign $P px py + lappend L [list [expr {$px*$m00+$py*$m10+$m20}] [expr {$px*$m01+$py*$m11+$m21}]] + } + return $L +} + + # get the vector from A to B (A-B) +proc Mtx::P-P {A B} { + set V {} + foreach a $A b $B { + lappend V [expr {$a-$b}] + } + return $V +} + + # mapVector + # VxM(v,M) = PxM(v,M)-PxM(0,M) +proc Mtx::VxM {V M} { + lassign $V vx vy + lassign $M m00 m01 m10 m11 m20 m21 + + list [expr {$vx*$m00+$vy*$m10}] [expr {$vx*$m01+$vy*$m11}] +} + + # --------------------------------------------------------------------------- + # Basic Matrices: + # identity --> Matrix + # translation dx dy --> Matrix + # scale sx ?sy? ?Point? --> Matrix + # rotation alfa ?degrees|radians? ?Point? --> Matrix + # skew sx sy --> Matrix + # xreflection --> Matrix + # yreflection --> Matrix + # --------------------------------------------------------------------------- + + +proc Mtx::translation {dx dy} {list 1 0 0 1 $dx $dy} + +# scale sx sy around point C +# fixed-point invariant: C x T = C +proc Mtx::scale { sx {sy {}} {C {}} } { + if {$sy eq {}} {set sy $sx} + if { $C eq {} } { + # C = (0 0), hence just a scale + set T [list $sx 0 0 $sy 0 0] + } else { + lassign $C cx cy + set T [list \ + $sx 0 \ + 0 $sy \ + [expr {$cx*(1-$sx)}] [expr {$cy*(1-$sy)}] \ + ] + } + return $T +} + +set Mtx::PI [expr {acos(-1)}] + +# fixed-point invariant: C x T = C +proc Mtx::rotation {angle {units radians} {C {0 0}}} { + switch -- $units { + degree - degrees { + variable PI + set angle [expr {double($angle)/180*$PI}] + } + radian - radians { + # Do nothing + } + default { + return -code error "unknown angle unit \"$units\": must be degree(s) or radian(s)" + } + } + set sinA [expr {sin($angle)}] + set cosA [expr {cos($angle)}] + if { $C eq {} } { set C {0 0} } + lassign $C cx cy + list \ + $cosA $sinA \ + [expr {-$sinA}] $cosA \ + [expr {$cx-$cosA*$cx+$sinA*$cy}] [expr {$cy-$sinA*$cx-$cosA*$cy}] +} + +proc Mtx::skew {sx sy} {list 1 $sx $sy 1 0 0} + +# fixed-point invariant: {x0 0} x T = {x0 0} +proc Mtx::xreflection {{x0 0.0}} {list -1 0 0 1 [expr {2*$x0}] 0} + +# fixed-point invariant: {0 y0} x T = {0 y0} +proc Mtx::yreflection {{y0 0.0}} {list 1 0 0 -1 0 [expr {2*$y0}]} + + # --------------------------------------------------------------------------- + # Composite transformations + # + # common transformation like + # apply a (pre/post)translation to the current matrix + # apply a (pre/post)rotation to the current matrix + # could be easily written as: + # + # # (pre) translate current matrix + # MxM [translation $dx $dy] $M + # + # # (post) translate current matrix + # MxM $M [translation $dx $dy] + # + # ... and so on ... + # + # here some explicit common composite operations: + # translate M dx dy --> Matrix + # post_translate M dx dy --> Matrix + # scaling M sx sy ?Point? --> Matrix + # post_scaling M sx sy ?Point? --> Matrix + + # rotate M angle degrees!radians ?Point? --> Matrix + # post_rotate M angle degrees!radians ?Point? --> Matrix + + # --------------------------------------------------------------------------- + + # (pre)translate +proc Mtx::translate {M dx dy} { + # eqq Mtx::MxM [Mtx::translation $dx $dy] $M + lassign $M m00 m01 m10 m11 m20 m21 + list \ + $m00 $m01 \ + $m10 $m11 \ + [expr {$dx*$m00+$dy*$m10+$m20}] [expr {$dx*$m01+$dy*$m11+$m21}] +} + +proc Mtx::post_translate {M dx dy} { + # eqq Mtx::MxM $M [Mtx::translation $dx $dy] + lassign $M m00 m01 m10 m11 m20 m21 + list \ + $m00 $m01 \ + $m10 $m11 \ + [expr {$dx+$m20}] [expr {$dy+$m21}] +} + + + # (pre)scaling + # C is the fixed point +proc Mtx::scaling { M sx sy {Cxy {0 0}} } { + MxM [scale $sx $sy $Cxy] $M +} + + # (post)scaling +proc Mtx::post_scaling { M sx sy {Cxy {0 0}} } { + MxM $M [scale $sx $sy $Cxy] +} + + +proc Mtx::rotate {M angle units {Cxy {0 0}}} { + MxM [rotation $angle $units $Cxy] $M +} + +proc Mtx::post_rotate {M angle units {Cxy {0 0}}} { + MxM $M [rotation $angle $units $Cxy] +} + +proc Mtx::yreflect {M {y0 0.0}} { + # note: it's a post-transformation + MxM $M [yreflection $y0] +} + +proc Mtx::xreflect {M {x0 0.0}} { + # note: it's a post-transformation + MxM $M [xreflection $x0] +} + +package provide Mtx 1.1 diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/SVGpath.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/SVGpath.tcl new file mode 100644 index 00000000..e9ab09a9 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/SVGpath.tcl @@ -0,0 +1,224 @@ + # + # parse SVG-Path "d" sequence + # + # Usage: + # SVGpath::init "M10-5,1e-1-2 q7-3.1 4 2zl1,2,3,4,5,6Z" + # SVGpath::getCmdArgs + # --> M {10 -5 0.01 2} + # . + # .. repeat SVGpath::getCmdAndArgs until it return {} (or raise an error) + + +namespace eval SVGpath { + variable G ; # array holding the all the 'globals' of the current module + + #-------------------------------------- + # constants + #-------------------------------------- + set G(RE_FLAG) { + \A + [01] + } + set G(RE_FLOAT) { + \A + [-+]? (?: [0-9]* \.? [0-9]+ | [0-9]+ \.? ) (?:[eE][-+]?[0-9]+)? + } + set G(FLOAT_INIT_SYMBOLS) "+-0123456789.eE" + + set G(RE_WHITES) { + \A + [[:space:]]* + } + set G(RE_WHITES_OR_COMMA) { + \A + [[:space:]]* ,? [[:space:]]* + } + + set G(PATHDATA_CMDS) "mMlLqQcChHvVsStTaAzZ" + + #-------------------------------------- + # scanner status + #-------------------------------------- + set G(STR) {} ;# string to scan + set G(CH) {} ;# current character (EndOfString is "") + set G(IDX) 0 ;# current scan index + + proc init {str} { + variable G + set G(STR) $str + set G(IDX) 0 + set G(CH) [string index $str 0] + } + + # advance the scan cursor of n chars + # on EndOfString CH is {} + proc _NEXT { {n 1} } { + variable G + set G(CH) [string index $G(STR) [incr G(IDX) $n]] + } + + proc _Scan {regexp} { + variable G + set strings [regexp -inline -start $G(IDX) -expanded $regexp $G(STR)] + set str [lindex $strings 0] + set nc [string length $str] + if { $nc > 0 } { _NEXT $nc } + return $str + } + + + # returns 1 (true) if ch is in validChars , else 0 (false) + # (( just an syntactic sugar around [string first ..] )) + proc _CharMatch { ch validChars } { + expr {[string first $ch $validChars] >= 0} + } + + proc _SkipWhites {} { + variable G + _Scan $G(RE_WHITES) + return + } + + + proc _SkipWhitesOrComma {} { + variable G + _Scan $G(RE_WHITES_OR_COMMA) + return + } + + proc _GetFlag {} { + variable G + set numStr [_Scan $G(RE_FLAG)] + if { $numStr eq "" } { + error "expected a flag (0 or 1) at pos $G(IDX)" + } + return [expr {$numStr+0}] ; #convert to number + } + + # return the scanned floating-point number + # or raise an error + # ASSERT: [_CharMatch $G(CH) $G(FLOAT_INIT_SYMBOLS)] + proc _GetFloat {} { + variable G + set numStr [_Scan $G(RE_FLOAT)] + if { $numStr eq "" } { + error "expected a number at pos $G(IDX)" + } + return [expr {$numStr+0.0}] ; #convert to number + } + + # return the scanned number-pair + # or raise an error + # ASSERT: [_CharMatch $G(CH) $G(FLOAT_INIT_SYMBOLS)] + proc _GetFloatPair {} { + set n1 [_GetFloat] + _SkipWhitesOrComma + set n2 [_GetFloat] ;# raise an errorif not found ... + ## if { $n2 == {} } + return [list $n1 $n2] + } + + proc _GetSequenceOfFloats {} { + variable G + set L {} + _SkipWhites + while { [_CharMatch $G(CH) $G(FLOAT_INIT_SYMBOLS)] } { + lappend L [_GetFloat] + _SkipWhitesOrComma + } + return $L + } + + # raise an error if the number of parameters in $argList + # is not valid for command $cmd + proc _CheckCmdArgs {pos cmd argList} { + incr pos -1 ; global position of the last scanned char + # no diff between uppercase and lowercase commands + set cmd [string toupper $cmd] + # command is just 1 char + set n [llength $argList] + if { [_CharMatch $cmd "MLT"] } { + # requires k pairs (i.e. 2*k numbers) + if { $n==0 || $n % 2 != 0 } { + error "command \"$cmd\" ending at position $pos requires k pairs of numbers" + } + } elseif { [_CharMatch $cmd "QS"] } { + # requires 2*k pairs (i.e. 2*2*k numbers) + if { $n==0 || $n % 4 != 0 } { + error "command \"$cmd\" ending at position $Gpos requires 2*k pairs of numbers" + } + } elseif { [_CharMatch $cmd "C"] } { + # requires 3*k pairs (i.e. 2*3*k numbers) + if { $n==0 || $n % 6 != 0 } { + error "command \"$cmd\" ending at position $pos requires 3*k pairs of numbers" + } + } elseif { [_CharMatch $cmd "HV"] } { + # requires k>0 numbers + if { $n==0 } { + error "command \"$cmd\" ending at position $pos requires at least one number" + } + } elseif { [_CharMatch $cmd "A"] } { + # requires k*7 numbers + # require k*( 3 floats, 2 flags, 2 floats ) + if { $n==0 || $n % 7 != 0 } { + error "command \"$cmd\" ending at position $pos requires 7*k pairs of numbers" + } + } elseif { [_CharMatch $cmd "Z"] } { + # requires 0 numbers + if { $n>0 } { + error "command \"$cmd\" ending at position $pos requires no parameters" + } + } else { + error "unknown command \"$cmd\" ending at position $pos" + } + return + } + + # return a two element list: + # 1st elem is the cmd (e.g. "M" ,"m", "Q" ..) + # 2nd elem is a list with all the numeric ... parameters + # may raise errors + # .. invalid token or wrong number of parameters (depending on cmd) + # on EndOfString return {} + proc getCmdAndArgs {} { + variable G + + _SkipWhites + if { $G(CH) == "" } return [list ] ;# end of string found, return empty list + + if { ! [_CharMatch $G(CH) $G(PATHDATA_CMDS)] } { + error "expected a Path-Data command at pos $G(IDX), found \"$G(CH)\"" + } + set cmd $G(CH) ; _NEXT + if { $cmd in {A a} } { + set L [_getCmdA_Args] + } else { + set L [_GetSequenceOfFloats] + } + _CheckCmdArgs $G(IDX) $cmd $L ;# may raise an error + return [list $cmd $L] + } + + # special processing for "A" cmd + # require k*( 3 floats, 2 flags, 2 floats ) + proc _getCmdA_Args {} { + variable G + set L {} + _SkipWhites + while { [_CharMatch $G(CH) $G(FLOAT_INIT_SYMBOLS)] } { + foreach i {1 2 3} { + lappend L [_GetFloat] + _SkipWhitesOrComma + } + foreach i {1 2} { + lappend L [_GetFlag] + _SkipWhitesOrComma + } + foreach i {1 2} { + lappend L [_GetFloat] + _SkipWhitesOrComma + } + } + return $L + } +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/Road_Rage-License.txt b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/Road_Rage-License.txt new file mode 100644 index 00000000..67e0c53d --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/Road_Rage-License.txt @@ -0,0 +1,17 @@ + +« Road Rage » font by Youssef Habchi © 2016. +V.1.0 +_____________________________________________________________________________ + + +This font is free for PERSONAL USE ONLY. + +If you would like to use it commercially, contact me at contact@youssef-habchi.com to get a commercial license. + +Thank you. + +_____________________________________________________________________________ + +contact@youssef-habchi.com + +http://youssef-habchi.com diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/_Readme.txt b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/_Readme.txt new file mode 100644 index 00000000..e69de29b diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/images/Ghostscript_Tiger.svg b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/images/Ghostscript_Tiger.svg new file mode 100644 index 00000000..679edec2 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/images/Ghostscript_Tiger.svg @@ -0,0 +1,725 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/images/texture.jpeg b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/images/texture.jpeg new file mode 100644 index 00000000..f1f04354 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/images/texture.jpeg differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample01.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample01.tcl new file mode 100644 index 00000000..5d567f1f --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample01.tcl @@ -0,0 +1,20 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample01 - demo + +package require Blend2d +set sfc [image create blend2d -format {480 480} ] +label .x -image $sfc ; pack .x + +$sfc clear + +set gpath [BL::Path new] +$gpath moveTo {26 31} +$gpath cubicTo {642 132} {587 -136} {25 464} +$gpath cubicTo {882 404} {144 267} {27 31} + +$sfc fill $gpath -fill.style 0xFFFFFFFF + +$gpath destroy + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample016-tigerSVG.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample016-tigerSVG.tcl new file mode 100644 index 00000000..f543816c --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample016-tigerSVG.tcl @@ -0,0 +1,98 @@ +# +# Blend2d - Tiger demo +# using BL::Svgdoc +# + +package require Blend2d + +set thisDir [file normalize [file dirname [info script]]] + + +# doPaint +# use global parameters: +# TigerSVG : the BL::Svgdoc instance +# TigerRect : the bounding box (..rect!) of TigerSVG +# SFC : the BL::Surface +# ZOOM ZOOM is relative to the window (i.e. ZOOM 0.5 -> half window size) +# ANGLE ANGLE in degrees +proc doPaint {args} { + # ignore any arg (added by trace or by widgets callbacks..) + global SFC + global ZOOM + global ANGLE + global TigerSVG + global TigerRect + + lassign [$SFC size] WIDTH HEIGHT + + $SFC clear -style 0xFFCD0532 + +$SFC push + $SFC configure -matrix [Mtx::translation [expr {$WIDTH/2}] [expr {$HEIGHT/2}]] + + lassign $TigerRect _ _ tdx tdy + set s [expr {min( $WIDTH/$tdx , $HEIGHT/$tdy) * $ZOOM}] + + $SFC applyTransform [Mtx::scale $s] + $SFC applyTransform [Mtx::rotation $ANGLE degrees] + + $SFC paint $TigerSVG -anchor CENTER +$SFC pop +} + +proc BBoxToRect {bbox} { + lassign $bbox x0 y0 x1 y1 + return [list $x0 $y0 [expr {$x1-$x0}] [expr {$y1-$y0}]] +} + +proc ttkScaleWithLabel {w -label labelTxt args} { + frame $w + label $w.label -text $labelTxt + ttk::scale $w.scale {*}$args + pack $w.label $w.scale +} + +# == MAIN ===== +wm title . "\"Blend2d\" high performance 2D vector graphics engine - TclTk bindings" + +set ANGLE 0.0 ;# degrees +set ZOOM 1.0 + +set SFC [image create blend2d -format {500 500}] + + # WARNING: remove any decoration from the container, or the handler will resize the image indefinitely ! +label .cvs -image $SFC -borderwidth 0 -padx 0 -pady 0 +frame .controls + +.controls configure -width 200 -pady 20 -padx 10 +pack .controls -side left -expand 0 -fill y +pack propagate .controls false + +pack .cvs -expand 1 -fill both + + # these scale-widgets simply set the global vars ANGLE and ZOOM; + # These variable are traced, so that each change will trigger a doPaint +ttkScaleWithLabel .controls.rotate -label Rotate -from 0 -to 360 -orient horizontal -variable ANGLE +ttkScaleWithLabel .controls.zoom -label Zoom -from 0.1 -to 8.0 -orient horizontal -variable ZOOM +foreach w [winfo children .controls] { + pack $w +} + +trace add variable ANGLE write doPaint +trace add variable ZOOM write doPaint + +bind .cvs { + set w %w + set h %h + $SFC reset + $SFC configure -format [list $w $h] + doPaint +} + + # ---------------------------------------------------------------- + + # load the tiger-data +set TigerSVG [BL::Svgdoc new $thisDir/images/Ghostscript_Tiger.svg] +set TigerRect [BBoxToRect [$TigerSVG bbox]] + +doPaint diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample02.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample02.tcl new file mode 100644 index 00000000..26c73265 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample02.tcl @@ -0,0 +1,14 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample02 - demo + +package require Blend2d + +set sfc [image create blend2d -format {480 480} ] +label .x -image $sfc ; pack .x + +$sfc clear + +set gradient [BL::gradient LINEAR {0 0 0 480} {0.0 0xFFFFFFFF 0.5 0xFF5FAFDF 1.0 0xFF2F5FDF}] +$sfc fill [BL::roundrect 40 40 400 400 45.5] -fill.style $gradient -compop SRC_OVER diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample03.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample03.tcl new file mode 100644 index 00000000..fe8981e2 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample03.tcl @@ -0,0 +1,14 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample03 - demo + +package require Blend2d + +set sfc [image create blend2d -format {480 480} ] +label .x -image $sfc ; pack .x + +$sfc clear + +set pattern [BL::pattern $thisDir/texture.jpeg] +$sfc fill [BL::roundrect 40 40 400 400 45.5] -fill.style $pattern -compop SRC_OVER diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample04i.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample04i.tcl new file mode 100644 index 00000000..5baba5a5 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample04i.tcl @@ -0,0 +1,32 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample04i - demo + +package require Blend2d +set sfc [image create blend2d -format {480 480} ] +label .x -image $sfc ; pack .x +scale .sc -from 0 -to 360 -orient horizontal -command Paint +pack .sc + +proc Paint {angle} { + global sfc + global pattern + + $sfc fill all -fill.style [BL::color orange] -compop SRC_COPY + + $sfc configure -matrix [Mtx::rotation $angle degrees {240 240}] + + $sfc fill [BL::roundrect 50 50 380 380 80.5] -fill.style $pattern -compop SRC_OVER +} + +proc PaintInit {} { + global sfc + + $sfc fill all -fill.style 0xFF0000FF -compop SRC_COPY +} + + +set pattern [BL::pattern $thisDir/images/texture.jpeg] +PaintInit +Paint [.sc get] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample04ii.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample04ii.tcl new file mode 100644 index 00000000..3699c6ae --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample04ii.tcl @@ -0,0 +1,56 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample04ii - demo + +package require Blend2d + + # Note that we are going to paint the surface-image only; + # all the attached widget will be repainted +proc SfcPaint {sfc dummy} { + global ANGLE + global ZOOM + global pattern + + $sfc clear -style 0xFF000000 -compop SRC_COPY + + # Rotate and zoom around a point at [240, 240]. + set C {240 240} + set M [Mtx::rotation $ANGLE degrees $C] + set M [Mtx::MxM [Mtx::scale $ZOOM $ZOOM $C] $M ] + + # BE CAREFUL with blend2d 0.0.1: the order of options is important + # You should set -matrix before setting -style, + # or the texture won't be rotated! + $sfc fill [BL::roundrect 50 50 380 380 80.5] -matrix $M -style $pattern -compop SRC_OVER +} + +# === setup the GUI ========================================================== + +set sfc [image create blend2d -format {480 480}] +set pattern [BL::pattern $thisDir/images/texture.jpeg] + + # create a label-widget embedding this blend2d image +label .sfc -image $sfc +pack .sfc + +set ANGLE 0.0 +set ZOOM 1.0 +scale .srot -from 0 -to 360 -orient horizontal -label Rotate -variable ANGLE -command [list SfcPaint $sfc] +scale .szoom -from 0.1 -to 4.0 -resolution 0.1 -orient horizontal -label Zoom -variable ZOOM -command [list SfcPaint $sfc] +pack .srot .szoom -side left -expand 1 + + # create another window with a label-widget using the same blend2d image +toplevel .dup; label .dup.sfc -image $sfc +pack .dup.sfc + + #arrange the toplevels side by side +update +set X 200 +set Y 50 +wm geometry . +$X+$Y +incr X [winfo width .] +wm geometry .dup +$X+$Y + +SfcPaint $sfc dummy + \ No newline at end of file diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample05.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample05.tcl new file mode 100644 index 00000000..a9995632 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample05.tcl @@ -0,0 +1,18 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample04i - demo + +package require Blend2d + +set sfc [image create blend2d -format {480 480} ] +label .x -image $sfc ; pack .x + + +$sfc clear + +set grad1 [BL::gradient RADIAL {180 180 180 180 180} {0.0 0xFFFFFFFF 1.0 0xFFFF6f3F}] +$sfc fill [BL::circle {180 180} 160] -style $grad1 -compop SRC_OVER + +set grad2 [BL::gradient LINEAR {195 195 470 470} {0.0 0xFFFFFFFF 1.0 0xFF3F9FFF}] +$sfc fill [BL::roundrect 195 195 270 270 25] -style $grad2 -compop DIFFERENCE diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample06.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample06.tcl new file mode 100644 index 00000000..5a6ad73e --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample06.tcl @@ -0,0 +1,24 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample06 - demo + +package require Blend2d +set sfc [image create blend2d -format {480 480} ] +label .x -image $sfc ; pack .x + +$sfc clear + +set glinear [BL::gradient LINEAR {0 0 0 480} {0.0 0xFFFFFFFF 1.0 0xFF1F7FFF}] + +set gpath [BL::Path new] +$gpath moveTo {119 49} +$gpath cubicTo {259 29} {99 279} {275 267} +$gpath cubicTo {537 245} {300 -170} {274 430} + + +$sfc configure -stroke.style $glinear \ + -stroke.width 15 \ + -stroke.cap {ROUND BUTT} +$sfc stroke $gpath -compop SRC_OVER +$gpath destroy diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample07.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample07.tcl new file mode 100644 index 00000000..49acbeed --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample07.tcl @@ -0,0 +1,25 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample07 - demo + +package require Blend2d + +set sfc [image create blend2d -format {480 480} ] +label .x -image $sfc ; pack .x + + +$sfc clear +set fontFace [BL::FontFace new "$thisDir/Road_Rage.otf"] +set font [BL::Font new $fontFace 50.0] +$sfc configure -fill.style [BL::color gray90] +$sfc fill [BL::text {60 80} $font "Hello Blend2D"] + +$sfc fill [BL::text {150 80} $font "Rotated Text"] -matrix [Mtx::rotation 45 degrees] + +set smallFont [BL::Font new $fontFace 12.0] +$sfc fill [BL::text {200 460} $smallFont {Font: "Road Rage" by Youssef Habchi}] + +$font destroy +$smallFont destroy +$fontFace destroy diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample08.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample08.tcl new file mode 100644 index 00000000..d9d8f36f --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample08.tcl @@ -0,0 +1,23 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample08 - demo + +package require Blend2d 1.3.2 + +set sfc [image create blend2d -format {500 500} ] +label .x -image $sfc ; pack .x + + # move origin at the surface center +$sfc applyTransform [Mtx::translation 250 250] + +set stops {0.0 0xFFFFFFFF 0.5 0xFF5FAFDF 1.0 0xFFFFFFFF} + +set gradient [BL::gradient CONIC {0 0 0} $stops] +$sfc fill all -style $gradient + +set gradient [BL::gradient CONIC {0 0 0} $stops -matrix [Mtx::rotation 180 degrees]] +$sfc fill [BL::circle {0 0} 200] -style $gradient + +set gradient [BL::gradient CONIC {0 0 0 16} $stops] +$sfc fill [BL::circle {0 0} 100] -style $gradient diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample102.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample102.tcl new file mode 100644 index 00000000..35c11929 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/demo/sample102.tcl @@ -0,0 +1,220 @@ +set thisDir [file normalize [file dirname [info script]]] +set auto_path [linsert $auto_path 0 [file dirname $thisDir]] + +# --sample102 - cubicles + +package require Blend2d + + +wm title . "TclTk binding for Blend2d - Cubicles demo" +set sfc [image create blend2d -format {1000 1000} ] ;# a square sfc +label .x -image $sfc ; pack .x + + + # 3d conventions: + # XY plane is the vertical 'front plane' + # Z-axis is the depth + + # P is a 3d point ; M is a 3x2 mtx ; result is a 2d point +proc PxM { P M } { + + lassign $P px py pz + lassign $M m00 m01 m10 m11 m20 m21 + + list [expr {$px*$m00+$py*$m10+$pz*$m20}] [expr {$px*$m01+$py*$m11+$pz*$m21}] +} + +# dimetric transf - alpha, beta in degrees + +proc dimetricMatrix {alpha beta} { + set alpha [expr {$alpha*3.1415/180.0}] + set beta [expr {$beta*3.1415/180.0}] + + list \ + [expr {cos($alpha)}] [expr {-sin($alpha)}] \ + 0 1 \ + [expr {cos($beta)/2}] [expr {sin($beta)/2}] +} + + + # cube of size LxLxL . + # Origin placed in the center of the cube + + # XY is the font plane; Z is depth +proc precomputeCube {size} { + global Face ;# array + global FaceColor ; #array + + set Face3D(front) { {-1 -1 -1} {+1 -1 -1} {+1 +1 -1} {-1 +1 -1} } + set Face3D(back) { {-1 -1 +1} {+1 -1 +1} {+1 +1 +1} {-1 +1 +1} } + set Face3D(left) { {-1 -1 -1} {-1 -1 +1} {-1 +1 +1} {-1 +1 -1} } + set Face3D(right) { {+1 -1 -1} {+1 -1 +1} {+1 +1 +1} {+1 +1 -1} } + set Face3D(bottom) { {-1 -1 -1} {+1 -1 -1} {+1 -1 +1} {-1 -1 +1} } + set Face3D(top) { {-1 +1 -1} {+1 +1 -1} {+1 +1 +1} {-1 +1 +1} } + + #pale yellow + cubeColors 60 0.5 1.0 + # scale the 3D cube + foreach face [array names Face3D] { + set Q3s {} + foreach P3 $Face3D($face) { + set Q3 [lmap c $P3 { expr {$size/2.0*$c} }] + lappend Q3s $Q3 + } + set Face3D($face) $Q3s + } + + # apply the dimetric transformation + # from Face3D(..) to Face(..) + set M [dimetricMatrix 7 42] + foreach face [array names Face3D] { + set Face($face) {} + foreach P3 $Face3D($face) { + lappend Face($face) [PxM $P3 $M] + } + } +} + + +proc cubeColors { h s b } { + variable FaceColor + + foreach {face color} [list \ + front [HSB $h $s $b] \ + back [HSB $h $s $b] \ + left [HSB $h $s [expr {$b*0.7}]] \ + right [HSB $h $s [expr {$b*0.8}]] \ + top [HSB $h $s [expr {$b*0.9}]] \ + bottom [HSB $h $s [expr {$b*0.9}]] \ + ] { + set FaceColor($face) $color + } +} + +proc random {a b} { + expr {$a+($b-$a)*rand()} +} + +proc cube {sfc} { + variable Face + variable FaceColor + + $sfc push + + if { 3*rand() < 1.0 } { + set isTransparent true + $sfc configure -globalalpha 0.5 + + # trasparent cubes should be smaller.. + set M [$sfc cget -matrix] + set OXY [Mtx::PxM {0 0} $M] + $sfc configure -matrix [Mtx::post_scaling $M 0.93 0.93 $OXY] + + + set hue [random 100 180] + set frontColor [HSB $hue 1 0.8] + set rightColor [HSB $hue 1 0.6] + set topColor [HSB $hue 1 0.6] + + set lineColor [HSB $hue 0.2 0.8] + + } else { + set isTransparent false + $sfc configure -globalalpha 1.0 + set frontColor $FaceColor(front) + set rightColor $FaceColor(right) + set topColor $FaceColor(top) + # solid cubes should be a little bit (random) bigger .. + set M [$sfc cget -matrix] + set OXY [Mtx::PxM {0 0} $M] + set size [expr {1.0+(rand()*0.2)}] ; # 1.0 .. 1.2 + $sfc configure -matrix [Mtx::post_scaling $M $size $size $OXY] + + lassign [RGB2HSB $FaceColor(front)] h s b + # b lerp(b,1,30%) + set b [expr {$b+(1-$b)*0.3}] + set lineColor [HSB $h $s $b] + } + + if { $isTransparent } { + # draw the back faces + $sfc fill [BL::polygon {*}$Face(back)] -style $FaceColor(back) + $sfc fill [BL::polygon {*}$Face(left)] -style $FaceColor(left) + $sfc fill [BL::polygon {*}$Face(bottom)] -style $FaceColor(bottom) + } + # draw the front faces + $sfc fill [BL::polygon {*}$Face(top)] -style $topColor + $sfc fill [BL::polygon {*}$Face(right)] -style $rightColor + $sfc fill [BL::polygon {*}$Face(front)] -style $frontColor + + # stroke the front edges +# todo: avoid to stroke the edges twice (bad antialiasing) + + $sfc configure -stroke.style $lineColor ;#0xFF222222 + $sfc stroke [BL::polygon {*}$Face(top)] + $sfc stroke [BL::polygon {*}$Face(right)] + $sfc stroke [BL::polygon {*}$Face(front)] + $sfc pop +} + + +# ---------- main ----------------------------------------------------------- + + # precompute the projected faces of the cube +# ... to to .. split set Cube3d a precompute projections.. + +set DM [dimetricMatrix 7 42] + lassign [$sfc size] WX WY +set DX 88 ;# cube size + +precomputeCube $DX +$sfc clear +set OM [Mtx::translation [expr {$WX/2.0}] [expr {$WY/2.0}]] ; # origin at the center +set OM [Mtx::MxM [Mtx::yreflection] $OM] +$sfc configure -matrix $OM + +$sfc configure -stroke.width 1.0 + +proc cubeOfCubes {sfc WX DX} { + variable STOP + variable OM + variable DM + +set STOP false + # background + $sfc fill all -style [BL::gradient RADIAL [list 0 0 0 0 [expr {4.0/5.0*$WX}]] \ + [list 0 [HSB 120 1.0 0.6] 0.9 [HSB 120 1.0 0.2] ]] + + $sfc push + for {set z [expr {-$WX/5.0}]} {$z<=$WX/5.0*1.5} {set z [expr {$z+$DX}]} { + for {set y [expr {-$WX/5.0}]} {$y<=$WX/5.0} {set y [expr {$y+$DX}]} { + for {set x [expr {-$WX/5.0}]} {$x<=$WX/5.0} {set x [expr {$x+$DX}]} { + #.. every 10%, skip a cube ... + if { rand() <0.1 } continue + + $sfc configure -matrix [Mtx::translate $OM {*}[PxM [list $x $y [expr {-$z}]] $DM]] + cube $sfc + if { $STOP } return + # refresh the scene + after 10; update + } + } + } + + $sfc pop +} + +cubeColors 120 0.8 0.3 + +# repeat on every click +bind . { + set STOP true; + # NOTE: this is not a clever sync method , anyway ... + # we should wait until the running cubeOfCubes ends. + # Knowing that cubeOfCubes has a sleeping time of 10 ms, we must set a start-time after 11 ms + after 11 cubeOfCubes $sfc $WX $DX +} +set STOP false +cubeOfCubes $sfc $WX $DX + + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/docs/tclBlend2d.html b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/docs/tclBlend2d.html new file mode 100644 index 00000000..4389fe8b --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/docs/tclBlend2d.html @@ -0,0 +1,1646 @@ + + + +tclBlend2d - Tcl meets Blend2d + + + + + +
+

tclBlend2d(n) 1.5 tclBlend2d "Tcl meets Blend2d"

+

Name

+

tclBlend2d - Tcl meets Blend2d

+
+ +

Synopsis

+
+
    +
  • package require Tcl 8.6
    • +
  • package require Blend2d ?1.5?
    • +
+ +
+
+

Description

+

Package Blend2d integrates the Blend2d vector engine in Tcl/Tk.

+

Blend2d is an open source, high-quality, high-performance vector graphics engine.

+

Blend2d is a binary package, distributed in a multi-platform bundle, i.e. it can be used on

+
    +

  • Windows 64 bit

    • +

  • Linux 64 bit

    • +

  • MacOS 64 bit

    • +
+

Just an example to get the flavor of how to use Blend2d:

+
+    # draw a circle ...
+    package require Blend2d
+    set sfc [BL::Surface new]
+    $sfc clear
+    $sfc configure -fill.style [BL::color orange]
+    $sfc fill [BL::circle {150 150} 100]
+    $sfc save "./image01.bmp"
+    $sfc destroy
+
+
+

Blend2d with and without Tk

+

You can run Blend2d from a tclsh interpreter, without loading Tk. +The following command

+
+package require tclBlend2d
+
+

can be used in a tclsh interpreter to load the package without requiring Tk support. +You will be still able to generate and save images, but of course, some subcommands related to Tk won't be available.

+

The command

+
+package require tkBlend2d
+
+

loads the full package (and requires Tk).

+

Note that

+
+package require Blend2d
+
+

is equivalent to

+
+package require tkBlend2d
+
+
+

BL::Surface and the graphics state parameters

+

The main concept of Tcl-Blend2d is the Surface.

+

A Surface comes with an internal framebuffer (32bit depth, with alpha support) and holds all of the +graphics state parameters that describe how drawing is to be done. This includes parameters like the +current line width, the current color (or gradient), a 2D transformation matrix and many other things.

+

A Surface can be created with the following commands

+
+
BL::Surface create sfcName ?options?
+

creates a new instance of the class BL::Surface called sfcName. +Options can be set at creation time, or later with the configure method.

+
BL::Surface new ?options?
+

creates a new instance of the class BL::Surface returning a new unique sfcName. +Options can be set at creation time, or later with the configure method.

+
sfcName destroy
+

destroys sfcName. Note that in general any oo-object like sfcName should be explicitly destroyed

+
sfcName dup
+

duplicates sfcName. Return a new BL::Surface.

+

Note: the full stack of options is not duplicated; only the current options are duplicated.

+
BL::Surface names
+

returns the list of all the currently allocated surfaces.

+
+

The whole set of Surface's options is also called the drawing state.

+

A drawing state consists of

+
    +

  • the 2D transformations that have been applied (i.e. translate, rotate, and scale ... see below),

    • +

  • the current values of various attributes controlling how to fill and how to stroke all the basic + and complex geometric entities,

    • +
+

and it can be manipulated with the cget/configure methods.

+
+
sfcName configure
+

returns a list with all the valid options and their values.

+
sfcName cget optionName
+

returns the current value of the option optionName. +Raise an error if optionName is not a valid option.

+
sfcName configure optionName
+

returns a list with two values: the named option and its value. +Raise an error if optionName is not a valid option.

+
sfcName configure optionName optionValue ?optionName optionValue ...?
+

modifies all the named options with the specified values. +Raise an error if any optionName is not recognized or its optionValue is not valid; +in this case, no option is modified.

+

Surface options are:

+
+
-threads count
+

If count is >=1 then all the rendering commands are queued and executed by worker-threads + when needed (i.e. before exporting an image or, if the surface is a Tkimage, in the event-loop) + Default is 0 (i.e all the rendering commands are run immediately (synchronous mode)).

+
-format {dx dy {?PRGB32 | XRGB32?}}
+

sets the size (in pixels) and type of the internal framebuffer.

+

WARNING: When user sets a new -format, the previous content of the framebuffer is lost, + and the new framebuffer is uninitialized (it contains garbage). It is user's responsibility + to clean it or to properly restore the previous contents. + Default is {400 400 PRGB32}

+
-matrix matrix
+

matrix defines the affine transformations that will be applied to the next + geometric entities specified with the "fill" or "stroke" operations + See the section "Affine Matrix" for more details. + Default is {1.0 0.0 0.0 1.0 0.0 0.0} (Identity matrix)

+
-metamatrix
+

This is a readonly option.

+

Meta matrix is a core transformation matrix that is normally not changed by transformations applied to the context. +Instead, it acts as a secondary matrix used to create the final transformation matrix from meta and user matrices.

+

Meta matrix can be used to scale the whole context for HI-DPI rendering or to change the orientation of the image being rendered, + however, the number of use-cases is unlimited.

+

To change the meta-matrix you must first change user-matrix and then call the userToMeta method, +which would update meta-matrix and clear user-matrix.

+
-compop compositionOp
+

defines how colors should be blended. + For further details try googling "Porter-Duff composition" or "Alpha composition". + Default value is SRC_OVER.

+
-globalalpha alphaValue
+

defines a global alpha value. + alphaValue should be between 0.0 (transparent) and 1.0 (opaque). + Default value is 1.0

+
-fill.style style
+

defines the style to be used for filling. + style can be a solid-color (with alpha transparency), a gradient, or a pattern ... + Default is 0xFF000000 (Opaque Black).

+

See the "Setting a style" section below.

+
-fill.alpha alphaValue
+

defines the alpha value for fill operations. + alphaValue should be between 0.0 (transparent) and 1.0 (opaque). + Default value is 1.0

+
-fill.rule mode
+

defines how to fill intersecting curves. + Default is NON_ZERO

+
-stroke.style style
+

defines the style to be used for stroking. + style can be a solid-color (with alpha transparency), a gradient, or a pattern. + Default is 0xFF000000 (Opaque Black) + See above notes for -fill.style

+
-stroke.alpha alphaValue
+

defines the alpha value for stroke operations. + alphaValue should be between 0.0 (transparent) and 1.0 (opaque). + Default value is 1.0

+
-stroke.width width
+

defines the width of the strokes (outlines). + Default value is 1.0. + Note that the stroke width is scaled according to the current matrix transformation. + If you want a constant width, independent of the current scale factor, you should set + the option -stroke.transformorder to BEFORE.

+
-stroke.dashoffset offset
+

defines the offset on the rendering of the associated dash array. + Default is 0.0

+
stroke.join mode
+

defines how the junction point of two consecutive segments will be stroked. + Default is MITER_CLIP

+
-stroke.miterlimit value
+

defines the limit on the ratio of the miter length to the stroke-width used to draw a miter join. + When the limit is exceeded, the join is converted from a miter to a bevel. + Default is 4.0.

+
-stroke.cap capMode
+
+
-stroke.cap {startCap endCap}
+

capMode specifies how to render the extremities of the stroke. + capMode may be a list of two values to specify the startCap and the endCap separately. + Default is {BUTT BUTT}

+
-stroke.transformorder mode
+

With the default mode AFTER the stroke width will be scaled according to the current transformation matrix. + If mode is set to BEFORE, the stroke width won't be scaled.

+
+
+

The whole drawing-state can be stored on an internal stack, and you can inspect, +save, and restore the whole drawing state (i.e. all the options) with just the following commands:

+
+
sfcName push
+

saves the current graphic-state on an internal stack.

+
sfcName pop
+

pops the graphic-state from the stack. + Raise an error if stack is empty.

+
sfcName stacksize
+

returns the size of the internal stack (i.e. number of saved graphic-states)

+
sfcName reset
+

sets the whole surface's graphic-state, including the internal stack. + All the options (but -format and -threads) are reset to their default values.

+
+

Setting a style

+

There are 3 types of styles you can set for strokes and fills: + SOLID, GRADIENT, PATTERN

+
    +

  • A SOLID style is a uniform color (with optional alpha transparency). +It can be specified as a simple hex number in 0xAARRGGBB format, + 0xFFFF0000 is red, + 0xFF0000FF is blue, + or through the following utilities:

    +
    +
    BL::rgb RR GG BB ?alpha?
    +

    returns a 0xAARRGGBB color by combining the RR GG BB + and the (optional) alpha arguments.

    +

    RR, GG, BB are integers 0..255 (best expressed as 0x00..0xFF), + alpha is an optional parameter ranging from 0.0 (transparent) to 1.0 (opaque). + Default alpha is 1.0

    +
    BL::color colorName ?alpha?
    +

    returns a 0xAARRGGBB color by combining the colorName and the (optional) alpha arguments.

    +

    colorName is a color name (e.g "lightblue") or a numeric-color like #rrggbb, + alpha is an optional parameter ranging from 0.0 (transparent) to 1.0 (opaque). + Default alpha is 1.0

    +
    HSB hue sat brightness ?alpha?
    +

    This is an alternative way of specifying a color (HSB model).

    +
    HSL hue sat lightness ?alpha?
    +

    This is an alternative way of specifying a color (HSL model).

    +

    See the "HSB/HSL color models" section at the end for more details.

    +
    +
    • +

  • A GRADIENT can be specified with the following syntax:

    +
    + +
    BL::gradient type values stopList ?options?
    +
      + +

    • type should be one of the following values: LINEAR, RADIAL, CONIC

      • +

    • values is a list of parameters (depending on type)

      +
        + +

      • BL::gradient LINEAR {x0 y0 x1 y1} _stopList_ ?_options_?

        • +

      • BL::gradient RADIAL {x0 y0 x1 y1 radius} _stopList_ ?_options_?

        • +

      • BL::gradient CONIC {x0 y0 angle ?repeat?} _stopList_ ?_options_?

        • +
      +
      • +

    • stopList is a list of offset and colors (at least two pairs of offset colors)

      +
        + +

      • offset is a number between 0.0 and 1.0

        • +

      • color can be expressed as an hex number (0xAARRGGBB) or with the above cited + BL::rgb , BL::color, HSB, HSL commands.

        • +
      +
      • +

    • options are:

      +
      + +
      -mode extendMode
      +

      defines how to extend or repeat the style outside the defined region. + Default is PAD. + See command "BL::enum EXTEND_MODE" for valid values.

      +
      -matrix mtx
      +

      defines an auxiliary 2D transformation that should be combined with the + current transformation matrix.

      +
      +
      • +
    +
    +

    Gradient example:

    +
    +    # define an oblique LINEAR gradient
+    set gr1 [BL::gradient LINEAR  {0 0 400 400} \ 
+        [list  0.0 [BL::color lightblue]  0.8 [BL::color blue] 1.0 [BL::rgb 0 0 0 0.1]] \ 
+        ]
+    $sfc fill [BL::circle {200 200} 100] -style $gr1
+
    +
    • +

  • A PATTERN can be specified with the following syntax:

    +
    + +
    BL::pattern sfcName|filename ?options?
    +

    defines a pattern based on another source bitmap, i.e a SfcName, or an external JPEG,PNG,BMP,QOI filename.

    +

    Valid options are:

    +
    + +
    -mode extendMode
    +

    same as for BL::gradient

    +
    -matrix mtx
    +

    same as for BL::gradient

    +
    -from {x y w h}
    +

    defines the pattern based on a rectangular subregion of the srcBitmap. + x, y, w,h are pixel coords (integer coords)

    +
    +
    +
    • +
+
+

Geometric types

+

Blend2D provides both + simple geometric types ( line, rectangle, circle ....) + and complex geometric types (Path). +The main difference between simple and complex geometry types derives from their +implementation. +Although all the geometric types could be implemented as oo-classes, this will +tend to develop programs difficult to maintain, since in Tcl oo-objects should be +explicitly destroyed. +Therefore most of the following commands for building geometric types don't return oo-objects +but simple tcl-lists/dictionaries, that are automatically disposed when they go out of scope.

+

Currently, just two complex geometry-types (BL::Path and BL::Svgdoc) are implemented as oo-class, +(and then it's programmers's responsibility to explicitly destroy it).

+

A simple example for drawing a simple geometry is

+
+$sfcName fill [BL::box {0 0} {120 175.8}]
+
+

The supported simple-geometries are:

+
+ +
BL::line {x0 y0} {x1 y1}
+
+
BL::polyline {x0 y0} {x1 y1} ?{x2 y2} ....?
+
+
BL::polygon {x0 y0} {x1 y1} ?{x2 y2} ....?
+
+
BL::box {x0 y0} {x1 y1}
+
+
BL::rect x y w h
+
+
BL::roundrect x y w h rx ?ry?
+
+
BL::circle {cx cy} r
+
+
BL::ellipse {cx cy} rx ry
+
+
BL::arc {cx cy} rx ry start sweep
+
+
BL::pie {cx cy} rx ry start sweep
+
+
BL::chord {cx cy} rx ry start sweep
+
+
BL::text {x y} font text ?-anchor anchor? ?-justify mode?
+

The string text, is rendered using font and by default, its anchor-point x y +denotes the left-extremity of the text baseline.

+

Starting from tclBlend2d 1.5, text can contain multiple lines separated by "\n" (e.g. "Hello\nWorld\n!")

+

When text contains multiple lines, the -justify option determines how the lines are laid out relative to one another. +Must be one of LEFT, CENTER or RIGHT. LEFT means that the lines' left edges all line up, CENTER means that the lines' centers are aligned, and RIGHT means that the lines' right edges line up. +Default is LEFT.

+

The -anchor option controls which notable point of the text's bounding box will be anchored to xy. Possible values are:

+
    +alignment on the text baseline +

  • LEFT - anchor the left-extremity of the baseline to xy (DEFAULT)

    • +

  • MID - anchor the mid-point of the baseline to xy

    • +

  • RIGHT - anchor the right-extremity of the baseline to xy

    • +
+
    +alignment on the 8 cardinal points of the textbox +

  • N - anchor the North side of the textbox to xy

    • +

  • S - anchor the South side of the textbox to xy

    • +

  • W - anchor the West side of the textbox to xy

    • +

  • E - anchor the East side of the textbox to xy

    • +

  • NW - anchor the North-West corner of the textbox to xy

    • +

  • SW - anchor the South-West corner of the textbox to xy

    • +

  • NE - anchor the North-East corner of the textbox to xy

    • +

  • SE - anchor the South-East corner of the textbox to xy

    • +

  • CENTER - anchor the center of the textbox to xy

    • +
+
BL::textbox {x y} font text ?-anchor anchor? ?-justifys mode?
+

This geometry simply returns the BL::box of the text. +Arguments and options are the same of the above BL::text geometry: +text can also be a multiline string; in this case a simple layout is applied; option -justify is supported but it's ignored.

+
BL::spline ?-alpha a? ?mode? {x0 y0} {x1 y1} ?{x2 y2} ....?
+

A spline in its canonical form is a curve going through all its control points, but the first and the last. +The first and the last points are just used for defining the tangent of the first interpolated point (i.e. the second control point) +and the tangent of the last interpolated point (i.e. the second to last control point).

+

Option -alpha is 0.5 for the centripetal splines (default), 0.0 for the uniform splines, 1.0 for the chordal splines.

+

If mode is not specified, then this is a canonical representation and it requires at least 4 points.

+

If mode is extend, then the control points are implicitly extended by adding a first and last point. In this way, the spline goes through all its explicit control points.

+

If mode is close, then some control points are implicitly added, so that the spline becomes a closed curve. +Note that if mode is close, then the last explicit control point should not be equal to the first explicit control point.

+
+  ...
+  $sfc configure -stroke.style [BL::color yellow]
+ 
+   # a minimal canonical spline (4 points): the first and the last point are not drawn
+  $sfc stroke [BL::spline {0 0} {100 100} {300 100} {200 200}]
+ 
+   # an extended spline (3 points): all the 3 control points are interpolated
+  $sfc stroke [BL::spline extend {100 100} {300 100} {200 200}] 
+ 
+   # a minimal close spline (3 points)
+  $sfc stroke [BL::spline close {100 100} {300 100} {200 200}]
+   
+
+

Note: default splines (those with -alpha 0.5) are C1 cubic Catmull-Rom centripetal splines.

+
+

Note that all these commands defining simple geometry types start +with a lowercase letter. These commands do not create oo-objects; they simply +return a specially crafted list that should be passed to the fill/stroke methods. +These objects (lists/dictionaries!) don't require an explicit "destroy" method.

+

Other than simple geometries there are complex geometries like + BL::Path and BL::Svgdoc +and they will be described in the next sections.

+
+

Drawing on a surface

+
+
sfcName stroke geometry ?options?
+

draws the outline of the specified geometry, according to the current drawing-state. + Extra options listed after geometry are temporarily set just for this operation. + Note that some options like -stroke.width, -stroke.style, can be abbreviated + as -width, -style, and so on.

+

This method also accepts the option -transformation.

+
+ +
-transformation mtx
+

applies a temporary transformation to the current coordinate system.

+
+

Note that this is different from option -matrix; option -transformation applies a transformation mtx to the current coord-sys, + whilst options -matrix resets the current coord-sys and sets the mtx transformation.

+
sfcName fill all|geometry ?options?
+

draws (fills) the specified geometry, according to the current drawing-state. + The special geometry all means "the whole framebuffer". + Extra options listed after geometry are temporarily set just for this operation. + Note that within this fill operation, the option -fill.style can be abbreviated as -fill.

+

This method also accepts the option -transformation as for the stroke method.

+
sfcName paint svgName ?options?
+

this is a special method for drawing a complex svgName obtained by loading an SVG-file (see the BL::Svgdoc section). + By default the svgName is drawn accordling to the current transformation (i.e. the transformation matrix'), by aligning its origin + with the origin of the current coordinate-system. In this way, by properly pre-setting the coordinate system, + svgName can be placed at any point of the surface, scaled and rotated.

+

This method returns the trasformation matrix applied over the current coordinate-system for translating&scaling the SVG-image.

+

Extra options can be specified for automatic scaling or aligning other notable control points....

+
+ +
-at point
+

The anchor point of the surface is translated by point {dx dy}. This displacement is applied relatively to the current coordinate systemapplies. Default is {0 0}

+
-anchor anchorSpec
+

anchorSpec is one of N,S,W,E,NE,NW,SE,SW,CENTER or NONE. (Default is NONE) + With this parameter, one of these notable points of the bounding-box of svgDoc, is aligned + with the origin of the coordinate-system, or better, with the surface's anchor point specified with the above -at option.

+
-autoresize boolValue
+

If boolValue is equivalent to true, then the svgName is automatically scaled, + so as to occupy the maximum Surface area, + compliant with the current coordinate-system and respecting the anchor constraints.

+

Note that if -autoresize is activated, and the surface's anchorpoint is not within the surface, then nothing is drawn, because with -autoresize ALL the svgName should be contained + within the visible section of the surface. In this case the return transformation matrix is {}.

+
+
sfcName clear ?options?
+

This is a shorthand for "sfcName fill all ?options?"

+
+
+

Other Surface commands

+
+
sfcName flush
+

flushes the internal rendering command queue and waits for its completion (will block). + (only useful in Multi-Thread contexts). + This command is normally unnecessary, since a flush() is automatically performed + before the image is copied/exported/displayed.

+
sfcName size
+

returns a list of two values: width and height of the surface (in pixels)

+
sfcName applyTransform mtx
+

applies the transformation mtx to the current context's matrix. + As a side effect, the context's matrix is changed.

+
+	set M1 [$sfc cget -matrix]
+	set M2 [Mtx::rotation 30 degrees]
+	$sfc applyTransform $M2
+	set M3 [$sfc cget -matrix]
+	# -->  M3 == M2*M1
+
+
+
sfcName userToMeta
+

sets the surface MetaMatrix and resets the UserMatrix

+
+	MetaxMtx <-- UserMtx * MetaMtx
+	UserMtx  <-- IdentityMtx
+
+
+
+
+

Masks

+

A Mask is an 8-bit BL::Surface.

+

As a Surface, almost all methods can be applied on a mask, except with a few important limitations.

+

Being an 8-bit alpha-only surface, it is not possible to display a mask per se; +its purpose is to be combined with a regular Surface, via the fillmask method. +A Mask should be instantiated via the usual BL::Surface create or BL::Surface new constructors, +and then it can be manipulted with the usual stroke, fill methods. +Take care that when specifyng a color, only the ALPHA component is considered (R,G,B components are ignored) +as follows:

+
+set DX 500
+set DY 400
+set myMask [BL::Surface new -format [list $DX $DY A8]]
+$myMask fill all -compop CLEAR ;#  always clear the mask. Now the mask is fully transparent
+ # prepare the mask with a blended circle with pixel-value 0x80
+$myMash fill [BL::circle {250 100} 100] -style 0x80000000
+....
+
+

In the next section, we will use the term sfcMask to denote an 8-bit Surface.

+
+
sfcMask loadmask filename channel
+

Load in sfcMask the selected channel (RED,GREEN,BLUE,ALPHA) of filename.

+

As with the load method, sfcMask size is changed and the context is reset.

+
sfcMask savemask filename
+

save an alpha-only mask as png, qoi or bmp filename

+

NOTE:

+

The resulting 32-bit image will be a 'gray-image' with even tha alpha channell + set to the same fray-level.

+
sfcMask invertmask
+

invert all the pixel of the sfcMask. + Raise an error if Surface's format is not A8 (i.e. a mask)

+
sfcName fillmask xy sfcMask
+

Fill the sfcName Surface by combining the current -fill.style with the sfcMask mask. +Place the sfcMask mask over the sfcName Surface at position xy, +and then fill the whole SfcName with the current -fill.style.

+

Interesting effect can be obtained when the sfcMask

+

NOTE:

+

A mask can be applied only if sfcName has no rotation/scale transformation; +if sfcName has a translation transformation set, the mask can be applied +only if the (translation + xy) is an integer coord. +In these cases the following error is raised + 0x10007 NOT_IMPLEMENTED

+
+
+
+

BL::Path

+

A Path is a complex shape made of b-curves (Bezier curves, including straight lines).

+

The following commands can be used for creating and manipulating a Path:

+
+
BL::Path create pathName
+

creates a new instance of the class BL::Path called pathName.

+
BL::Path new
+

creates a new instance of the class BL::Path returning a new unique pathName.

+
pathName destroy
+

destroys pathName.

+
pathName dup
+

duplicates pathName. Return a new path

+
BL::Path names
+

returns the list of the currently available paths

+
pathName add geometry ?geometry ...? ?options?
+

adds one or more geometry to pathName. geometry is any geometric type above defined, +including the same pathName.

+

Valid options are:

+
+ +
-direction value
+

value can be one of NONE, CW, CCW. Default is CW.

+

Hint: Use CCW for adding holes in a path

+
-matrix matrix
+

applies a 2D transformation to the added geometries.

+
+
+   # starting from Blend2d 1.0, the "add" method also accepts a "BL::text" as a geometry.
+   # All the glyphs are converted and added to a BLPath using a simple layout algorithm
+  set fontFace [BL::FontFace new "./Arial.ttf"]
+  set fontName [BL::Font new $fontFace 12.0]
+  set blPath [BL::Path new]
+  $blPath add [BL::text {100 100} $fontName "ABC .. Z"]
+   # then you can get and manipulate its SVG representation 
+  set SVG [$blPath view] 
+  ...
+
+
+
pathName newStrokedPath ?stroke-options?
+

creates a new BL::Path made by stroking the current path with the stroking options passed as arguments. +Valid stroke-options are:

+
+ +
-width value
+
+
-dasharray value
+
+
-dashoffset value
+
+
-join value
+
+
-cap value
+
+
-miterlimit value
+
+
-transformorder value
+
+
+

These stroke-options are a subset of the options used for the stroke method of the BL::Surface class.

+
+    # build path0 as a simple triangle
+   set path0 [BL::Path new]
+   $path0 add [BL::polygon {100 100} {150 200} {200 200}]
+    # then derive a new path ... as the previous path but with a thick contour and rounded corners ..'
+   set path1 [$path0 newStrokedPath -width 20 -join ROUND]
+   ... remember to destroy path0 and path1
+
+
+
pathName addSVGpath dataString
+

reads and parses the SVG-path-data commands in dataString and adds the equivalent Blend2d command. +dataString must follow the rules for the "d" property of the SVG path elements, see the specs at https://www.w3.org/TR/SVG/paths.html#DProperty

+
+    set blPath [BL::Path new]
+    # the following SVG-path is presented in this way just for readability  ..
+    $blPath addSVGpath "
+       M 100 100
+       q -100 0 -200 -100
+       l 10.0 20.1 30 40 50 -5
+       h 1.5e+3
+       Z"
+    # but it can also be specified in a compact form       
+    $blPath addSVGpath "M100+100q-100+0-200-100l10.0,20.1,30,40,50-4H2E+3h1.5e+3Z"
+
+
+
pathName apply matrix
+

applies the 2D matrix transformation to the whole pathName.

+

if matrix is a 3x3 matrix (i.e a list of 9 numbers), then a planar-perspective-transformation is applied.

+

**NOTE** +This perspective transformation is not completely correct from a mathematical + point of view, in the sense that the curves that form a BL::Path are not + totally correctly deformed; only the control points of these curves are deformed. +In practice, all the straight segments are correctly deformed, and the error + in the curves is perceptible only in the case of accentuated perspective deformations.

+
pathName fitTo x y w h
+

fits (scale&translate) the whole pathName into the given rect.

+
pathName moveTo point0
+

sets the starting point0 (expressed as a list of two numbers) for the next commands ..

+
pathName lineTo point ?point ...?
+
+
pathName quadTo p1 p2 ?p1 p2...?
+
+
pathName cubicTo p1 p2 p3 ?p1 p2 p3...?
+
+
pathName smoothQuadTo p2 ?p2...?
+
+
pathName smoothCubicTo p2 p3 ?p2 p3...?
+
+
pathName arcQuadrantTo point1 point2
+
+
pathName arcTo pointC pointR start sweep ?-moveto boolean?
+
+
pathName ellipticArcTo point1 pointR rotation largeArcFlag sweepFlag point1
+
+
pathName close
+
+
pathName reset
+
+
pathName shrink
+

shrinks the internal capacity of the path to fit the current usage.

+
pathName bbox
+

Get the path's bounding-box.

+

Note that bbox does not consider the line-width, offset, caps (these parameters + are defined when stroking/filling the path). + If path is empty returns {0.0 0.0 0.0 0.0}

+
pathName empty
+

Return true if pathName's bbox is empty, i.e bbox width and height are 0.0. This is method is internally optimized since it does not call the costly bbox method.

+

Note that a pathname containing just a point (e.g a circle having radius 0), + is considered empty, since its bbox has width and height equal to 0.

+
pathName reverse
+

Reverse each figure (single curve) and their order as well.

+
pathName view
+

Returns the path data in SVG format

+
+

Path, contours and b-curves

+

Within a Path, a contour is a sequence of connected b-curves. +A non-empty Path may contain one or more contours; contours can be open or closed.

+
+
pathName contours ?count?
+

return the number of contours.

+
pathName contour tolerance ?value?
+

get or set the tolerance used for computing the curve length. By default this tolerance is 0.001 +meaning that the computed length will have an error less than 0.001 times the actual length.

+
pathName contours reset
+

Computing the length of a set of curves is an expensive task and the computed lengths are kept in a cache. +This kind of computation is activated only when some specific contour methods are called. +This method reset this cache. Note however that when a pathName object is destroyed, all the cache memory is cleaned.

+
+
+

The contour method - operations on contours

+
+
pathName contour i|* ?count?
+

return the number of b-curves of the i-th contour. + If * is specified, it returns a list with the number of b-curves of every contour. + If contour-index i is out of range, result is {}

+
pathName contour i|* length
+

return the length of the i-th contour. + If * is specified, it returns a list with the length of each contour. + If contour-index i is out of range, result is {}.

+

Length is calculated using numerical approximation. (see above tolerance).

+
pathName contour i|* isclosed
+

return 1 if the i-th contour is closed, else 0. + If * is specified, it returns a list with the status (0/1) of each contour. + If contour-index i is out of range, result is {}

+
+

curveOP: The following curveOP can be used for evaluating some properties +of each b-curve part of a contour; by using the b-curve's (implicit) parametric +equatione B(t), you can evaluate +the following curveOP functions at value t +(t must be between 0.0 and 1.0):

+
    + +

  • at: returns the position {x y} at B(t)

    • +

  • tangent: returns the tangent versor {x y} at B(t)

    • +

  • normal: returns the normal versor {x y} at B(t)

    • +

  • tangentAt: returns the position and the tangent versor at B(t)

    • +

  • normalAt: returns the position and the normal versor at B(t)

    • +

  • curvature: returns the (signed) curvature at B(t). Straight segments have curvature equal to 0.

    • +
+
+ +
pathName contour i|* atlength rLen curveOP
+

rLen is a coefficient (0<=rLen<=1) denoting the relative length of a contour ; + 0 corresponds to the start of contour, 0.5 corresponds to the midpoint of the contour (measured along the curves) + Depending on the curveOP function (see above), this method returns + a point {x y}, a point and a vector {{x y} {dx dy}} or a number.

+

If contour-index i is out of range, result is {}. +If * is specified, it returns a list with the curveOP evaluation at rLen for each contour.

+

Note that if the coefficient T corresponds to a junction-point + of two b-curves, the result for the + tangent, normal, tangentAt, normalAt, curvature may be undefined (i.e {})

+
pathName contour i|* t-subdivision N curveOP
+

generates a sequences of values (evaluating curveOP), by sampling N+1 points on the contour. + Points are spaced at parametrically equidistant intervals, meaning that they are closer when the curve has an higher curvature.

+

If the countour is closed, the last point ((N+1)-th point) coincides with the first one.

+
pathName contour i|* l-subdivision N curveOP
+

generates a sequence of N+1 values similar to the above, but points + are spaced at intervals of equal length.

+
+
+

The contour method - operations on single b-curves

+

The following methods require to specify two indices, i and j; i is the contour-index, j is the b-curve-index. +As usual, i and j can be '*', meaning 'all contours' and 'all b-curves'.

+
+
pathName contour i|* j|* length
+

return the length of the j-th b-curve of the i-th contour.

+

If * is specified for the contour-index, the evaluation is performed on each contour, returning a list of values; + similarly if the curve-index is *.

+

If * is specified for both the contour-index and the curve-index, + this command returns a list of lists, i.e. for every contour returns a + list with the lengths of each of its b-curves.

+
pathName contour i|* j|* atlength rLen curveOP
+

return the evaluation of curveOP on the j-th b-curve of the i-th contour, at a relative arc-length rLen + (rLen equal to 0.5 corresponds to the midpoint of the b-curve). rLen must be between 0.0 an 1.0 + If * is specified, the same previous considerations apply.

+
pathName contour i|* j|* curveOP t
+

return the evaluation of curveOP on the j-th b-curve of the i-th contour, at t. + If * is specified, the same previous considerations apply.

+
pathName contour i|* j|* t-subdivision N curveOP
+

generates a sequences of N+1 values evaluating curveOP, + by sampling N+1 points on the j-th b-curve of the i-th contour. + Points are spaced at parametrically equidistant intervals, meaning that they are closer when the curve has an higher curvature. + If * is specified, the same previous considerations apply.

+
pathName contour i|* j|* l-subdivision N curveOP
+

generates a sequence of N+1 values similar to the above, but points + are spaced at intervals of equal length.

+
+
+
+

BL::Svgdoc

+

A Svgdoc is an internal representation of the contents of an SVG file. +There are no methods for manipulating a SvgDoc, other than for creating (loading an SVG-file), +painting on a Surface (see above the method paint) and of course unloading/destroying.

+

A Svgdoc is built by using a third-party library (https://github.com/Wiladams/svgandme) providing a +"[..] fairly complete library, supporting most of the SVG features found in typical usage today."

+

The following commands can be used for creating and manipulating a Svgdoc:

+
+
BL::Svgdoc create pathName SVG-file
+

creates a new instance of the class BL::Svgdoc called pathName by parsing and loading the file SVG-file

+
BL::Svgdoc new SVG-file
+

creates a new instance of the class BL::Svgdoc by parsing and loading the file SVG-file. +Returs a new unique pathName.

+
pathName destroy
+

destroys pathName.

+
BL::Svgdoc names
+

returns the list of the currently available Svgdocs

+
+

Usage notes: Svgdoc and font-files

+

In case a given SVG-file makes use of external fonts, these fonts are searched among the loaded fonts, and if not found, a default-loaded font is selected. +You can use these two command for controlling the available loaded fonts.

+
+
BL::loadedsvgfonts
+

returns a list of the loaded font-families

+
BL::loadsvgfonts font-file ?font-file ...?
+

load one ore more font-files (*.ttf, *.ttc, *.otf, ...).

+

NOTE* An error is raised if one font-file cannot be loaded, but no details are returned + ... THIS SHOULD BE FIXED ...

+
+
+
+

BL::FontFace, BL::Font and Glyphs

+

+ Note: Currently text support is still basic and subject to changes. +

+

Before drawing some text, you need to load some fonts from an external font-file.

+
+ +
BL::FontFace create faceName fontfile ?faceIdx?
+

loads a fontfile and creates a new instance of the class BL::FontFace + named faceName.

+

If fontfile is a font collection, you can specify which + fontface to load. Default value for faceIdx is 0 (i.e. the first fontface). + if faceIdx is greater than the number of the available fontfaces, the last fontface is loaded, and it can be inspected with the details method.

+
BL::FontFace new fontfile ?faceIdx?
+

loads a fontfile, creates a new instance of the class BL::FontFace returning + a new unique faceName.

+
faceName destroy
+

destroys faceName. Note that in general any oo-object like faceName should be explicitly destroyed

+
BL::FontFace names
+

returns the list of all the currently allocated fontfaces.

+
faceName details
+

returns a dictionary with some properties of the loaded faceName.

+

These are the currently listed properties; more properties may be added in future Blend2d releases.

+
+  # load the last fontface from a fontfile-collection
+  #   ("AmericanTypewriter.ttc" can be found in the tclBlend2d-devkit distribution )
+  # Note that I want to load the last fontface, so I specify a large 'faceIdx'
+  # surely greater than the available fontface (.. there're 6 fontfaces in this collection ..) 
+ set fface [BL::FontFace new "./AmericanTypewriter.ttc" 999]
+  # pretty print details
+ dict for {key value} [$fface details] {
+    puts "[format "%25s %s" $key $value]"
+ }
+  # ....
+  # other ops ...
+  #
+ $fface destroy
+
+

This produces the following output :

+
+                faceIndex 5
+               glyphCount 916
+                 fullName American Typewriter Condensed Light
+               familyName American Typewriter
+            subfamilyName Condensed Light
+           postScriptName AmericanTypewriter-CondensedLight
+               unitsPerEm 1000
+                   weight 300
+                    style 0
+                  stretch 3
+    hasCharToGlyphMapping 1 
+
+
+
+

Once a BL::FontFace has been loaded, and before drawing some text or extracting some glyphs, +you should create a BL::Font object based on an instance of BL::FontFace

+
+ +
BL::Font create fontName faceName fontsize
+

creates a new instance of the class BL::Font, based on faceName, having size fontsize (float).

+

Note that although any text and glyph can be arbitrarily scaled with the usual 2D transformations, + fontsize can be used to select some special glyphs that some fonts + may make available for working with very small font sizes.

+
BL::Font new faceName fontsize
+

creates a new instance of the class BL::Font returning + a new unique fontName.

+
fontName destroy
+

destroys fontName. Note that in general any oo-object like fontName should be explicitly destroyed

+
BL::Font names
+

returns the list of all the currently allocated fonts.

+
BL::Font face
+

returns a dictionary with the details of its related BL::FontFace.

+
fontName metrics
+

returns a dictionary with several font properties (size, ascent, vAscent, descent, vDescent, lineGap, xHeight, capHeight, xMin, yMin, xMax, yMax, underlinePosition, underlineThickness, strikethroughPosition, strikethroughThickness)

+
fontName textmetrics string
+

string can also be a multiline string; in this case a simple layout is applied.

+

returns a dictionary with the following keys:

+
    +

  • advance - a point (or better a direction xy)

    • +

  • leadingBearing - a point

    • +

  • trailingBearing - a point

    • +

  • boundingBox - a list of 4 coords: x0 y0 x1 y1

    • +
+
fontName textbox xy text ?options?
+

return a list {x0 y0 x1 y1} denoting the bounding box of text. + text can also be a multiline string; in this case a simple layout is applied. + See the details of the BL::text command for the meaning of various parameters and options.

+
+

Text and Glyphs

+

A fontName can be used for drawing some text like in the following example

+
+  set fontFace [BL::FontFace new "./Arial.ttf"]
+  set fontName [BL::Font new $fontFace 12.0]
+  set sfc [BL::Surface new]
+  $sfc fill [BL::text {100 100} $fontName "Hello World"] -style [BL::color orange]
+
+

but it can also used for extracting single glyphs from it.

+
+ +
fontName glyphs someText
+

returns a list of glyph-indexes. Note that character ligatures may be taken into account, + so the number of glyphs may be less than the number of characters (Example: depending on the font in use, "fi" characters may be merged into a single glyph)

+

NOTES:

+
    +

  • With versions before 1.4, this method returned one glyph-index for each (Unicode) character in someText. Fixed with tclBlend2d 1.4

    • +

  • Starting from tclBlend 1.5, 'newline' characters are ignored (i.e. no glyph is returned for "\n").

    • +
+
fontName glyphs someText -withadvance bool ?-justify mode?
+

if bool is true, this method returns a sequence of glyph-index and advancePositions (i.e. a (dx,dy) direction). +In case someText is a multi-line text, the +-justify option determines how the lines are laid out relative to one another.

+
+   # -- how to paint all the glyphs one by one ..
+   #    and apply a different color (or any other change) on every glyph
+  set fontFace [BL::FontFace new "./Arial.ttf"]
+  set fontName [BL::Font new $fontFace 24.0]
+  set sfc [BL::Surface new]
+  set colors {red blue white green yellow lightblue}
+  $sfc push
+  $sfc applyTransform [Mtx::translation 50 100] ;# position of the 1st glyph
+  foreach {glyphID advance} [$font glyphs "Hello\nWorld\n!" -withadvance true -justify CENTER] {
+	 set glyphObj [$font glyph $glyphID]
+	  # .. choose a random color for each glyph ..
+	 set color [lindex $colors [expr {int(rand()*[llength $colors])}]]
+	 $sfc fill $glyphObj -style [BL::color $color]
+	 $sfc applyTransform [Mtx::translation {*}$advance]
+	 $glyphObj destroy
+  }
+  $sfc pop
+
+

Of course, if you simply need to draw this text, without 'special effects', you could do the same with just a single line

+
+  ..
+  $sfc fill [BL::text {50 100} $font "Hello\nWorld\n!" -justify CENTER]
+
+
+
fontName glyph glyphIdx
+

returns a new instance of BL::Path containing the geometrical representation of the given glyphIdx. Raise an error if glyphIdx is invalid.

+

Note: this method creates a new BL::Pathinstance, and it is user's responsibility + to destroy it explicitly.

+
+

Before drawing some text (or a single glyph) you should load a fontfile, then +setup a BL::Font with a given size

+
+    set aFontFace [BL::FontFace new _fontfile_]
+    set aFont [BL::Font new $aFontFace _size_]
+
+

note that both BL:FontFace and BL::Font create new objects, and therefore it's +programmer's responsibility to delete them (e.g call "$aFontFace destroy" )

+

The easiest way to draw a text on a Surface is to use the special 'geometry' BL::text +with the fill/stroke methods

+
+    surfaceName fill [BL::text {10 20} $aFont "Hello World!!"]
+
+

Of course you can set the drawing-properties of the Surface as usual (color, gradient, line width, matrix transformation ....)

+

Alternatively, you can extract a single glyph from a font, store it as a BL::Path, and then +manipulate it as usual

+
+    set aGlyph [$font glyph 44]  ;# extract glyph n.44
+    $sfc stroke $aGlyph
+
+

Note that the glyph method returns a new BL::Path object,and therefore it is +programmer's responsibility to free the resources (e.g. "$aGlyph destroy" )

+
+
+

Applying filters

+

TclBlend2d provides two basic ways to work with filters. +You can apply a filter to a rectangular region of a Surface (currently only blur and bw filters), or you can +set a filter to a script so that it will be applied to all the graphical primitives that will be rendered by this script.

+
+
sfcName blur radius ?-rect {x y w h}?
+

applies a blur filter of size radius (from 2 to 254) to a rectangular region of sfcName

+

Valid options are:

+
+ +
-rect {x y w h}
+

defines the rectangular subregion where the filter will be applied. + x, y, w,h are pixel coords (integer coords)

+

If -rect is not specified, the filter will be applied to the whole surface.

+
+
sfcName bw ?-luma {r g b}? ?-rect {x y w h}?
+

applies a black&white filter to a rectangular region of sfcName

+

Valid options are:

+
+ +
-luma {r g b}
+

{r g b} are luminance coefficients. Default is {0.2126, 0.7152, 0.0722} (Rec. 709)

+
-rect {x y w h}
+

defines the rectangular subregion where the filter will be applied. + x, y, w,h are pixel coords (integer coords)

+

If -rect is not specified, the filter will be applied to the whole surface.

+
+
sfcName filter filterType ?filter-args? script
+

all the graphical primitives created by this script that will be rendered on sfcName will be +redirected to a special temporary layer, +then the filter will be applied to this temporary layer and then it will be blended with the underlying Surface.

+

Parameters are:

+
+
filterType
+

Valid values are bw, blur, shadow, and the special filter ignore. + This latter filter means that no filter will be applied.

+
filter-args
+

A list of options for filterType. (see below .....)

+
script
+

A tcl script. Usually, this script should contain some rendering commands on sfcName. All these commands will be temporarily redirected + to an automatically allocated temporary Surface. This temporary surface is initialized as a transparent surface and has the same 'state' (e,g the set of options) + of sfcName. When script ends, the filter is applied to the whole temporary surface + (or better, only to the bounding-box of the rendered primitives), and finally, this temporary Surface will be blended + with the underlying sfcName.

+

Note that if this script changes the state of the (redirected) sfcName, these changes will be also visible in the original sfcName.

+

Warning: take care of not "popping" the initial stack level of sfcName. Method push and pop + are allowed within script as long as they are properly paired.

+
+
+

filter-args for "bw" filter

+
+ +
-luma {r g b}
+

{r g b} are luminance coefficients. Default is {0.2126, 0.7152, 0.0722} (Rec. 709)

+
+
+

filter-args for "blur" filter

+
+ +
-radius radius
+

blur radius (from 2 to 254). Default is 5 pixels.

+
+
+

filter-args for "shadow" filter

+
+ +
-radius radius
+

blur radius (from 2 to 254). Default is 5 pixels.

+
-dxy {dx dy}
+

dx,dy translation of the blurred shadow. Default is {3 5}

+
-color color
+

shadow color. Default is [BL::color gray30]

+
+
+	$sfc reset
+	$sfc clear -style [BL::color white]
+	 #
+	 # --- a shadowed blue/white/red disc
+	 #
+	set center {100 150}
+	$sfc filter shadow -radius 20 -dxy {5 9} {
+		foreach circleRadius {90 60 30} color {lightblue white red} {
+			$sfc fill [BL::circle $center $circleRadius] -style [BL::color $color]		
+		}
+	}
+	 #
+	 # --- three shadowed discs	
+	 #
+	set center {300 150}
+	foreach circleRadius {90 60 30} color {lightblue white red} {
+		$sfc filter shadow -radius 20 -dxy {5 9} {
+			$sfc fill [BL::circle $center $circleRadius] -style [BL::color $color]		
+		}
+	}
+
+
+
+

Exchanging pixmaps

+

Blend2d provides commands for loading graphics files in a Surface, as well for saving the +Surface's internal framebuffer in a graphic file. +Blend2d provides commands for copying (part of) the internal framebuffer among different Surfaces. +If the Tk support is loaded, that is if you loaded the Blend2d or tkBlend2d packages, you can also +exchange parts of the Surfaces framebuffer with tk photo images.

+

read/write files

+
+
sfcName load filename
+

loads the contents of filename. Supported formats: png, jpeg, bmp, qoi.

+

WARNING: the internal framebuffer cleared and then resized.

+
sfcName addimage filename ?options?
+

loads the image filename, without clearing and resizing sfcName. Supported formats: png, jpeg, bmp, qoi.

+

options are the same options of the copy method.

+
sfcName save filename ?-format file-format?
+

saves the internal framebuffer in filename +If -format is not specified, this command tries to guess the file-format from the file extension.

+

NOTE: Currently only BMP, PNG and QOI encodecrs are available

+
+
+

copy among surfaces

+
+
sfcName copy srcSurface ?-from {x0 y0 w h}? ?-to {xp yp}? ?-compop op? ?-globalalpha alpha?
+
+
sfcName copy srcSurface ?-from {x0 y0 w h}? ?-to {x y w h}? ?-compop op? ?-globalalpha alpha?
+

copies (a sub-region of) srcSurface to the current sfcName. + If no options are specified, this command copies the whole srcSurface + starting at coordinates (0,0).

+

The following options may be specified:

+
+ +
-from {x y w h}
+

specifies a rectangular sub-region of the surface to be copied. + The pixels copied will include the left and top edges of the specified rectangle but not the bottom or right edges. + If the -from option is not given, the default is the whole surface.

+
-to {x y}
+

specifies where to place the source sub-region in the current surface. + The current surface is never resized, therefore, all parts + of the srcSurface that will be placed outside this surface will be excluded (clipped).

+
-to {x y w h}
+

specifies a rectangular sub-region of the current surface. + The source sub-region is scaled to fit into the destination rectangle.

+
-compop value
+

applies a composition-operation to the pixels that will be copied. + If this option is not specified, the current value of the -compop option is used.

+
-globalalpha alpha
+

srcSurface will be blitted using alpha transparency. + If this option is not specified, the current value of the -globalalpha option is used.

+
+

copies (a sub-region of) srcSurface to the current sfcName. + If no options are specified, this command copies the whole srcSurface + starting at coordinates (0,0).

+

Note that if there's a matrix-trasformation (rotation, scaling, ..) on the + current surface, this transformation will be applied to all points of the + destination sub-region (i.e. the -from rectangle will be rotated, scaled, ...)

+
sfcName rawcopy srcSurface ?-from {x0 y0 w h}? ?-to {x y w h}? ?-compop op? ?-globalalpha alpha?
+

similar to the copy method. The only difference is that the source region + (those specified by the -from option) will be copied in sfcName + *without* any transformation.

+

The default -compop mode is SRC_OVER.

+
+
+

reading/writing tkphoto

+

These commands require the Blend2d or tkBlend2d package. +These commands are not available if you loaded the tclBlend2d package;

+

NOTE: points and rectangles below are specified in pixel-coords. This means that +pixels-coords are independent of the current transformation matrix; no rotation or scaling is applied.

+
+ +
sfcName readFromTkphoto tkphoto ?-from {x0 y0 w h}? ?-to {x0 y0}?
+

copies (a sub-region of) tkphoto to the current sfcName. + If no options are specified, this command copies the whole tkphoto + to the sfcName coordinates (0,0).

+

The following options may be specified:

+
+ +
-from {x y w h}
+

Specifies a rectangular sub-region of the tkphoto to be copied. + The pixels copied will include the left and top edges of the specified rectangle but not the bottom or right edges. + If the -from option is not given, the whole tkphoto is loaded (clipped against sfcName). + x or y can be negative integers.

+
-to {x y}
+

Specifies where to place the source sub-region in the current surface. x or y can be negative integers.

+
+

NOTE: sfcName is not resized; you should take care to resize it + in order to get all the portion of the tkphoto you are interested in.

+
sfcName writeToTkphoto tkphoto ?-from {x0 y0 w h}? ?-to {x0 y0}?
+

copies (a sub-region of) sfcName to a tkphoto. + If no options are specified, this command copies the whole srcSurface + to the tkphoto coordinates (0,0).

+

tkphoto will be expanded to include the the source area, unless the user has specified + an explicit image size with the -width and/or -height widget configuration options (see photo(n)); + in that case the source area is silently clipped to the image boundaries.

+

The following options may be specified:

+
+ +
-from {x y w h}
+

Specifies a rectangular sub-region of the surface to be copied. + The pixels copied will include the left and top edges of the specified rectangle but not the bottom or right edges. + If the -from option is not given, the whole surface is copied to tkphoto. + x or y can be negative integers.

+
-to {x y}
+

Specifies where to place the source sub-region in the destination tkphoto. x or y can be negative integers.

+
+
+
+
+

Creating a blend2d (tk-)image

+

These commands require the "Blend2d" or "tkBlend2d" package. +These commands are not available if you loaded the "tclBlend2d" package;

+
+ +
image create blend2d ?name? ?options?
+

Similar to the standard command "image create photo ...", this command creates a new image of type blend2d plus a new surface-object that can be used for manipulating the image.

+

Options are the same options used for the "BL::Surface create .." command.

+

The image can then be embedded in a widget (like a "label" or a "canvas"); every + command like fill or stroke issued to the image name, will immediately change the displayed image.

+

Both "image delete sfcName" and "sfcName destroy" can be used to delete the image AND the related surface-object.

+
+
+

Other BL:: commands

+
+
BL::classes
+

lists the name of the BL classes (e.g BL::Surface,BL::Path, ...)

+
BL::classinfo objectName
+

returns the class name of objectName. + objectName can be any tcloo object (not limited to BL:: objects)

+
BL::codecs
+

lists the supported graphics file formats.

+

For each supported graphic file formats, returns a detailed list made of 5 elements: + id, vendor, mimeType, extensions, features.

+
    + +

  • id is the key element to be used in load/save operations (e.g. JPEG)

    • +

  • vendor is the name of the codec's vendor.

    • +

  • mimetype is a string (e.g. image/jpeg)

    • +

  • extensions is a sequence of recognized filename-extensions; elements are separated by "|" (e.g. jpg|jpeg|jif|jfi|jfif)

    • +

  • features is a list of supported features

    +
      + +

    • READ: reading is supported

      • +

    • WRITE: writing is supported

      • +

    • LOSSY: lossy compression

      • +

    • LOSSLESS: lossless compression

      • +

    • MULTI_FRAME: multiple frames (GIF).

      • +

    • IPTC: supported IPTC metadata.

      • +

    • EXIF: supported EXIF metadata.

      • +

    • XMP: supported XMP metadata.

      • +
    +
    • +
+
BL::enum
+

lists all the enum categories

+
BL::enum category
+

lists all the values for that _category_ + e.g. BL::enum GRADIENT_TYPE --> LINEAR RADIAL CONIC

+
BL::libinfo
+

returns a dictionary with info about the core Blend2d library. + The dictionary keys are version, type (build-type)

+
BL::platform
+

returns a dictionary with info about the cpu architecture and the cpu features used by Blend2d. + The dictionary keys are cpuArch, cpuFeatures, coreCount.

+
+
+

Auxiliary utilities

+

Blend2d provides some small helpers for working with transformation-matrix and colors

+

Affine matrix

+

An affine matrix is a 3x3 matrix whose last column is fixed 0 0 1

+
+    a b 0
+    c d 0
+    e f 1
+
+

Given this rule, it is convenient to express such matrices as a list of 6 numbers +{ a b c d e f } instead of 9 numbers.

+

Working with these matrices can be simplified by using the Mtx package included in Blend2D.

+

In the following paragraphs "M" stands for a matrix (a list of 6 numbers), "P" stands for +a 2D point (a list of 2 numbers).

+

The following commands are supported

+
+ +
Mtx::identity
+

returns the identity matrix {1 0 0 1 0 0}

+
Mtx::MxM M1 M2
+

matrix multiplication

+
Mtx::determinant M
+
+
Mtx::invert M
+

matrix inversion - Raise an error if M is not invertible.

+
Mtx::PxM P M
+

map a Point

+
Mtx::multiPxM Points M
+

map a list of Points

+
Mtx::P-P P1 P2
+

return P1-P2

+
Mtx::VxM V M
+

map a vector V : VxM(V,M) = PxM(V,M)-PxM(0,M)

+
Mtx::translation dx dy
+
+
Mtx::scale sx ?sx? ?C?
+

scale sx sy around the fixed-point C (C default is {0 0})

+
Mtx::rotation angle radians|degrees ?C?
+

performs a rotation of angle around the fixed-point C (C default is {0 0})

+
Mtx::skew sx sy
+
+
Mtx::xreflection ?x0?
+

reflection with respect to the vertical axis x=x0 (default x0 is 0)

+
Mtx::yreflection ?y0?
+

reflection with respect to the horizontal axis y=y0 (default y0 is 0)

+
Mtx::translate M dx dy
+
+
Mtx::post_translate M dx dy
+
+
Mtx::scaling M sx sy ?C?
+
+
Mtx::post_scaling M sx sy ?C?
+
+
Mtx::rotate M angle radians|degrees ?C?
+
+
Mtx::post_rotate M angle radians|degrees ?C?
+
+
Mtx::xreflect M ?x0?
+
+
Mtx::yreflect M ?y0?
+
+
+
+

3x3 matrix

+

A 3x3 matrix is an extension of an affine matrix and it could be used for applying +a Planar Perspective Transformation to a BL::Path (see method "$pathObj apply ..."). +This matrix is expressed as a list of 9 numbers, and as a convenience it can be +computed with Mtx::quadtoquad

+
+ +
Mtx::quadtoquad quad1 quad2
+

where quad1 and quad2 are two quadrilaters, i.e two lists of 4 points.

+

Note that this command may raise an error if quadrilaters are degenere (e.g. non-convex quadrilaters) + or more generally if ther's no transformation from quad1 to quad2.

+
+
+

HSB/HSL color model

+

Blend2d internally works with colors expressed in terms of red,green,blue and alpha channels, +but in some cases it is more natural to express color following the HSB or HSL color model, where:

+
    + +

  • h (hue) is a 0.0..360.0 angle

    • +

  • s (saturation) is 0.0 .. 1.0

    • +

  • b (brigthness) is 0.0 .. 1.0 ( 0 is black, 1 is white ) + or

    • +

  • l (lightness) is 0.0 .. 1.0 ( 0 is black, 1 is white )

    • +

  • alpha is 0.0 .. 1.0

    • +
+

See https://en.wikipedia.org/wiki/HSL_and_HSV for details.

+

The following commands are available for converting between between ARGB and HSB or HSL color models, +as well for interpolating color in the HSB or HSL color-space.

+
+
HSB h s b ?alpha?
+

returns an ARGB number (in decimal notation, not in hex notation)

+
RGB2HSB 0xAARRGGBB
+

returns a list with the HSB components. { h s b alpha }

+
HSBblend hsb1 hsb2 t
+

blends two colors hsb1 and hsb2 (expressed as {h s b} or {h s b a}) + with a weigth t (t is always clamped between 0.0 and 1.0). + Result is a new HSB color as {h s b a}.

+
HSL h s l ?alpha?
+

returns an ARGB number (in decimal notation, not in hex notation)

+
RGB2HSL 0xAARRGGBB
+

returns a list with the HSL components. { h s l alpha }

+
HSLblend hsl1 hsl2 t
+

blends two colors hsl1 and hsl2 (expressed as {h s l} or {h s l a}) + with a weigth t (t is always clamped between 0.0 and 1.0). + Result is a new HSL color as {h s l a}.

+
+
+
+

Limitations

+
    +

  • Saving a Surface is currently limited to BMP,PNG, QOI files.

    • +

  • The -stroke.dasharray option is currently a no-op.

    • +
+
+

Keywords

+

graphics

+
+

Category

+

vector graphics

+
+ +
\ No newline at end of file diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/pkgIndex.tcl new file mode 100644 index 00000000..6ec11a5b --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/pkgIndex.tcl @@ -0,0 +1,31 @@ +package ifneeded Mtx 1.1 [list source [file join $dir Mtx.tcl]] +package ifneeded HSB 1.3 [list source [file join $dir HSB.tcl]] + +package ifneeded BL::SVG 1.0.2 [list apply { dir { + source [file join $dir t2dsvg.tcl] + package provide BL::SVG 1.0.2 +}} $dir] ;# end of lambda apply + +package ifneeded BL::Filter 1.0.1 [list apply { dir { + source [file join $dir t2d_filters.tcl] + package provide BL::Filter 1.0.1 +}} $dir] ;# end of lambda apply + +package ifneeded tkBlend2d 1.5 [list apply { dir { + source [file join $dir t2d.tcl] + load [BL::_findDLL $dir "tkBlend2d"] T2d + package provide tkBlend2d 1.5 +}} $dir] ;# end of lambda apply + +package ifneeded tclBlend2d 1.5 [list apply { dir { + source [file join $dir t2d.tcl] + load [BL::_findDLL $dir "tclBlend2d"] T2d + package provide tclBlend2d 1.5 +}} $dir] ;# end of lambda apply + +# --- Alias +package ifneeded Blend2d 1.5 [list apply { dir { + set ver 1.5 + package require -exact tkBlend2d $ver + package provide Blend2d $ver +}} $dir] ;# end of lambda apply diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2d.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2d.tcl new file mode 100644 index 00000000..e0bb71d1 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2d.tcl @@ -0,0 +1,339 @@ +# t2d.tcl +# +# Class definitions for the Tcl->Blend2D (t2d) integration +# + +package require Mtx 1.1 +package require HSB 1.0 + +namespace eval BL { + variable FontDir + # take into account not the 'devkit' tree, but the deployed package tree. + set FontDir [file join [file normalize [file dirname [info script]]] "fonts"] +} + +proc BL::_findDLL {dir pkgName} { + set thisDir [file normalize ${dir}] + + set os $::tcl_platform(platform) + switch -- $os { + windows { set os win } + unix { + switch -- $::tcl_platform(os) { + Darwin { set os darwin } + Linux { set os linux } + } + } + } + set majorVersion [lindex [split [package present Tcl] "."] 0] + switch -- $majorVersion { + 8 {set vtag "86"} + 9 {set vtag "90"} + default { error "tclBlend2d: Unsupported Tcl version" } + } + switch -- $pkgName { + Blend2d - + tkBlend2d { + set libName "tkb2d" + } + tclBlend2d { + set libName "tclb2d" + } + default { + error "Unregistered package name \"$pkgName\"" + } + } + + set tail_libFile ${libName}${vtag}[info sharedlibextension] + # try to guess the tcl-interpreter architecture (32/64 bit) + set arch $::tcl_platform(pointerSize) + switch -- $arch { + 4 { set arch x32 } + 8 { set arch x64 } + default { error "${pkgName}: Unsupported architecture: Unexpected pointer-size $arch!!! "} + } + set dir_libFile [file join $thisDir ${os}-${arch}] + if { ! [file isdirectory $dir_libFile ] } { + error "${pkgName}: Unsupported platform ${os}-${arch}" + } + + set full_libFile [file join $dir_libFile $tail_libFile] + return $full_libFile +} + + # this proc is an 'internal' proc called from the "C" T2dSvgDoc_Setup initialization procedure +proc BL::_DefaultFonts_init {} { + variable FontDir + # Arial NOT freely distributed - loadsvgfonts [file join $FontDir "arial.ttf"] + + switch -- $::tcl_platform(platform) { + windows { + set fonts { + "c:/Windows/Fonts/arial.ttf" + "c:/Windows/Fonts/calibri.ttf" + "c:/Windows/Fonts/cour.ttf" + "c:/Windows/Fonts/times.ttf" + "c:/Windows/Fonts/verdana.ttf" + } + } + unix { + switch -- $::tcl_platform(os) { + Darwin { + set fonts { + "Library/Fonts/Courier.ttc" + "Library/Fonts/Helvetica.ttc" + "Library/Fonts/Times.ttc" + } + } + Linux { + set fonts { + "/usr/share/fonts/truetype/freefont/FreeSans.ttf" + "/usr/share/fonts/truetype/freefont/FreeSerif.ttf" + } + } + } + } + default { set fonts {} } + } + foreach font $fonts { + if {[file readable $font]} { + # ignore errors, try to load all fonts .. + catch {loadsvgfonts $font} + } + } +} + + +namespace eval BL { + oo::class create COMMON_METHODS { + # return the (sorted) list of current instances + method names {} { + lsort [info class instances [lindex [info level 0] 0]] + } + } + + variable _classes + # precompute _classes + foreach clazz {Surface Path FontFace Font Svgdoc} { + lappend _classes [namespace current]::$clazz + ::oo::class create $clazz { + # Constructor and methods are written in C + } + # add the "names" typemethod + oo::objdefine $clazz {mixin COMMON_METHODS} + } + unset clazz + + proc classes {} { + variable _classes + return $_classes + } + + proc classinfo {obj} { + info object class $obj + } + +} + + # ------------------------------------------ + # some helper methods for class BL::Surface + # ------------------------------------------ + +package require BL::Filter + + # KNOWN LIMITS: + # Only the Surface object is cloned; if the original Surface is linked to + # a tk-image (of type "blend2d"), the new Surface will be devoid of it. + # See CloneB2dProc in t2d_Surface.cxx +::oo::define BL::Surface method dup {} { + oo::copy [self] +} + +::oo::define BL::Surface method clear {args} { + my fill all {*}$args +} + +::oo::define BL::Surface method size {} { + lrange [my cget -format] 0 1 +} + + # rawcopy is similar to "copy". + # The only diff is that with "rawcopy" the destination area is not + # rotated/scaled by the current transformation matrix. + # i.e any geometry transformation is ignored + # +oo::define BL::Surface method rawcopy {fromSurf args} { + set metamtx [my cget -metamatrix] + set usermtx [my cget -matrix] + + my push + my configure -matrix [Mtx::invert $metamtx] + my userToMeta + # now meta-matrix and user-matrix are the Identity matrix + try { + my copy $fromSurf -compop SRC_OVER {*}$args + } finally { + my pop + } +} + + # save an alpha-only mask on a png, qoi, bmp files + # as a grayscale ARGB image (including alpha channel) + # A8: 0xNn -> ARGB: 0xNnNnNnNn +oo::define BL::Surface method savemask {filename} { + lassign [my cget -format] W H fmt + if { $fmt != "A8" } { + error "savemask can be used with an A8 surface only." + } + try { + set tmpSfc [BL::Surface new -format [list $W $H]] + $tmpSfc fill all -compop CLEAR + $tmpSfc copy [self] + $tmpSfc save $filename + } finally { + $tmpSfc destroy + } +} + + # add an image over the current Surface. + # options are those option of the "copy" method (-from, -to, -compop ..). + # Note that if there's a matrix-trasformation (rotation, scaling, ..) on the current surface, + # this transformation will be applied to all points of the destination sub-region + # (i.e. the -from rectangle will be rotated, scaled, ...) +oo::define BL::Surface method addimage {filename args} { + set tmpSfc [BL::Surface new] + try { + $tmpSfc load $filename + my copy $tmpSfc {*}$args + } finally { + $tmpSfc destroy + } +} + + + + # ------------------------------------------ + # some helper methods for class BL::Path + # ------------------------------------------ + +::oo::define BL::Path method dup {} { + oo::copy [self] +} +package require BL::SVG + +::oo::define BL::Path method addSVGpath {dataStr} { + BL::SVG::buildBLPathFromSVGPathD [self] $dataStr +} + + # ==================================================================== + # General rules: + # All the following procs will build a standard representation for + # some geometric entities. + # This representation is a list with 2 elems: + # a 'type' (expressed with a keyword *matching ENUM_TABLE(GEOMETRIC_TYPES)*) + # a list enclosing all the required parameters + # ==================================================================== + + # build a BOXD + # box P0 P1 +proc BL::box {P0 P1} { + list BOXD [list $P0 $P1] +} + + # build a RECTD + # rect x y w h +proc BL::rect {x y w h} { + list RECTD [list $x $y $w $h] +} + +# build an ROUND_RECT +# roundrect x0 y0 w h rx ?ry? +proc BL::roundrect {x y w h rx {ry {}}} { + if {$ry eq {}} { set ry $rx } + list ROUND_RECT [list $x $y $w $h $rx $ry] +} + +# build a CIRCLE +# circle C radius +proc BL::circle {C r} { + list CIRCLE [list $C $r] +} + +# build an ELLIPSE +# ellipse C rx ry +proc BL::ellipse {C rx ry} { + list ELLIPSE [list $C $rx $ry] +} + +# build an ARC +# arc C rx ry start sweep +proc BL::arc {C rx ry start sweep} { + list ARC [list $C $rx $ry $start $sweep] +} + +# build a CHORD +# chord C rx ry start sweep +proc BL::chord {C rx ry start sweep} { + list CHORD [list $C $rx $ry $start $sweep] +} + +# build a PIE +# pie C rx ry start sweep +proc BL::pie {C rx ry start sweep} { + list PIE [list $C $rx $ry $start $sweep] +} + +proc BL::line {P0 P1} { + list LINE [list $P0 $P1] +} + +# build a POLYLINED +# polyline P0 P1 ? ... Pn? +proc BL::polyline { args } { + list POLYLINED $args +} + +proc BL::polygon { args } { + list POLYGOND $args +} + +proc BL::text { xy font string args } { + list XTEXT [list $xy $font $string {*}$args] +} + +proc BL::textbox {xy font string args} { + if { ! [info object isa object $font] || [info object class $font] ne "::BL::Font" } { + error "\"$font\" is not a BL::Font object" + } + set bbox [$font textbox $xy $string {*}$args] + lassign $bbox x0 y0 x1 y1 + list BOXD [list [list $x0 $y0] [list $x1 $y1]] +} + +proc BL::spline { args } { + list XSPLINE $args +} + +# ---------------------------------------------------------------------------- +# the following are not geometric entities , they are graphics entities ... +# ---------------------------------------------------------------------------- + +proc BL::rgb {R G B {alpha 1.0}} { + if { $alpha < 0.0 } { set alpha 0.0 } + if { $alpha > 1.0 } { set alpha 1.0 } + set hexAlpha [expr {int(255*$alpha)}] + + expr {($hexAlpha<<24) | ($R&0xFF)<<16 | ($G&0xFF)<<8 | ($B&0xFF) } +} + + # no check on arguments; they will be checked when used + # in -fill.style ... -fill.stroke +proc BL::pattern { surfaceOrFilename args } { + list PATTERN $surfaceOrFilename {*}$args +} + + # no check on arguments; they will be checked when used + # in -fill.style ... -fill.stroke +proc BL::gradient { type values stopList args } { + list GRADIENT $type $values $stopList {*}$args +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2d_filters.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2d_filters.tcl new file mode 100644 index 00000000..d052faf5 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2d_filters.tcl @@ -0,0 +1,290 @@ + +# For every new filter XXX +# two methods should be provided: +# 1) method CheckArgs-XXX { args } { ... } +# 2) method filter-XXX { ..params... } { .. } + +# filter-XXX will take every required parameter in a simple fixed format +# example: method filter-XXX { alpha beta ARGBcolor offset } +# CheckArgs-XXX will take the parameters expressed as a list of key/options +# e.g. -color blue -alpha 30 +# and return a list of values (without the keys) conformat to the expected parameters of filter-XXX +# * note: take care of missing key/value (-> provide internal default values) +# * take care of the order of the expected parameters of filter-XXX. +# Example: +# * if the expected parameters are {alpha beta ARGBcolor offset } +# and the input parameters are "-color blue -alpha 30" (NOTE: keys "-beta" and "-offset" unspecified ) +# then +# alpha takes "30" from "-alpha" parameters +# beta takes "360" from internal default +# color takes "#0xFF0000FF" from "-color" ( then converted in a proper format) +# offset takes {3 3} from internal default +# then +if 0 { + method CheckArgs-XXX {args} { + # set default values for the expected parameters + set alpha 0.0 + set beta 360.0 + set ARGBcolor 0xFF000000 + set offset {3 3} + + ... parse $args and update alpha, beta, .... + + return [list $alpha $beta $ARGBcolor $offest] + } +} +# --------------------------------------------------------------------- + + # to do .. make them public ! + # ?? are you sure that x0<=x1 and y0<=y2 ??? +proc BL::_box2rect { x0 y0 x1 y1} { + list $x0 $y0 [expr {$x1-$x0}] [expr {$y1-$y0}] +} +proc BL::_enlargedRect { x y w h dx dy} { + list [expr {$x-$dx}] [expr {$y-$dy}] [expr {$w+2*$dx}] [expr {$h+2*$dy}] +} + + +oo::define BL::Surface method CheckArgs-bw {args} { + # expected options and default values + # note: these options must be listed in the same order of the filter-bw arguments + set Args [dict create] + + set argc [llength $args] + set i 0 + while { $i < $argc } { + set opt [lindex $args $i] ; incr i + switch -- $opt { + -luma { + if { $i >= $argc } { error "option \"$opt\" requires a list of 3 floating point numbers."} + set val [lindex $args $i] ; incr i + # val should be a list of 3 float + if { [llength $val] != 3 } { + error "option \"$opt\" requires a list of 3 floating point numbers" + } + foreach v $val { + if { ! [string is double -strict $v] } { + error "option \"$opt\" requires a list of 3 floating point numbers" + } + } + dict set Args $opt $val + } + default { + error "Unrecognized option \"$opt\". Valid options are: -luma" + } + } + } + return [dict values $Args] +} + +oo::define BL::Surface method filter-bw { {luma {}} } { + set bbox [my DirtyArea] + if { $bbox != {} } { + set rect [BL::_box2rect {*}$bbox] + set options {} + if { $luma ne {} } { set options [list -luma $luma] } + my bw -rect $rect {*}$options + } +} + +oo::define BL::Surface method CheckArgs-blur {args} { + # expected options and default values + # note: these options must be listed in the same order of the Filter-blur arguments + set Args [dict create \ + -radius 5 \ + ] + set argc [llength $args] + set i 0 + while { $i < $argc } { + set opt [lindex $args $i] ; incr i + switch -- $opt { + -radius { + if { $i >= $argc } { error "option \"$opt\" requires a value."} + set val [lindex $args $i] ; incr i + if { $val eq "" || ! [string is digit $val] || $val < 1 } { + error "option \"$opt\" requires an integer > 0" + } + dict set Args $opt $val + } + default { + error "Unrecognized option \"$opt\". Valid options are [join [dict keys $Args] ","]" + } + } + } + return [dict values $Args] +} + +oo::define BL::Surface method filter-blur {radius} { + set bbox [my DirtyArea] + if { $bbox != {} } { + set rect [BL::_box2rect {*}$bbox] + set rect [BL::_enlargedRect {*}$rect $radius $radius] + my blur $radius -rect $rect + } +} + + +oo::define BL::Surface method CheckArgs-shadow {args} { + # expected options and default values + # note: these options must be listed in the same order of the Filter-shadow arguments + set Args [dict create \ + -radius 10 \ + -dxy {3 5} \ + -color [BL::color gray30] \ + ] + set argc [llength $args] + set i 0 + while { $i < $argc } { + set opt [lindex $args $i] ; incr i + switch -- $opt { + -radius { + if { $i >= $argc } { error "option \"$opt\" requires a value."} + set val [lindex $args $i] ; incr i + if { $val eq "" || ! [string is digit $val] || $val < 1 } { + error "option \"$opt\" requires an integer > 0" + } + dict set Args $opt $val + } + -dxy { + if { $i >= $argc } { error "option \"$opt\" requires a value."} + set val [lindex $args $i] ; incr i + if { [llength $val] != 2 } { + error "option \"$opt\" requires a list of two integers {dx dy}" + } + lassign $val dx dy + if { + $dx == "" || ! [string is integer $dx] + || + $dy == "" || ! [string is integer $dy] + } { + error "option \"$opt\" requires a list of two integers {dx dy}" + } + dict set Args $opt $val + } + -color { + if { $i >= $argc } { error "option \"$opt\" requires a value."} + set val [lindex $args $i] ; incr i + # if $val is not a color , raise an error .. ok + # dirty trick for checking.. + my push + try { + my configure -fill.style $val + } on error err { + error "invalid BL::color \"$val\"" + } finally { + my pop + } + dict set Args $opt $val + } + default { + error "Unrecognized option \"$opt\". Valid options are [join [dict keys $Args] ","]" + } + } + } + return [dict values $Args] +} + +oo::define BL::Surface method filter-shadow {radius dxy shadowColor} { + try { + set bbox [my DirtyArea] + if { $bbox == {} } return + + set rect [BL::_box2rect {*}$bbox] + set enlargedRect [BL::_enlargedRect {*}$rect $radius $radius] + + lassign $enlargedRect ex ey ew eh + set shadowSurf [BL::Surface new -format [list $ew $eh PRGB32]] + $shadowSurf clear -compop CLEAR + $shadowSurf copy [self] -from $rect -to [list $radius $radius] + $shadowSurf clear -style $shadowColor -compop SRC_ATOP + $shadowSurf blur $radius + + # draw the shadow UNDER the current picture (and translated) + lassign $dxy dx dy + incr ex $dx + incr ey $dy + + my rawcopy $shadowSurf -to [list $ex $ey] -compop DST_OVER + } finally { + catch {$shadowSurf destroy} + } +} + + + # PRIVATE +oo::define BL::Surface method Swap {otherSurf} { + set thisSurf [self] + rename $thisSurf ${thisSurf}__tmp + rename $otherSurf $thisSurf + rename ${thisSurf}__tmp $otherSurf +} + + # + # $surface filter _filterType_ ?_filter_arguments_? _script_ + # +oo::define BL::Surface method filter {filterType args} { + # parsing args + set filterArgs [lrange $args 0 end-1] + set script [lindex $args end] + + # no way to check if script is valid, until you execute it ! + # of course it is "complete" or it weren't passed to this method. + + #.... parse filterArgs + set validFilters {ignore bw blur shadow} + if { $filterType ni $validFilters } { + error "\"$filterType\" is not a supported filter. Valid filters are: [join $validFilters ", "]" + } + + # special shortcut: + # if filterType is "ignore", don't create all the supporting surfaces; + # just run here the script ! + if { $filterType eq "ignore"} { + # -------------- + uplevel $script + # -------------- + return + } + + # may raise error .. ok + set filterParams [my CheckArgs-${filterType} {*}$filterArgs] + try { + # -- init: create a new workSurface and redirect all the + # next operations to workSurface + set origSurfName [self] + set workSurf [my dup] + $workSurf clear -compop CLEAR + $workSurf DirtyArea on + + my Swap $workSurf + # from now, everything involving $origSurfName is redirected to the new Surface + try { + # -------------- + uplevel $script + # -------------- + } finally { + # --- turn back the redirection + my Swap $origSurfName + } + + # --------------------------------------- + $workSurf filter-${filterType} {*}$filterParams + # --------------------------------------- + + } on error err { + error $err + } on return res { + return -code return "$res" + } finally { + + set bbox [$workSurf DirtyArea] + if { $bbox != {} } { + set rect [BL::_box2rect {*}$bbox] + set xy [lrange $rect 0 1] + my rawcopy $workSurf -from $rect -to $xy + } + # OK, force a full realignment of the surface state + my CloneState $workSurf + $workSurf destroy + } +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2dsvg.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2dsvg.tcl new file mode 100644 index 00000000..1e77f6e6 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/t2dsvg.tcl @@ -0,0 +1,213 @@ + +# t2dsvg.tcl +# +# parse SVG path-data and build an equivalent BL::Path + + # load auxiliary SVGpath module for parsing the input string +source [file join [file normalize [file dirname [info script]]] SVGpath.tcl] + + +namespace eval BL::SVG { + proc buildBLPathFromSVGPathD {blPath dataStr} { + set CXY {0 0} ;# current point + set OXY {0 0} ;# initial point (Origin of the sub-path) + + set prevCmd "" + SVGpath::init $dataStr + while {1} { + lassign [SVGpath::getCmdAndArgs] cmd floats + if { $cmd == "" } break + # fix: if previous cmd was a "Z" and current cmd is NOT a M", + # then Blend2d requires an explicit moveTo() + if { [string toupper $prevCmd] eq "Z" } { + if { [string toupper $cmd] ne "M" } { + $blPath moveTo $OXY + } + } + set CXY [$cmd $blPath {*}$floats] + set prevCmd $cmd + } + return + } + + # ------------------------------------------------------------------------- + # --- internal helpers ---------------------------------------------------- + # ------------------------------------------------------------------------- + + # args is a sequence of relative coords. + # the first coord is relative to the 'base' b, + # ... + # the i-th coord is relative to the previous coord + proc absCoords { b args } { + lmap x $args { + set b [expr {$b+$x}] + } +} + + # args is a sequence of relative coord-pairs. + # the first N coord-pairs are relative to the 'base' (bx,by), + # ... + # then the last coord-pair of every group of N + # becomes the base for the next group of N coord-pairs + # + # + proc absCoordPairs { bx by N args } { + if { [llength $args] % 2 != 0 } { + error "**Incomplete coord pairs. Found odd coords." + } + set absArgs {} + set i 1 + foreach {x y} $args { + set x [expr {$bx+$x}] + set y [expr {$by+$y}] + lappend absArgs $x $y + if { $i == $N } { + set bx $x + set by $y + set i 1 + } else { + incr i + } + } + return $absArgs + } + + proc coords2coordpairs {args} { + if { [llength $args] % 2 != 0 } { + error "**Incomplete coord pairs. Found odd coords." + } + lmap {x y} $args { + list $x $y + } + } + + + # ------------------------------------------------------------------------- + # ------------------------------------------------------------------------- + # INTERNAL procs - they can be called only by buildBLPathFromSVGPathD + # since they share its local variables OXY and CXY + # ------------------------------------------------------------------------- + # ------------------------------------------------------------------------- + + # Below you can find the implementation of every 'absolute' path commands + # M, Z, L, Q, .... + # All these command must follow these rules: + # * the 1st param must be a blPath + # * they must return the new 'current point' + # (this is critical for transforming relative-path commands) + + proc M { blPath x y args } { + upvar OXY OXY + set OXY [list $x $y] + + set lastP [list $x $y] + $blPath moveTo $lastP + + # args must be 2x + if { [llength $args] % 2 != 0 } { + error "required 2x" + } + if { $args != {} } { + set lastP [L $blPath {*}$args] + } + return $lastP + } + + proc Z {blPath} { + upvar OXY OXY + $blPath close + return $OXY + } + + proc H { blPath args } { + upvar CXY CXY + lassign $CXY cx cy + + set points {} + foreach x $args { + lappend points [list $x $cy] + } + $blPath lineTo {*}$points + return [list $x $cy] + } + + proc V { blPath args } { + upvar CXY CXY + lassign $CXY cx cy + + set points {} + foreach y $args { + lappend points [list $cx $y] + } + $blPath lineTo {*}$points + return [list $cx $y] + } + + proc L { blPath args } { +# args must be 2x + $blPath lineTo {*}[coords2coordpairs {*}$args] + return [lrange $args end-1 end] + } + + proc Q { blPath args } { +# args must be 4x + $blPath quadTo {*}[coords2coordpairs {*}$args] + return [lrange $args end-1 end] + } + + proc C { blPath args } { +# args must be 6x + $blPath cubicTo {*}[coords2coordpairs {*}$args] + return [lrange $args end-1 end] + } + + proc T { blPath args } { +# args must be 2x + $blPath smoothQuadTo {*}[coords2coordpairs {*}$args] + return [lrange $args end-1 end] + } + + proc S { blPath args } { +# args must be 4x + $blPath smoothCubicTo {*}[coords2coordpairs {*}$args] + return [lrange $args end-1 end] + } + + proc A { blPath args } { +# args must be 7x + foreach {rx ry phi fa fs x y} $args { + $blPath ellipticArcTo [list $rx $ry] $phi $fa $fs [list $x $y] + } + return [lrange $args end-1 end] + } + + + # since Blend2d only works with absolute-path commands, + # we should translate the relative-path commands in terms of its equivalent ones. + + proc m {blPath args} { upvar CXY CXY; tailcall M $blPath {*}[absCoordPairs {*}$CXY 1 {*}$args] } + proc z {blPath} { tailcall Z $blPath } + proc h {blPath args} { upvar CXY CXY; tailcall H $blPath {*}[absCoords [lindex $CXY 0] {*}$args] } + proc v {blPath args} { upvar CXY CXY; tailcall V $blPath {*}[absCoords [lindex $CXY 1] {*}$args] } + proc l {blPath args} { upvar CXY CXY; tailcall L $blPath {*}[absCoordPairs {*}$CXY 1 {*}$args] } + proc q {blPath args} { upvar CXY CXY; tailcall Q $blPath {*}[absCoordPairs {*}$CXY 2 {*}$args] } + proc c {blPath args} { upvar CXY CXY; tailcall C $blPath {*}[absCoordPairs {*}$CXY 3 {*}$args] } + proc s {blPath args} { upvar CXY CXY; tailcall S $blPath {*}[absCoordPairs {*}$CXY 2 {*}$args] } + proc t {blPath args} { upvar CXY CXY; tailcall T $blPath {*}[absCoordPairs {*}$CXY 1 {*}$args] } + proc a {blPath args} { + #this is tricky because just some of the args should be converted + # in absolute coords. + upvar CXY CXY; + #since I don't want to modify CXY trough its alias, make a copy + set XY $CXY + + set newArgs {} + foreach {rx ry phi fa fs x y} $args { + # just make absolute the (x,y) point + set XY [absCoordPairs {*}$XY 1 $x $y] + lappend newArgs $rx $ry $phi $fa $fs {*}$XY + } + tailcall A $blPath {*}$newArgs + } + +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/tclBlend2D-license.terms b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/tclBlend2D-license.terms new file mode 100644 index 00000000..931c2fd4 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/tclBlend2D-license.terms @@ -0,0 +1,24 @@ +== tclBlend2D - Tcl meets Blend2D == + +tclBlend2D- Copyright (c) 2020-2024 : +Blend2D - Copyright (c) 2017-2024 Blend2D Team. +SvgAndMe - Copyright (c) 2024 William Adams. + + +* Blend2D library and its dependencies are open source software released +under the Zlib license and can be used safely in any open-source or commercial product, +statically or dynamically linked, and without advertising the use of Blend2D. +https://github.com/blend2d/blend2d/blob/master/LICENSE.md + +* SvgAndMe is distributed under the MIT license +https://github.com/Wiladams/svgandme/blob/main/LICENSE + +* tclBlend2D is distributed the following license: + +This library is free software; you can use, modify, and redistribute it +for any purpose, provided that existing copyright notices are retained +in all copies and that this notice is included verbatim in any +distributions. + +This software is distributed WITHOUT ANY WARRANTY; without even the +implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. \ No newline at end of file diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/blend2d.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/blend2d.dll new file mode 100644 index 00000000..29d8b736 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/blend2d.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/tclb2d90.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/tclb2d90.dll new file mode 100644 index 00000000..07aa6631 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/tclb2d90.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/tkb2d90.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/tkb2d90.dll new file mode 100644 index 00000000..b71d57d0 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/blend2d1.5/win-x64/tkb2d90.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/LICENSE b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/LICENSE new file mode 100644 index 00000000..415141fd --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/LICENSE @@ -0,0 +1,25 @@ +BSD 2-Clause License + +Copyright (c) 2021, apnadkarni +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl new file mode 100644 index 00000000..0f266406 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl @@ -0,0 +1,32 @@ +# +# Tcl package index file - generated from pkgIndex.tcl.in +# + +package ifneeded cffi 2.0.3 \ + [list apply [list {dir} { + package require platform + set package_ns ::cffi + set initName [string totitle cffi] + if {[package vsatisfies [package require Tcl] 9]} { + set fileName "tcl9cffi203.dll" + } else { + set fileName "cffi203t.dll" + } + set platformId [platform::identify] + set searchPaths [list [file join $dir $platformId] \ + {*}[lmap platformId [platform::patterns $platformId] { + file join $dir $platformId + }] \ + $dir] + foreach path $searchPaths { + set lib [file join $path $fileName] + if {[file exists $lib]} { + uplevel #0 [list load $lib $initName] + # Load was successful + set ${package_ns}::dll_path $lib + set ${package_ns}::package_dir $dir + return + } + } + error "Could not locate $fileName in directories [join $searchPaths {, }]" + }] $dir] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll new file mode 100644 index 00000000..cb9396d5 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/docs/doc.txt b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/docs/doc.txt new file mode 100644 index 00000000..78147a3e --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/docs/doc.txt @@ -0,0 +1,126 @@ +extrafont - 1.3 +================ + +extrafont is a package designed to provide "private fonts" for Tk apps. + +"Private fonts" are fonts usually delivered with an app. +They don't need to be installed in some 'standard' system-wide directories; +once these fonsts are loaded, they can be used in the same way of pre-installed fonts. +These loaded fonts are only visible by the process (app) who loaded'em, and then +disappear when the app terminates. + +This package provides an homogeneous multi platform mechamism for such purpose. +Supported tcltk runtimes are + * Windows (32/64 bit) + * Linux (32/64 bit) + * MacOS +You don't need to choose a specific binary runtime; it is automatically selected +when you run + package require extrafont +Note that a specific runtime support (e.g. "Linux 32") is not referred to the +hosting O.S. architecture, but it's referred to the architecture of the TclTk +interpreter. +E.g. if you have a 32-bit TclTk interpreter running on a 64-bit Linux, +then the binary extension for linux-x32 will be automaticaaly selected. + +======= + +The extrafont package provides these commands: + extrafont::load + extrafont::unload + extrafont::loaded (*deprecated obsolete*) + extrafont::query + extrafont::nameinfo + extrafont::nametable::nameIDs + extrafont::cleanup + extrafont::isAvailable + extrafont::availableFamilies + +extrafont::load _filename_ + Loads all the fonts contained in filename. These fonts will be visible to the current process only + and they will automatically disappear when the process terminates. + After loading filename, all the fonts contained in filename will be available to the current Tk app. + This command returns the list of the font-families loaded. + An error is raised if filename represents an invalid font-file, or if filename has been already loaded as an extrafont. + +extrafont::unload _filename_ + Unloads all the fonts previosly loaded with filename. + Note that if a widget is using these fonts, it may display them correctly, as long text or font-properties (e.g. size) are not changed; + in these latter cases, Tk will replace the displayed text using a default font. + +extrafont::loaded + (This command is obsolete and its use is deprecated. See extrafont::query command) + Returns a list containing the names of all currently loaded 'extrafont' font-files + +extrafont::query _kind_ ?_selector_ _pattern_? + Returns lists of different kinds (files, families, fullnames, details) about + the loaded fonts (just about the extrafont-loaded fonts), matching the optional + selection-pattern. + A selection-pattern is made by a selector (-file, -family, -fullname) and a + glob-style pattern. + Examples: + * list all the (extrafont) loaded font-files: + extrafont::query files + * list all the (extrafont) loaded font-families from font-files "Ariel*.ttf"" + extrafont::query families -file "*/Ariel*.ttf" + * list all the details of the font-family "Ariel*" + extrafont::query details -family "Ariel*" + +extrafont::nameinfo _fontfile_ ?fontPlatformName? + Returns a list of font-details. One font-detail (a dictionary) for each font + contained in $fontfile. + fontPlatformName can be ("" (default) "win" "mac" ). + If fontPlatformName is "" then the extracted info are those required for + the current platform (i.e "win" for "windows" or "mac" for all other platforms) + +extrafont::nametable::nameIDs + Returns all the valid keys used for the font-details dictionary + +extrafont::cleanup + Unloads all the loaded extrafonts. + +extrafont::isAvailable _fontFamily_ + Returns true if fontFamily is avaiable. + **WARNING** - on MacOSX after loading/unloading one or more fonts, the list + of the availables fonts won't be updated till the next event-loop update. + For this reason, if your script needs to call isAvalable/availableFamilies + just after loading/unloading a fontfile, you need to call the "update" command. + + +extrafont::availableFamilies ?_fontFamilyPattern_? + Returns the list of font-families matching the glob-style fontFamilyPattern. + e.g. + extrafont::availableFamilies co* + returns + Courier {Comic Sans MS} ..... + **WARNING** - on MacOSX after loading/unloading one or more fonts, the list + of the availables fonts won't be updated till the next event-loop update. + For this reason, if your script needs to call isAvalable/availableFamilies + just after loading/unloading a fontfile, you need to call the "update" command. + + +One important distinction to keep in mind is among + font-filename + font-family + fontname (or tk-fontname) + +Font-filename is used just for loading/unloading an external font: + set fontfamilies [extrafont::load "c:/tmp/Monoton-regular.ttf"] + +This font-file contains just one font. The font-family-name can be extracted as +result of the extrafont::load command + foreach fontfamily $fontfamilies { + puts "Loaded font-family: $fontfamily" + } + # just get the 1st font-familiy + set myNewFontFamily [lindex $fontfamilies 0] ;# --> "Monoton" + +When you want to use this new font, you should create or configure +a tk-fontname (using the standard 'font' command) + + set myfontname "tk_monoton" ;# ... choose the name you want .. + font create $myfontname -family $myNewFontFamily -size 20 + # or, let tk choose a fontname for you ... + set myfontname [font create -family $myNewFontFamily -size 20] + # then use $myfontname for a new widget ... + label .mylabel -font $myfontname -text ABC ....... diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/extrafont.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/extrafont.tcl new file mode 100644 index 00000000..731c6db7 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/extrafont.tcl @@ -0,0 +1,325 @@ +## extrafont.tcl -- a multi-platform binary package for loading "private fonts" + +## Copyright (c) 2017,2018 by A.Buratti +## +## This library is free software; you can use, modify, and redistribute it +## for any purpose, provided that existing copyright notices are retained +## in all copies and that this notice is included verbatim in any +## distributions. +## +## This software is distributed WITHOUT ANY WARRANTY; without even the +## implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +## + +namespace eval extrafont { + # FFFD-table is the core data structure holding all the relations between + # font-files, font-familiies, font-fullnames and font-details. + # *** NOTE: we are talking just about fonts loaded with extrafont::load; + # *** fonts loaded at system-level are not included here. + # They first three components FFF (font-file, font-familiy, font-fullname) + # gives you a primary key for the D component (the font-detail dictionary) + # + variable _FFFD_Table ;# array: key is (file,family,fullname) + ;# value is the font-detail + variable _File2TempFile ;# array: key is the originale filename (normalized), + ;# value is its temporary working copy + variable _TempDir + + array unset _FFFD_Table + array unset _File2TempFile + set _TempDir "" + + proc _isVfsFile {filename} { + expr { [lindex [file system $filename] 0] != "native" } + } + + # load thi submodule" fontnameinfo.tcl" in a sub-namespace + # It provides the 'nameinfo' command + namespace eval nametable { + source [file join [file dirname [info script]] fontnameinfo.tcl] + } + # when Tk is destroyed (e.g on exit), then do a cleanup + trace add command "." delete {apply { {args} {extrafont::cleanup} } } +} + + +proc extrafont::_copyToTempFile {filename} { + variable _TempDir + + if { $_TempDir == "" } { + set _TempDir [futmp::mktempdir [futmp::tempdir] extrafont_] + # don't catch error; let it raise + } + + set fd [open $filename r] ;# on error let it raise .. + fconfigure $fd -translation binary + + # note: tempfile returns an open channel ; the filename is returned via upvar (in newfilename var) + set newfilename "" + set wentWrong [catch { + set cacheChannel [futmp::tempfile newfilename $_TempDir cache_ [file extension $filename]] + fconfigure $cacheChannel -translation binary + } errmsg ] + if { $wentWrong } { + close $fd + error $errmsg + } + + set wentWrong [catch { + fcopy $fd $cacheChannel + } errmsg ] + + close $cacheChannel + close $fd + + if { $wentWrong } { + error $errmsg + } + + return $newfilename +} + + # extrafont::load fontfile + # ------------------------ + # install the fonts contained in $fontfile and return a list of font-families + # eg: "{ "Family A" "Family B" ... } + # Usually the returned list holds just one font-family. + # If you load an OpenTypeCollections (*.ttc), it may contains more than one font; + # usuallly this fonts are variants of the same font-family, but nothing prevents a *.ttc + # to include different font-families. Note that the returned list + # may contain duplicates. + # + # In order to discover the differences for these fonts of the same font-family, + # use extrafont::query ... for extracting the font-fullnames, or the full details. +proc extrafont::load {fontfile} { + variable _FFFD_Table + variable _File2TempFile + + set fontfile [file normalize $fontfile] + set orig_fontfile $fontfile + if { [array names _FFFD_Table $orig_fontfile,*] != {} } { + error "Fontfile \"$orig_fontfile\" already loaded." + } + + if { [_isVfsFile $orig_fontfile] } { + set fontfile [_copyToTempFile $orig_fontfile] ;# on error let it raise + set _File2TempFile($orig_fontfile) $fontfile + } + if { [catch {core::load $fontfile} errmsg] } { + array unset _File2TempFile $orig_fontfile + error [string map [list $fontfile $orig_fontfile] $errmsg] + } + set fontsInfo {} + # if nameinfo fails, don't stop; return an empty list + catch { + set fontsInfo [nametable::nameinfo $fontfile] + } + set FamList {} + foreach fontInfo $fontsInfo { + set family [dict get $fontInfo "fontFamily"] + set fullname [dict get $fontInfo "fullName"] + set _FFFD_Table($orig_fontfile,$family,$fullname) $fontInfo + lappend FamList $family + } + # ? should I return preferredFamily ? + return $FamList +} + + + # extrafont::unload fontfile + # -------------------------- + # Be careful: since this proc could be called when app exits, + # you cannot rely on other packages (e.g. vfs ), since they could have been destroyed before. + # Therefore DO NOT use within this proc code from other packages +proc extrafont::unload {fontfile} { + variable _FFFD_Table + variable _File2TempFile + + set fontfile [file normalize $fontfile] + + # Fix for MacOSX : + # Since core::unload does not return an error when unloading a not-loaded file, + # we must check-it before + if { $::tcl_platform(os) == "Darwin" } { + if { [query files -file $fontfile] == {} } { + error "error 0 - cannot unload font \"$fontfile\"" + } + } + set orig_fontfile $fontfile + set isVfs [info exists _File2TempFile($orig_fontfile)] + if { $isVfs } { + set fontfile $_File2TempFile($orig_fontfile) + } + if { [catch {core::unload $fontfile} errmsg] } { + error [string map [list $fontfile $orig_fontfile] $errmsg] + } + + if { $isVfs } { + catch {file delete $fontfile} ;# skip errors + unset _File2TempFile($orig_fontfile) + } + array unset _FFFD_Table $fontfile,* + return +} + + + # extrafont::loaded + # returns the list of the currently loaded (extra)font-files. + # + # OBSOLETE + # extrafont::loaded has been obsoleted by the extrafont::query command + # and it is currently suported just for backward compatibility. + # + # extrafont::loaded + # is equivalent to + # extrafont::query files +proc extrafont::loaded {} { + variable _FFFD_Table + return [query files] +} + + + # extrafont::query _kind_ ? _selector_ _pattern_ ? + # ---------------------------------------------- + # returns list of *extrafont-loaded* files,families,fullnames,details + # matching -file,-family,-fullname pattern + # NOTE: system-installed fonts are not excluded; this query deals with + # extrafonts-installed fonts only. + # Example: + # query files + # query files -file Ariel*.ttf + # query files -family Ariel* + # query families + # query families -file Ariel*.ttf + # query fullnames + # query fullnames -family Ariel* + # ... + # query details -family Ariel* +proc extrafont::query { kind args } { + variable _FFFD_Table + + set allowedValues {files families fullnames details} + if { $kind ni $allowedValues } { + error "bad kind \"$kind\": must be [join $allowedValues ","]" + } + + if { $args == {} } { + set selector "(empty)" ;# dummy selector + } elseif { [llength $args] == 2 } { + lassign $args selector selectorVal + set allowedValues {-file -family -fullname} + if { $selector ni $allowedValues } { + error "bad selector \"$selector\": must be [join $allowedValues ","]" + } + } else { + error "wrong params: query _kind_ ?selector value?" + } + + switch -- $selector { + (empty) { set pattern "*" } + -file { set pattern "$selectorVal,*,*" } + -family { set pattern "*,$selectorVal,*" } + -fullname { set pattern "*,*,$selectorVal" } + } + + set L {} + foreach { key detail } [array get _FFFD_Table $pattern] { + lassign [split $key ","] fontfile family fullname + switch -- $kind { + files { lappend L $fontfile } + families { lappend L $family } + fullnames { lappend L $fullname} + details {lappend L $detail } + } + } + lsort -unique $L +} + + + # nameinfo $fontfile ?$fontPlatformID? + # ------------------ + # Returns a list of font-info. One font-info (a dictionary) for each font + # contained in $fontfile. + # + # fontPlatformName can be used for selecting data tailored for a given platform. + # It can be ("" (default) "win" or "mac" - no support for the "Unicode platform"). + # If fontPlatformName is "" then the extracted info are those required for + # the current platform (i.e "win" for windows and "mac" for mac/linux/../restOfTheWorld) + # + # Implementation note: + # if $fontfile is loaded, then the 'cached' font-infos are returned, + # else these are extracted by calling [nametable::nameinfo $fontfile] +proc extrafont::nameinfo {fontfile {fontPlatformName ""}} { + variable _FFFD_Table + + if { $fontPlatformName eq "" } { + if { $::tcl_platform(platform) == "windows" } { + set fontPlatformName "win" + } else { + set fontPlatformName "mac" + } + } + switch -- $fontPlatformName { + "mac" { set fontPlatformID 1 } + "win" { set fontPlatformID 3 } + default { error "invalid fontPlatformName. Valid values are win, mac."} + } + + set fontfile [file normalize $fontfile] + set res [query details -file $fontfile] + if { $res == {} } { + set res [nametable::nameinfo $fontfile $fontPlatformID] + } + return $res +} + + # extrafont::cleanup + # ------------------ + # remove all the loaded extrafonts (with all the underlying OS stuff at OS level) +proc extrafont::cleanup {} { + variable _FFFD_Table + variable _File2TempFile + variable _TempDir + + foreach fontfile [query files] { + catch {unload $fontfile} ;# don't stop it now ! + } + + if { $_TempDir != "" } { + file delete -force $_TempDir ;# brute force + set _TempDir "" + } + # nothing required on the core side + return +} + + + # extrafont::isAvailable $family + # ------------------------------ + # test if a given font-family is available. + # WARNING; on MacOSX after loading/unloading one or more fonts, the list + # of the availables fonts (i.e. [font families]) won't be updated till the next event-loop update. + # For this reason, if your script needs to call isAvalable/availableFamilies + # just after loading/unloading a fontfile, you need to call the "update" command. +proc extrafont::isAvailable {family} { + expr {[lsearch -nocase -exact [font families] $family] == -1 ? false : true} +} + + + # extrafont::availableFamilies ?pattern? + # -------------------------------------- + # returns the list of available fontfamiles matching pattern. + # NOTE: + # extrafont::availableFamilies and extrafont::query families + # are quit similar, and they bot returns a list of matching font-families. + # They key difference is that + # extrafont::query families -families A* + # matches the loaded extra-fonts ONLY + # whilst + # extrafont::avalableFamilies A* + # matches all the loaded font-families (both system-wide fonts and private-fonts) + # (and it's a case-sensitive matching) + # +proc extrafont::availableFamilies { {familyPattern {*}} } { + lsearch -all -inline -glob -nocase [font families] $familyPattern +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/fontnameinfo.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/fontnameinfo.tcl new file mode 100644 index 00000000..8908c44c --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/fontnameinfo.tcl @@ -0,0 +1,337 @@ +# fontnameinfo.tcl +# +# Commands for extracting details from the "name' table of OpenType font-files. +# +# Tested with +# *.otf (including those with PostScript outlines (OTTO)) +# *.ttf +# *.ttc (OpenTypeCollections) +# +# Reference Specification: +# Opentype 1.6 - http://www.microsoft.com/typography/otspec/ +# +# This module derives from the module Glyph +# ( see http://wiki.tcl.tk/37854 ) +# which in turn is inspired by the following works: +# * org.apache.batik.svggen project (Apache License, 2.0) +# * pdf4tcl project +# Copyright (c) 2004 by Frank Richter and +# Jens Ponisch +# Copyright (c) 2006-2012 by Peter Spjuth +# Copyright (c) 2009 by Yaroslav Schekin +# * sfntutil.tcl - by Lars Hellstrom + + + # NameIDs for the name table. +set _NameID2Str [dict create {*}{ + 0 copyright + 1 fontFamily + 2 fontSubfamily + 3 uniqueID + 4 fullName + 5 version + 6 postScriptName + 7 trademark + 8 manufacturer + 9 designer + 10 description + 11 manufacturerURL + 12 designerURL + 13 license + 14 licenseURL + 15 reserved + 16 typographicFamily + 17 typographicSubfamily + 18 compatibleFullName + 19 sampleText + 20 postScriptFindFontName + 21 wwsFamily + 22 wwsSubfamily + 23 lightBackgroundPalette + 24 darkBackgroundPalette + 25 variationsPostScriptNamePrefix +}] + + # return all the valid keys for the font-info dictionary + # NOTE: none of these nameID is mandatory, but the following + # are strongly recommended: + # 1 fontFamily + # 2 fontSubfamily + # 4 fullName + # ? 16 typographicFamily + # ? 17 typographicSubfamily + # + # Reference: + # https://docs.microsoft.com/en-us/typography/opentype/spec/name#name-ids + # + # Note: currently extrafont requires just the following mandatory nameID + # fontFamily + # fullName +proc nameIDs {} { + variable _NameID2Str + dict values $_NameID2Str +} + + + # nameinfo $fontPath + # ------------------ + # scan the 'name' table(s) of $fontPath, and returns a list of font-info + # One font-info for each name table + # Each font-info is a dictionary + # (see [nameIDS] for the keys; not all the keys are mandatory) + # + # fontPlatformID can be ("" (default) 3 (windows) 1 (everything but windows ). + # If fontPlatformID is "" then the extracted info are those required for + # the current platform (i.e 3 for "windows" or 1 for mac/linux/...) + # + # An error is raised if fontPath cannot be properly parsed. +proc nameinfo {fontPath {fontPlatformID ""}} { + set fd [open $fontPath "r"] + fconfigure $fd -translation binary + set failed [catch {set names [_ReadFontFile $fd $fontPlatformID]} errMsg] + close $fd + + if { $failed } { + error $errMsg + } + return $names +} + + # _ReadFontFile $fd + # ----------------- + # return a list of font-info (usually just one font-info) + # Each font-info is a dictionary + # An error is raised if fontPath cannot be properly parsed. +proc _ReadFontFile { fd {fontPlatformID ""}} { + set fontsInfo {} + set magicTag [read $fd 4] + if { $magicTag == "ttcf" } { + set fontsOffset [_ReadTTC_Header $fd] ;# one elem for each subfont + foreach fontOffset $fontsOffset { + # go to the start of the subfont and skip the initial 'magicTag' + seek $fd [expr {$fontOffset+4}] + lappend fontsInfo [_ReadSimpleFontFile $fd $fontPlatformID] + } + } elseif { $magicTag in { "OTTO" "\x00\x01\x00\x00" "typ1" "true" } } { + lappend fontsInfo [_ReadSimpleFontFile $fd $fontPlatformID] + } else { + error "Unrecognized magic-number for OpenType font: 0x[binary encode hex $magicTag]" + } + return $fontsInfo +} + + + # _ReadTTCHeader $fd + # ------------------ + # scan the TTC header and + # returns a list of fontsOffset ( i.e. where each sub-font starts ) +proc _ReadTTC_Header {fd} { + binary scan [read $fd 8] SuSuIu majorVersion minorVersion numFonts + #extract a list of 32bit integers + binary scan [read $fd [expr {4*$numFonts}]] "Iu*" fontsOffset + + # NOTE: if majorVersion > 2 there can be a trailing digital-signature section + # ... IGNORE IT + + return $fontsOffset +} + + + # _ReadSimpleFontFile $fd + # ----------------------- + # returns a font-info dictionary (or an error ...) +proc _ReadSimpleFontFile {fd {fontPlatformID ""}} { + # Assert: we are at the beginng of the Table-Directory + binary scan [read $fd 8] SuSuSuSu numTables searchRange entrySelector rangeShift + + # scan the Table Directory ... we are just interested with the 'name' table + set tableName {} + for {set n 0} {$n<$numTables} {incr n} { + binary scan [read $fd 16] a4H8IuIu tableName _checksum start length + if { $tableName == "name" } break + } + if { $tableName != "name" } { + error "No \"name\" table found." + } + + seek $fd $start + return [_ReadTable.name $fd $length $fontPlatformID] +} + + + # _convertfromUTF16BE $data + # ------------------------- + # convert strings from UTF16BE to (tcl)Unicode strings. + # NOTE: + # When font-info is extracted from namerecords with platformID==3 (Windows) + # data (binary strings) are originally encoded in UTF16-BE. + # These data should be converted in (tcl)Unicode strings. + # Since the "tcl - unicode encoding" is BigEndian or LittleEndian, depending + # on the current platform, two variants of _convertfromUTF16BE areprovided; + # the right conversion will be choosen once at load-time. +if { $::tcl_platform(byteOrder) == "bigEndian" } { + proc _convertfromUTF16BE {data} { + encoding convertfrom unicode $data + } +} else { + proc _convertfromUTF16BE {data} { + # swp bytes, then call encoding unicode .. + binary scan $data "S*" z + encoding convertfrom unicode [binary format "s*" $z] + } +} + + # _score ... + # -------------- + # return the score (>=0) + # for every tuple of {platformID specificID languageID} + # Scores are weighted based un the target fontPlatformID +proc _score {fontPlatformID platformID specificID languageID} { + switch -- $fontPlatformID { + 1 { ;# macintosh i.e non-windows + set premium(macEnglish) 0x0100 + set premium(winEnglish_US) 0x0040 + set premium(winEnglish_UK) 0x0030 + set premium(winEnglish) 0x0020 + } + 3 { ;# windows + set premium(macEnglish) 0x000 + set premium(winEnglish_US) 0x0400 + set premium(winEnglish_UK) 0x0300 + set premium(winEnglish) 0x0200 + } + default { error "unsupported target platformID" } + } + + set score 0 + switch -- $platformID { + 0 { + # platform Unicode + set score 3 + } + 1 { + # platform Macintosh + if { $specificID == 0 } { + # MacEncodingRoman + set score 2 + } else { + return 0 ;# NO WAY !! + } + if { $languageID == 0 } { + # MacLanguageEnglish + incr score $premium(macEnglish) + } + } + 3 { + #platform Windows + switch -- $specificID { + 0 { set score 1 } ;# WindowsEncodingSymbol + 1 { set score 4 } ;# WindowsEncodingUCS2 + default { return 0 } ;# NO WAY !! + } + # try to augment score based on languageId + if { ($languageID & 0xFF) == 0x09 } { + # .. generic English + switch -- [format "0x%.4x" $languageID] { + 0x0409 { incr score $premium(winEnglish_US) } + 0x0809 { incr score $premium(winEnglish_UK) } + default { incr score $premium(winEnglish) } + } + } + } + } + return $score +} + + + # _ReadTable.name $fd + # -------------------- + # Scan the 'name' table and return a font-info dictionary. + # + # Reference Specification: + # see http://www.microsoft.com/typography/otspec/name.htm + # NOTE: + # New internal logic for selecting values among repeated values + # for different platformID encodingID languageID nameID, + # based on a score system. +proc _ReadTable.name {fd tableSize {fontPlatformID ""}} { + variable _NameID2Str + + if { $fontPlatformID eq "" } { + if { $::tcl_platform(platform) == "windows" } { + set fontPlatformID 3 + } else { + set fontPlatformID 1 + } + } + + set tableStart [tell $fd] ;# save the start of this Table + set tableEnd [expr {$tableStart+$tableSize}] + binary scan [read $fd 6] "SuSuSu" version count strRegionOffset + # we expect version == 0 ; version == 1 is not supported yet + + set strRegionStart [expr {$tableStart + $strRegionOffset}] + set strRegionSize [expr {$tableSize-$strRegionOffset}] + #Each nameRecord is made of 6 UnsignedShort + binary scan [read $fd [expr {2*6*$count}]] "Su*" nameRecords + + set nameinfo [dict create] + # initialize bestScore array + for {set nameID 0} {$nameID <= 25} {incr nameID} { + set bestScore($nameID) 0 + # no need to initialize bestPlatform, bestOffset, bestLength arrays + } + # Assert: nameRecords are sorted by platformID,encodingID,languageID,nameID + foreach { platformID specificID languageID nameID strLength strOffset } $nameRecords { + if { $nameID > 25 } continue + # Offset could be anything if length is zero. + if {$strLength == 0} continue + # Fonts are full of wrong data, if the offset is outside of the string data we simply skip the record. + if { $strOffset >= $strRegionSize || $strOffset+$strLength>$strRegionSize } continue ;# WARNING + + set score [_score $fontPlatformID $platformID $specificID $languageID] + if { $score > $bestScore($nameID) } { + set bestScore($nameID) $score + set bestOffset($nameID) $strOffset + set bestLength($nameID) $strLength + set bestPlatform($nameID) $platformID + } + } + for {set nameID 0} {$nameID <= 25} {incr nameID} { + if { $bestScore($nameID) == 0 } continue; + + set offset $bestOffset($nameID) + set length $bestLength($nameID) + seek $fd [expr {$strRegionStart+$offset}] + binary scan [read $fd $length] "a*" value + + # Windows only: extracted strings from records with platformID == 3 (windows) + # are in UTF-16BE format. They should be converted. + if { $bestPlatform($nameID) == 3 } { + set value [_convertfromUTF16BE $value] + } + + set nameIDstr [dict get $_NameID2Str $nameID] + dict set nameinfo $nameIDstr $value + } +if 0 { +# TODO ... The score logic should consider the current platform +# and then adjust the evaluation. +# BUT current platform should be an 'external' parameter, so that +# it could be used for tuning different platforms. + + # prefer typographicFamily over fontFamily + if { [dict exists $nameinfo typographicFamily] } { + dict set nameinfo fontFamily [dict get $nameinfo typographicFamily] + } + # prefer typographicSubfamily over fontSubfamily + if { [dict exists $nameinfo typographicSubfamily] } { + dict set nameinfo fontSubfamily [dict get $nameinfo typographicSubfamily] + } +} + + # if $version == 1, there should be a 'languageTag section' + # ... IGNORE IT + + return $nameinfo +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/futmp.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/futmp.tcl new file mode 100644 index 00000000..a4d63716 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/futmp.tcl @@ -0,0 +1,201 @@ +# futmp.tcl - file utilities for working with temporary files. +# +# This package is largely derived from the tcllib's package "fileutil" 1.14.10 +# The original commands' synospys has been changed to include an explicit +# base-dir and an optional file-suffix. +# +# futmp::tempdir +# futmp::tempdir _newdir_ +# futmp::mktempdir _basedir_ ?_prefix_? +# futmp::tempfile _basedir_ ?_prefix_? ?_suffix_? +# +# -Aug.2017 - A.Buratti fecit +# +# Credits for the original "fileutil" : +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2005-2013 by Andreas Kupries +# + +package provide futmp 1.14.10 + +namespace eval ::futmp { + variable tempdir {} + variable tempdirSet 0 +} + +# ::futmp::tempdir -- +# +# Return the correct directory to use for temporary files. +# Attempt this sequence, which seems logical: +# +# 1. The directory named by the `TMPDIR' environment variable. +# +# 2. The directory named by the `TEMP' environment variable. +# +# 3. The directory named by the `TMP' environment variable. +# +# 4. A platform-specific location: +# * On Macintosh, the `Temporary Items' folder. +# +# * On Windows, the directories `C:\\TEMP', `C:\\TMP', +# `\\TEMP', and `\\TMP', in that order. +# +# * On all other platforms, the directories `/tmp', +# `/var/tmp', and `/usr/tmp', in that order. +# +# 5. As a last resort, the current working directory. +# +# The code here also does +# +# 0. The directory set by invoking tempdir with an argument. +# If this is present it is used exclusively. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# The directory for temporary files. + +proc ::futmp::tempdir {args} { + if {[llength $args] > 1} { + return -code error {wrong#args: should be "::futmp::tempdir ?path?"} + } elseif {[llength $args] == 1} { + variable tempdir [lindex $args 0] + variable tempdirSet 1 + return + } + return [TempDir] +} + + +proc ::futmp::TempDir {} { + global tcl_platform env + variable tempdir + variable tempdirSet + + set attempdirs [list] + set problems {} + + if {$tempdirSet} { + lappend attempdirs $tempdir + lappend problems {User/Application specified tempdir} + } else { + foreach tmp {TMPDIR TEMP TMP} { + if { [info exists env($tmp)] } { + lappend attempdirs $env($tmp) + } else { + lappend problems "No environment variable $tmp" + } + } + + switch $tcl_platform(platform) { + windows { + lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" + } + macintosh { + lappend attempdirs $env(TRASH_FOLDER) ;# a better place? + } + default { + lappend attempdirs \ + [file join / tmp] \ + [file join / var tmp] \ + [file join / usr tmp] + } + } + + lappend attempdirs [pwd] + } + + foreach tmp $attempdirs { + if { [file isdirectory $tmp] && [file writable $tmp] } { + return $tmp + } elseif { ![file isdirectory $tmp] } { + lappend problems "Not a directory: $tmp" + } else { + lappend problems "Not writable: $tmp" + } + } + # Fail if nothing worked. + return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" +} + + +proc futmp::mktempdir { basedir {prefix {}} } { + if {![file writable $basedir]} { + return -code error "Base-Directory $basedir is not writable" + } + + set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + set nrand_chars 10 + set maxtries 10 + + for {set i 0} {$i < $maxtries} {incr i} { + set newname $prefix + for {set j 0} {$j < $nrand_chars} {incr j} { + append newname [string index $chars [expr {int(rand()*62)}]] + } + set newname [file join $basedir $newname] + + if { ! [file exists $newname] } { + # WARNING [file mkdir ..] does not return an error if $newname is already present + # For this reason we test before if the new directory is present. + # This is not perfect, since this should be an atomic operation. It isn't ! + # There's a chance that someone else will create the same $newname between + # these two operations. (Mitigation: the probability that another process + # generates another file with *same random name* in the *same interval (msec)* + # is very low. + if { ! [catch {file mkdir $newname}] } { + return $newname + } + } + } + return -code error "Failed to find an unused temporary file name" +} + + +# ::futmp::tempfile -- +# +# generate a temporary file name suitable for writing to +# the file name will be unique, writable. +# Code derived from http://mini.net/tcl/772 attributed to +# Igor Volobouev and anon. +# +# Arguments: +# basedir - where to put the new filename +# prefix - prefix for the new filename, +# extension - extension for the new filename +# Results: +# returns an opened channed (and the filename via filenameVar) or an error. +# + +proc ::futmp::tempfile { filenameVar basedir {prefix {}} {extension {}} } { + set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + set nrand_chars 10 + set maxtries 10 + set access [list RDWR CREAT EXCL] + set permission 0600 + set channel "" + + if {![file writable $basedir]} { + return -code error "Directory $basedir is not writable" + } + + for {set i 0} {$i < $maxtries} {incr i} { + set newname $prefix + for {set j 0} {$j < $nrand_chars} {incr j} { + append newname [string index $chars [expr {int(rand()*62)}]] + } + set newname [file join $basedir $newname] + append newname $extension + if { ! [catch {open $newname $access $permission} channel] } { + # Success + upvar $filenameVar newfilename + set newfilename $newname + return $channel + } + } + return -code error "Failed to find an unused temporary file name" +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/license.terms b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/license.terms new file mode 100644 index 00000000..30b53f84 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/license.terms @@ -0,0 +1,12 @@ +== Extrafont == +A multi-platform binary package for loading "private fonts" + +Copyright (c) 2017,2024 by A.Buratti + +This library is free software; you can use, modify, and redistribute it +for any purpose, provided that existing copyright notices are retained +in all copies and that this notice is included verbatim in any +distributions. + +This software is distributed WITHOUT ANY WARRANTY; without even the +implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/pkgIndex.tcl new file mode 100644 index 00000000..5d888a22 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/pkgIndex.tcl @@ -0,0 +1,50 @@ + +package ifneeded extrafont 1.3.1 [list apply { dir { + package require Tk + + set thisDir [file normalize ${dir}] + + set os $::tcl_platform(platform) + switch -- $os { + windows { set os win } + unix { + switch -- $::tcl_platform(os) { + Darwin { set os darwin } + Linux { set os linux } + } + } + } + set majorVersion [lindex [split [package present Tcl] "."] 0] + switch -- $majorVersion { + 8 {set vtag "85"} + 9 {set vtag "90"} + default { error "extrafont: Unsupported Tcl version" } + } + + set tail_libFile extrafont${vtag}[info sharedlibextension] + # try to guess the tcl-interpreter architecture (32/64 bit) + set arch $::tcl_platform(pointerSize) + switch -- $arch { + 4 { set arch x32 } + 8 { set arch x64 } + default { error "extrafont: Unsupported architecture: Unexpected pointer-size $arch!!! "} + } + + + set dir_libFile [file join $thisDir ${os}-${arch}] + if { ! [file isdirectory $dir_libFile ] } { + error "extrafont: Unsupported platform ${os}-${arch}" + } + + set full_libFile [file join $dir_libFile $tail_libFile] + load $full_libFile + + namespace eval extrafont {} + source [file join $thisDir extrafont.tcl] + source [file join $thisDir futmp.tcl] + + package provide extrafont 1.3.1 + +}} $dir] ;# end of lambda apply + + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/win-x64/extrafont90.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/win-x64/extrafont90.dll new file mode 100644 index 00000000..ab0b29e8 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/extrafont1.3.1/win-x64/extrafont90.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/netcdf0.1/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/netcdf0.1/pkgIndex.tcl new file mode 100644 index 00000000..a9d50fc4 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/netcdf0.1/pkgIndex.tcl @@ -0,0 +1,33 @@ +# -*- tcl -*- +# +# Tcl package index file - generated from pkgIndex.tcl.in +# + +package ifneeded netcdf 0.1 \ + [list apply [list {dir} { + package require platform + set package_ns ::netcdf + set initName [string totitle netcdf] + if {[package vsatisfies [package require Tcl] 9]} { + set fileName "tcl9netcdf01.dll" + } else { + set fileName "netcdf01t.dll" + } + set platformId [platform::identify] + set searchPaths [list [file join $dir $platformId] \ + {*}[lmap platformId [platform::patterns $platformId] { + file join $dir $platformId + }] \ + $dir] + foreach path $searchPaths { + set lib [file join $path $fileName] + if {[file exists $lib]} { + uplevel #0 [list load $lib $initName] + # Load was successful + set ${package_ns}::dll_path $lib + set ${package_ns}::package_dir $dir + return + } + } + error "Could not locate $fileName in directories [join $searchPaths {, }]" + }] $dir] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/netcdf0.1/tcl9netcdf01.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/netcdf0.1/tcl9netcdf01.dll new file mode 100644 index 00000000..87a56161 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/netcdf0.1/tcl9netcdf01.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.49.1/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.49.1/pkgIndex.tcl deleted file mode 100644 index e0ec2265..00000000 --- a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.49.1/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# -*- tcl -*- -# Tcl package index file, version 1.1 -# -# Note sqlite*3* init specifically -# -if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded sqlite3 3.49.1 \ - [list load [file join $dir tcl9sqlite3491.dll] Sqlite3] -} else { - package ifneeded sqlite3 3.49.1 \ - [list load [file join $dir sqlite3491.dll] Sqlite3] -} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.49.1/tcl9sqlite3491.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.49.1/tcl9sqlite3491.dll deleted file mode 100644 index 532ecda6..00000000 Binary files a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.49.1/tcl9sqlite3491.dll and /dev/null differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl new file mode 100644 index 00000000..2185fad5 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {[package vsatisfies [package provide Tcl] 9.0-]} { +package ifneeded sqlite3 3.51.0 [list load [file join $dir tcl9sqlite3510.dll] [string totitle sqlite3]] +} else { +package ifneeded sqlite3 3.51.0 [list load [file join $dir sqlite3510t.dll] [string totitle sqlite3]] +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n new file mode 100644 index 00000000..13913e55 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n @@ -0,0 +1,15 @@ +.TH sqlite3 n 4.1 "Tcl-Extensions" +.HS sqlite3 tcl +.BS +.SH NAME +sqlite3 \- an interface to the SQLite3 database engine +.SH SYNOPSIS +\fBsqlite3\fI command_name ?filename?\fR +.br +.SH DESCRIPTION +SQLite3 is a self-contains, zero-configuration, transactional SQL database +engine. This extension provides an easy to use interface for accessing +SQLite database files from Tcl. +.PP +For full documentation see \fIhttp://www.sqlite.org/\fR and +in particular \fIhttp://www.sqlite.org/tclsqlite.html\fR. diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll new file mode 100644 index 00000000..91b343f3 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/LICENSE b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/LICENSE new file mode 100644 index 00000000..99f57ab4 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2014, Ashok P. Nadkarni +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/build.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/build.tcl new file mode 100644 index 00000000..88301c47 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/build.tcl @@ -0,0 +1,49 @@ +# Simple Tcl script to build tarray +# Set up the appropriate environment and specify the corresponding -target +# Should be one of the built-in Critcl targets or if -config tarray.cfg +# is specified, one of the targets in that file. +# No checks are made that the build env and target match +# +# Example: tclsh build.tcl ext -config tarray.cfg -keep -target win32-dev64 +# NOTE: if you need to use a debugger, use -keep option so that source +# files are preserved + + +package require platform + +proc usage {} { + set script [info script] + puts "Usage:\n $script extension\n $script tea\n $script test" + exit 1 +} +set buildarea [file normalize [file join [pwd] .. build]] + +# Note argv will override -target, -pkg and -libdir options if specified + +switch -exact -- [lindex $argv 0] { + ext - + extension { + package require critcl 3.1 + package require critcl::app + critcl::app::main [list -pkg -libdir [file join $buildarea lib] -includedir [file join $buildarea include] -cache [file join $buildarea cache] -clean {*}[lrange $argv 1 end] tarray tarray.critcl] + } + tea { + critcl::app::main [list -tea -libdir [file join $buildarea tea] {*}[lrange $argv 1 end] tarray tarray.critcl] + } + test { + cd ../tests + if {[info exists env(TCLLIBPATH)]} { + set env(TCLLIBPATH) [linsert $env(TCLLIBPATH) 0 [file join $buildarea lib]] + } else { + set env(TCLLIBPATH) [list [file join $buildarea lib]] + } + set fd [open |[list [info nameofexecutable] all.tcl -notfile xtal*.test {*}[lrange $argv 1 end]]] + while {[gets $fd line] >= 0} { + puts $line + } + close $fd + } + default { + usage + } +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/dbimport.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/dbimport.tcl new file mode 100644 index 00000000..2b054c1b --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/dbimport.tcl @@ -0,0 +1,121 @@ +# +# Copyright (c) 2019, Ashok P. Nadkarni +# All rights reserved. +# +# See the file LICENSE for license +# + +namespace eval tarray::table::dbimport { + + proc map_sql_type {type nullable} { + # colmeta in form returned by tdbc in column subdictionary + # Nullable columns always returned as Tcl_Obj as we have + # there is no way to represent them for other types. + # Even the empty string rep for Tcl_Obj is incorrect but + # that's life. + if {$nullable} { + return any + } + switch -exact -- $type { + int - smallint - integer {return int} + bigint {return wide} + tinyint {return byte} + float - decimal - numeric - double {return double} + bit {return boolean} + default {return any} + } + } + + proc sql_quote_name {name} { + # Note - "" quote in MySQL requires ANSI_QUOTES option to be set + return "\"$name\"" + } + + proc is_primary_key {db tabname colname} { + # Return true if the column is a primary key in the table + + # Note, tolower because tdbc seems to convert all keys in meta information + # to lower so tabname and colname passed in are lower case + foreach keymeta [$db primarykeys [sql_quote_name $tabname]] { + if {[dict exists $keymeta columnName] && + [string equal -nocase [dict get $keymeta columnName] $colname] + } { + return 1 + } + } + return 0 + } + + proc resultset {rs vtab} { + upvar 1 $vtab tab + set orig_size [tarray::table size $tab] + if {[catch { + while {[$rs nextlist row]} { + tarray::table vinsert tab $row end + } + } result ropts]} { + # Remove any entries that were added + tarray::table vdelete tab $orig_size end + return -options $ropts $result + } + } + + proc table {db dbtable args} { + # Extract column type information. + set tabmeta [$db columns $dbtable] + if {[llength $args] == 0} { + set colnames [dict keys $tabmeta] + } elseif {[llength $args] == 1} { + set colnames [lindex $args 0] + } else { + throw {TCL WRONGARGS} "wrong # args: should \"table dbimport table DBCONN TABNAME ?COLNAMES?\"" + } + array set coltypes {} + foreach colname $colnames { + if {![dict exists $tabmeta $colname]} { + if {[dict exists $tabmeta [string tolower $colname]]} { + set colname [string tolower $colname] + } else { + error "Could not get type for column $colname in table $dbtable" + } + } + if {[is_primary_key $db $dbtable $colname]} { + set nullable 0 + } else { + set nullable [dict get $tabmeta $colname nullable] + } + set coltypes($colname) [map_sql_type [dict get $tabmeta $colname type] $nullable] + } + set sql_colnames [lmap colname $colnames {sql_quote_name $colname}] + set stmt [$db prepare "SELECT [join $sql_colnames ,] FROM [sql_quote_name $dbtable]"] + try { + set rs [$stmt execute] + set rs_colnames [$rs columns] + if {[llength $rs_colnames] == 0} { + # Empty table -> no column names in result. Use meta names gathered above + set rs_colnames $colnames + } + set column_defs [list ] + foreach colname $rs_colnames { + if {[info exists coltypes($colname)]} { + set coltype $coltypes($colname) + } elseif {[info exists coltypes([string tolower $colname])]} { + set coltype $coltypes([string tolower $colname]) + } else { + error "Could not get type for column $colname in table $dbtable" + } + lappend column_defs $colname $coltype + } + set result [tarray::table create $column_defs] + resultset $rs result + } finally { + $stmt close + } + return $result + } + + namespace export resultset table + namespace ensemble create + +} + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/parser.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/parser.tcl new file mode 100644 index 00000000..b6bee611 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/parser.tcl @@ -0,0 +1,273 @@ +package require pt::pgen +package require pt::ast +package require pt::util +package require fileutil +# Next line because the generated code has a return which +# causes script to exit if not caught +switch [catch { + eval [pt::pgen peg [fileutil::cat selector.peg] oo -class ::tarray::SelectorBase -package ::tarray::selector -version 0.1] +} msg opts] { + 0 - 2 {} + default { + return -options $opts $msg + } +} + +proc prast {s} { + set ast [parser parset $s] + tarray::selector::print $s $ast +} + +oo::class create tarray::Selector { + superclass tarray::SelectorBase + method parset text { + my variable Asts + if {! [info exists Asts($text)]} { + set Asts($text) [next $text] + } + return $Asts($text) + } + method print text { + tarray::selector::print $text [my parset $text] + } +} +tarray::Selector create tarray::selector::parser + +namespace eval tarray::selector { + namespace export print + namespace ensemble create +} + +proc tarray::selector::Print {s ast} { + set children [lassign $ast type start end] + set result [list [list <$type> :: $start $end [string range $s $start $end]]] + + # The arguments are already processed for printing + foreach c $children { + foreach line $c { + lappend result " $line" + } + } + return $result +} + + +proc tarray::selector::print {s ast} { + return [join [pt::ast::bottomup [list [namespace current]::Print $s] $ast] \n] +} + +namespace eval tarray::selector::interpreter {} + +proc tarray::selector::interpret {expr} { + set ip [Interpreter new] + try { + uplevel 1 [list $ip interpret $expr] + } finally { + $ip destroy + } +} + +oo::class create tarray::selector::Interpreter { + variable Parser Expr FrameLevel + constructor {} { + set Parser tarray::selector::parser + } + + method interpret {expr} { + set Expr $expr + set ast [$Parser parset $expr] + set FrameLevel "#[expr {[info level]-1}]" + return [my {*}$ast] + } + + method Selector {from to firstarg args} { + # firstarg broken out as separate argument because it is always required + + set result [my {*}$firstarg] + foreach {orop andterm} $args { + if {$result} break; # Shortcut evaluation + set result [my {*}$andterm] + } + return [expr {!!$result}] + } + + method AndTerm {from to firstarg args} { + # firstarg broken out as separate argument because it is always required + + set result [my {*}$firstarg] + foreach {andop boolterm} $args { + if {! $result} break; # Shortcut evaluation + set result [my {*}$boolterm] + } + return [expr {!!$result}] + } + + method BoolTerm {from to firstarg args} { + set result [my {*}$firstarg] + if {[llength $args]} { + lassign $args relop baseterm + set baseterm [my {*}$baseterm] + # Instead of defining a method for each operator, just + # pick it out from the child node + set op [string range $Expr {*}[lrange $relop 1 2]] + set result [switch -exact -- $op { + == - != - <= - >= - < - > { + tcl::mathop::$op $result $baseterm + } + + =^ { string equal -nocase $baseterm $result } + !^ { string compare -nocase $baseterm $result } + + =~ { regexp -- $baseterm $result } + !~ { expr {![regexp -- $baseterm $result]} } + =^~ { regexp -nocase -- $baseterm $result } + !^~ { expr {![regexp -nocase -- $baseterm $result]} } + + =* { string match $baseterm $result } + !* { expr {![string match $baseterm $result]} } + =^* { string match -nocase $baseterm $result } + !^* { expr {![string match -nocase $baseterm $result]} } + + default { error "Invalid operator $op" } + }] + } + return [expr {!!$result}] + } + + method BaseTerm {from to args} { + set val [my {*}[lindex $args end]] + if {[llength $args] == 1} { + return $val + } + if {[lindex [lindex $args 0] 0] ne "NotOp"} { + error "Internal error in compiler: Expected NotOp, got [lindex [lindex $args 0] 0]" + } + return [expr {! $val}] + } + + method RealNumber {from to} { + return [string range $Expr $from $to] + } + + method StringLiteral {from to} { + # Need to adjust by one char to remove enclosing quotes + return [string range $Expr [incr from] [incr to -1]] + } + + method Var {from to} { + return [uplevel $FrameLevel [list set [string range $Expr $from $to]]] + } +} + +# +# Implementation generating Tcl code + +namespace eval tarray::selector::interpreter {} + +proc tarray::selector::evaluator {expr} { + set e [Evaluator new] + try { + uplevel 1 [list $e evaluate $expr] + } finally { + $e destroy + } +} + +oo::class create tarray::selector::Compiler { + variable Parser Expr Compilations + constructor {} { + set Parser tarray::selector::parser + } + + method compile {expr} { + if {![info exists Compilations($expr)]} { + set Expr $expr + set ast [$Parser parset $expr] + set Compilations($expr) [my {*}$ast] + } + return $Compilations($expr) + } + + method evaluate {expr} { + return [uplevel 1 [my compile $expr]] + } + + method Selector {from to firstarg args} { + # firstarg broken out as separate argument because it is always required + + set result [my {*}$firstarg] + foreach {orop andterm} $args { + if {$result} break; # Shortcut evaluation + set result [my {*}$andterm] + } + return [expr {!!$result}] + } + + method AndTerm {from to firstarg args} { + # firstarg broken out as separate argument because it is always required + + set result [my {*}$firstarg] + foreach {andop boolterm} $args { + if {! $result} break; # Shortcut evaluation + set result [my {*}$boolterm] + } + return [expr {!!$result}] + } + + method BoolTerm {from to firstarg args} { + set result [my {*}$firstarg] + if {[llength $args]} { + lassign $args relop baseterm + set baseterm [my {*}$baseterm] + # Instead of defining a method for each operator, just + # pick it out from the child node + set op [string range $Expr {*}[lrange $relop 1 2]] + set result [switch -exact -- $op { + == - != - <= - >= - < - > { + tcl::mathop::$op $result $baseterm + } + + =^ { string equal -nocase $baseterm $result } + !^ { string compare -nocase $baseterm $result } + + =~ { regexp -- $baseterm $result } + !~ { expr {![regexp -- $baseterm $result]} } + =^~ { regexp -nocase -- $baseterm $result } + !^~ { expr {![regexp -nocase -- $baseterm $result]} } + + =* { string match $baseterm $result } + !* { expr {![string match $baseterm $result]} } + =^* { string match -nocase $baseterm $result } + !^* { expr {![string match -nocase $baseterm $result]} } + + default { error "Invalid operator $op" } + }] + } + return [expr {!!$result}] + } + + method BaseTerm {from to args} { + set val [my {*}[lindex $args end]] + if {[llength $args] == 1} { + return $val + } + if {[lindex [lindex $args 0] 0] ne "NotOp"} { + error "Internal error in compiler: Expected NotOp, got [lindex [lindex $args 0] 0]" + } + return [expr {! $val}] + } + + method RealNumber {from to} { + return [string range $Expr $from $to] + } + + method StringLiteral {from to} { + # Need to adjust by one char to remove enclosing quotes + return [string range $Expr [incr from] [incr to -1]] + } + + method Var {from to} { + return [uplevel $FrameLevel [list set [string range $Expr $from $to]]] + } +} + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/pkgIndex.tcl new file mode 100644 index 00000000..25673a05 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/pkgIndex.tcl @@ -0,0 +1,33 @@ +# +# Tcl package index file - generated from pkgIndex.tcl.in +# + +package ifneeded tarray 2.0a0 \ + [list apply [list {dir} { + package require platform + set package_ns ::tarray + set initName [string totitle tarray] + if {[package vsatisfies [package require Tcl] 9]} { + set fileName "tcl9tarray20a0.dll" + } else { + set fileName "tarray20a0t.dll" + } + set platformId [platform::identify] + set searchPaths [list [file join $dir $platformId] \ + {*}[lmap platformId [platform::patterns $platformId] { + file join $dir $platformId + }] \ + $dir] + foreach path $searchPaths { + set lib [file join $path $fileName] + if {[file exists $lib]} { + uplevel #0 [list load $lib $initName] + # Load was successful + set ${package_ns}::dll_path $lib + set ${package_ns}::package_dir $dir + source [file join $dir tarray.tcl] + return + } + } + error "Could not locate $fileName in directories [join $searchPaths {, }]" + }] $dir] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tabulate.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tabulate.tcl new file mode 100644 index 00000000..ce9271bd --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tabulate.tcl @@ -0,0 +1,260 @@ +#! /usr/bin/env tclsh +# Tabulate -- turn standard input into a table. +# Copyright (C) 2015 Danyil Bohdan +# License: MIT +namespace eval ::tabulate { + variable version 0.8.0 +} +namespace eval ::tabulate::style { + variable default { + top { + left \U250C + padding \U2500 + separator \U252C + right \U2510 + } + separator { + left \U251C + padding \U2500 + separator \U253C + right \U2524 + } + row { + left \U2502 + padding { } + separator \U2502 + right \U2502 + } + bottom { + left \U2514 + padding \U2500 + separator \U2534 + right \U2518 + } + } + + variable loFi { + top { + left + + padding - + separator + + right + + } + separator { + left + + padding - + separator + + right + + } + row { + left | + padding { } + separator | + right | + } + bottom { + left + + padding - + separator + + right + + } + } +} + +namespace eval ::tabulate::options {} + +# Simulate keyword arguments in procedures that accept "args". +# Usage: store in ?default ? +proc ::tabulate::options::store {name {__in__ {}} varName + {__default__ {}} {default {}}} { + if {$__in__ ne {in}} { + error "incorrect keyword: \"$__in__\" instead of \"in\"" + } + set useDefaultValue 0 + if {$__default__ ne {}} { + if {$__default__ ne {default}} { + error "incorrect keyword: \"$__default__\" instead of \"default\"" + } + set useDefaultValue 1 + } + upvar 1 args arguments + upvar 1 $varName var + if {[dict exists $arguments $name]} { + set var [dict get $arguments $name] + } else { + if {$useDefaultValue} { + set var $default + } else { + error "no argument \"$name\" given" + } + } + dict unset arguments $name +} + +# Check that the caller's $args is empty. +proc ::tabulate::options::got-all {} { + upvar 1 args arguments + set keys [dict keys $arguments] + if {[llength $keys] > 0} { + set keysQuoted {} + foreach key $keys { + lappend keysQuoted "\"$key\"" + } + error "unknown option(s): [join $keysQuoted {, }]" + } +} + +# Return a value from dictionary like [dict get] would if it is there. +# Otherwise return the default value. +proc ::tabulate::dict-get-default {dictionary default args} { + if {[dict exists $dictionary {*}$args]} { + dict get $dictionary {*}$args + } else { + return $default + } +} + +# Format a list as a table row. Does *not* append a newline after the row. +# $columnAlignments is a list that contains one alignment ("left", "right" or +# "center") for each column. If there are more columns than alignments in +# $columnAlignments "center" is assumed for those columns. +proc ::tabulate::formatRow args { + options::store -substyle in substyle + options::store -row in row + options::store -widths in columnWidths + options::store -alignments in columnAlignments default {} + options::store -margins in margins default 0 + options::got-all + + set result {} + append result [dict get $substyle left] + set fieldCount [expr { [llength $columnWidths] / 2 }] + for {set i 0} {$i < $fieldCount} {incr i} { + set field [lindex $row $i] + set padding [expr { + [dict get $columnWidths $i] - [string length $field] + 2 * $margins + }] + set alignment [lindex $columnAlignments $i] + switch -exact -- $alignment { + {} - + center { + set rightPadding [expr { $padding / 2 }] + set leftPadding [expr { $padding - $rightPadding }] + } + left { + set rightPadding [expr { $padding - $margins }] + set leftPadding $margins + } + right { + set rightPadding $margins + set leftPadding [expr { $padding - $margins }] + } + default { + error "unknown alignment: \"$alignment\"" + } + } + append result [string repeat [dict get $substyle padding] $leftPadding] + append result $field + append result [string repeat [dict get $substyle padding] $rightPadding] + if {$i < $fieldCount - 1} { + append result [dict get $substyle separator] + } + } + append result [dict get $substyle right] + return $result +} + +# Convert a list of lists into a string representing a table in pseudographics. +proc ::tabulate::tabulate args { + options::store -data in data + options::store -style in style default $::tabulate::style::default + options::store -alignments in align default {} + options::store -margins in margins default 0 + options::got-all + + # Find out the maximum width of each column. + set columnWidths {} ;# Dictionary. + foreach row $data { + for {set i 0} {$i < [llength $row]} {incr i} { + set field [lindex $row $i] + set currentLength [string length $field] + set width [::tabulate::dict-get-default $columnWidths 0 $i] + if {($currentLength > $width) || ($width == 0)} { + dict set columnWidths $i $currentLength + } + } + } + + # A dummy row for formatting the table's decorative elements with + # [formatRow]. + set emptyRow {} + for {set i 0} {$i < ([llength $columnWidths] / 2)} {incr i} { + lappend emptyRow {} + } + + set result {} + set rowCount [llength $data] + # Top of the table. + lappend result [::tabulate::formatRow \ + -substyle [dict get $style top] \ + -row $emptyRow \ + -widths $columnWidths \ + -alignments $align \ + -margins $margins] + # For each row... + for {set i 0} {$i < $rowCount} {incr i} { + set row [lindex $data $i] + # Row. + lappend result [::tabulate::formatRow \ + -substyle [dict get $style row] \ + -row $row \ + -widths $columnWidths \ + -alignments $align \ + -margins $margins] + # Separator. + if {$i < $rowCount - 1} { + lappend result [::tabulate::formatRow \ + -substyle [dict get $style separator] \ + -row $emptyRow \ + -widths $columnWidths \ + -alignments $align \ + -margins $margins] + } + } + # Bottom of the table. + lappend result [::tabulate::formatRow \ + -substyle [dict get $style bottom] \ + -row $emptyRow \ + -widths $columnWidths \ + -alignments $align \ + -margins $margins] + + return [join $result \n] +} + +# Read the input, process the command line options and output the result. +proc ::tabulate::main {argv0 argv} { + set data [lrange [split [read stdin] \n] 0 end-1] + + # Input field separator. If none is given treat each line of input as a Tcl + # list. + set FS [::tabulate::dict-get-default $argv {} -FS] + if {$FS ne {}} { + set updateData {} + foreach line $data { + lappend updateData [split $line $FS] + } + set data $updateData + dict unset argv FS + } + + puts [tabulate -data $data {*}$argv] +} + +#ifndef SQAWK +# If this is the main script... +if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} { + ::tabulate::main $argv0 $argv +} +#endif diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/taprint.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/taprint.tcl new file mode 100644 index 00000000..e99eaa30 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/taprint.tcl @@ -0,0 +1,157 @@ +# +# Copyright (c) 2012-2015, Ashok P. Nadkarni +# All rights reserved. +# +# See the file LICENSE for license +# +namespace eval tarray { + namespace eval column {} + namespace eval table {} +} + +proc tarray::_parse_print_opts {nelems optargs} { + set opts [dict merge { + -full 0 + } $optargs] + + if {[dict get $opts -full]} { + set nhead $nelems + set ntail 0 + } else { + if {[dict exists $opts -head]} { + set nhead [dict get $opts -head] + } else { + if {[dict exists $opts -tail]} { + set nhead 0 + } else { + set nhead 5 + } + } + if {[dict exists $opts -tail]} { + set ntail [dict get $opts -tail] + } else { + if {[dict exists $opts -head]} { + set ntail 0 + } else { + set ntail 5 + } + } + } + + if {($nhead + $ntail) >= $nelems} { + set nhead $nelems + set ntail 0 + } + + return [list $nhead $ntail] +} + + +proc tarray::column::prettify {c args} { + lassign [tarray::_parse_print_opts [size $c] $args] nhead ntail + if {[type $c] in {string any}} { + set sep "\n" + set sep2 "\n...\n" + } else { + set sep ", " + set sep2 "..." + } + set l {}; # In case nhead and ntail are both 0 + if {$nhead} { + set l [range -list $c 0 [expr {$nhead-1}]] + } + if {$ntail} { + set l2 [range -list $c end-[expr {$ntail-1}] end] + if {$nhead == 0} { + set l $l2 + } else { + lappend l $sep2 + set l [concat $l[set l {}] $l2] + } + } + return [join $l $sep] +} + +proc tarray::column::print {c args} { + if {[llength $args] & 1} { + set args [lassign $args chan] + } else { + set chan stdout + } + lassign [tarray::_parse_print_opts [size $c] $args] nhead ntail + puts $chan [tarray::column::prettify $c -head $nhead -tail $ntail] + return +} + +proc tarray::table::prettify {t args} { + set ncols [width $t] + set nrows [size $t] + lassign [tarray::_parse_print_opts $nrows $args] nhead ntail + + set rows [list [cnames $t]] + if {$nhead} { + set rows [concat $rows [range -list $t 0 [expr {$nhead-1}]]] + if {$ntail} { + # Separator to indicate hidden rows + lappend rows [lrepeat $ncols .] + } + } + if {$ntail} { + if {$nhead == 0} { + # Separator to indicate hidden leading rows + lappend rows [lrepeat $ncols .] + } + set rows [concat $rows [range -list $t end-[expr {$ntail-1}] end]] + } + + set alignments [lmap type [tarray::types {*}[tarray::table::columns $t]] { + switch -exact -- $type { + boolean - byte - int - uint - wide - double { lindex right } + default { lindex left } + } + }] + + if {[dict exists $args -style] && [dict get $args -style] eq "graphics"} { + # Use the default UTF-8 graphics characters for table skeleton + return [tabulate::tabulate -alignments $alignments -data $rows -style $::tabulate::style::default] + } else { + return [tabulate::tabulate -alignments $alignments -data $rows -style $::tabulate::style::loFi] + } +} + +proc tarray::table::print {t args} { + if {[llength $args] & 1} { + set args [lassign $args chan] + } else { + set chan stdout + } + lassign [tarray::_parse_print_opts [size $t] $args] nhead ntail + puts $chan [tarray::table::prettify $t -head $nhead -tail $ntail] + return +} + +proc tarray::prettify {val args} { + lassign [types $val] type + return [switch -exact -- [lindex [types $val] 0] { + "" { return -level 0 $val } + table {table prettify $val {*}$args} + default {column prettify $val {*}$args} + }] +} + +proc tarray::print {val args} { + lassign [types $val] type + return [switch -exact -- [lindex [types $val] 0] { + "" { + if {[llength $args] & 1} { + set args [lassign $args chan] + } else { + set chan stdout + } + puts $chan $val + } + table {table print $val {*}$args} + default {column print $val {*}$args} + }] +} + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tarbc.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tarbc.tcl new file mode 100644 index 00000000..f3e647dd --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tarbc.tcl @@ -0,0 +1,69 @@ +# +# Copyright (c) 2017-2018 Ashok P. Nadkarni +# All rights reserved. +# +# See the file LICENSE for license +# + +namespace eval tarray::rbc { + # TBD - document tovector and fromvector + # Define our rbc vector procedures to initialize rbc and then call + # the *redefined* commands of the same name. + variable name + foreach name {fromvector tovector} { + proc $name args "init; tailcall \[namespace current\]::$name {*}\$args" + } + unset name + + # Initializes rbc and defines the real commands + proc init {} { + proc init {} {} + + # The uplevel is required to define C commands in global context + if {[catch {uplevel #0 tarray::rbc::init_stubs}]} { + # Perhaps we are running against RBC without stubs + # Then define procedures the slow way + + proc fromvector {vec args} { + if {[llength $args] == 0} { + set first 0 + set last end + } elseif {[llength $args] == 2} { + lassign $args first last + } else { + error "wrong #args: should be \"fromvector VEC ?FIRST LAST?\"" + } + # $vec has to be resolved in context of caller + set vals [uplevel 1 [list [$vec range $first $last]]] + return [tarray::column create double $vals] + } + + proc tovector {vec col args} { + if {[llength $args] == 0} { + set vals [tarray::column range -list $col 0 end] + } elseif {[llength $args] == 1} { + set vals [tarray::column get -list $col [lindex $args 0]] + } else { + error "wrong #args: should be \"tovector VEC COLUMN ?INDICES?\"" + } + + # Note $vec has to be resolved in context of caller, hence the uplevels + set qual_vec [uplevel 1 [list namespace which -command $vec]] + if {$qual_vec eq "" || $qual_vec ni [rbc::vector names]} { + uplevel 1 [list rbc::vector create $qual_vec] + try { + $qual_vec append $vals + } trap {} {msg ropts} { + vector destroy $qual_vec + return $ropts $msg + } + } else { + $qual_vec length 0 + $qual_vec append $vals + } + return $vec; # Return same name as originally passed + } + } + } +} + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tarray.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tarray.tcl new file mode 100644 index 00000000..4b6c1635 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tarray.tcl @@ -0,0 +1,1215 @@ +# +# Copyright (c) 2015-2020, Ashok P. Nadkarni +# All rights reserved. +# +# See the file LICENSE for license +# + +namespace eval tarray { + variable package_dir + if {![info exists package_dir]} { + set package_dir [file dirname [info script]] + } + + namespace eval column { namespace path [namespace parent] } + namespace eval table { namespace path [namespace parent] } + namespace eval unsupported { namespace path [namespace parent] } + namespace eval test { namespace path [namespace parent] } + + proc lambda {arglist body {ns {}}} { + return [list ::apply [list $arglist $body $ns]] + } + + # Fully qualify command prefix + proc _fqcp {cmdprefix {level 2}} { + set cmd [lindex $cmdprefix 0] + if {[string range $cmd 0 1] eq "::"} { + return $cmdprefix + } + set qual_cmd [uplevel $level [list namespace which -command $cmd]] + if {$qual_cmd eq ""} { + error "Command $cmd not found in caller namespace." + } + return [lreplace $cmdprefix 0 0 $qual_cmd] + } + + variable limits + array set limits { + boolean {0 1} + byte {0 255} + int {-2147483648 2147483647} + uint {0 4294967295} + wide {-9223372036854775808 9223372036854775807} + } + + if {[package vsatisfies [package require Tcl] 9-] && $::tcl_platform(pointerSize) == 8} { + proc _indextype {} {return wide} + } else { + proc _indextype {} {return int} + } +} + +proc tarray::column::bitmap0 {{count 0} {init {}}} { + return [fill [fill [create boolean {} $count] 0 0 [incr count -1]] 1 $init] +} +proc tarray::column::bitmap1 {{count 0} {init {}}} { + return [fill [fill [create boolean {} $count] 1 0 [incr count -1]] 0 $init] +} + +proc tarray::column::values {col} { + return [range -list $col 0 end] +} + +proc tarray::table::rows {tab} { + return [range -list $tab 0 end] +} + +# TBD - type overflows need to be checked +# Credits: numpy linspace +proc tarray::column::linspace {start stop count args} { + dict size $args; # Verify dictionary format + + parseargs args { + {type.arg double {byte int uint wide double}} + {open.bool 0} + } -maxleftover 0 -setvars + + foreach arg {start stop} { + if {!([string is entier -strict [set $arg]] || [string is double -strict [set $arg]])} { + error "expected numeric value, got \"[set $arg]\"" + } + } + + if {![string is integer -strict $count] || $count < 0} { + error "expected non-negative numeric value, got \"$count\"" + } elseif {$count == 0} { + return [create $type] + } elseif {$count == 1} { + return [create $type [list $start]] + } + + + if {$type ne "double"} { + if {$stop >= $start} { + set upper_bound $stop + if {$open} { + incr upper_bound -1 + } + set lower_bound $start + } else { + set upper_bound $start + set lower_bound $stop + if {$open} { + incr lower_bound + } + } + lassign $::tarray::limits($type) lb ub + if {$lower_bound < $lb || $upper_bound > $ub} { + error "Interval {$start $stop} not within range for type $type." + } + } + + # NOTE: count > 1 beyond this point + + set series [series 0.0 $count 1.0]; # Note series of doubles + + # Ensure operands are treated as doubles + set start [tcl::mathfunc::double $start] + set stop [tcl::mathfunc::double $stop] + + # If closed interval, then number of interval divisions is one less than count + set div [expr {$open ? $count : ($count-1)}] + set delta [expr {$stop - $start}] + set step [expr {$delta / $div}] + + # TBD - a column vmath command would perform better here + + if {$step == 0} { + set result [math / $series $div] + set result [math * $result $delta] + } else { + set result [math * $series $step] + } + + set result [math + $result $start] + if {!$open} { + # Overwrite last element which might have exceeded bound + vfill result $stop end + } + + if {$type ne "double"} { + # TBD - perhaps round instead of casting? + return [cast $type $result] + } else { + return $result + } +} + +# Credits: numpy linspace +proc tarray::column::logspace {start stop count args} { + dict size $args; # Verify dictionary format + + parseargs args { + {type.arg double {byte int uint wide double}} + {open.bool 0} + {base.arg 10.0} + } -maxleftover 0 -setvars + + set lin [linspace $start $stop $count -open $open -type double] + set result [math ** $base $lin] + if {$type ne "double"} { + # TBD - perhaps round instead of casting? + return [cast $type $result] + } else { + return $result + } +} + +# This somewhat obtruse function calculates a heuristic based +# "reasonable" step size for a histogram when +# min == max. For example, +# min = 35 -> step = 1 +# min = 10300 -> step = 100 +# min = .020300 -> step = .0001 +# min = 2.304e25 -> step = .001e25 + +proc tarray::_histogram_default_step {val} { + if {[string is wide -strict $val]} { + # negative -> positive and + # hex/bin -> decimal + set ival [format %ld [tcl::mathfunc::abs $val]] + set exp "" + } elseif {[string is double -strict $val]} { + regexp {^-?(\d+)(?:\.0*)?(e[-+]?\d+)?$} $val -> ival exp + } else { + error "Non-numeric value '$val' for calculating default histogram step." + } + + if {[info exists ival]} { + set ndigits [string length $ival] + set nleading [string length [string trimright $ival 0]] + if {$nleading == $ndigits} { + return 1 + } + return "1[string repeat 0 [expr {$ndigits - $nleading}]]$exp" + } + + # Floating point with a fractional part + regexp {^-?\d*\.(\d+)?(e[-+]?\d+)?$} $val -> frac exp + set nfrac [string length [string trimright $frac 0]] + return "0.[string repeat 0 [expr {$nfrac - 1}]]1$exp" +} + +proc tarray::column::_histogram_boolean {col nintervals compute} { + if {$nintervals != 2} { + error "Number of intervals must be 2 for boolean columns." + } + switch -exact -- $compute { + count { + set n1 [count $col 1] + set n0 [expr {[size $col]-$n1}] + set datacol [create [_indextype] [list $n0 $n1]] + } + sum { + set datacol [create wide [list 0 [count $col 1]]] + } + indices { + set datacol [create any \ + [list \ + [search -all $col 0] \ + [search -all $col 1]]] + } + values { + set n1 [count $col 1] + set n0 [expr {[size $col]-$n1}] + set datacol [create any [list \ + [bitmap0 $n0] \ + [bitmap1 $n1]]] + } + } + return [list [column create boolean {0 1}] $datacol] +} + +proc tarray::column::histogram {args} { + parseargs args { + {compute.radio count {count sum values indices}} + min.arg + max.arg + {cnames.arg {LowerBound Data}} + } -setvars + + if {[llength $args] != 2} { + error "wrong #args: should be \"column histogram ?options? COL NINTERVALS\"." + } + lassign $args col nintervals + + if {$nintervals <= 0} { + error "Number of buckets must be greater than zero." + } + + set coltype [type $col] + if {$coltype eq "boolean"} { + return [tarray::table create2 $cnames [_histogram_boolean $col $nintervals $compute]] + } + + if {![info exists min] || ![info exists max]} { + lassign [minmax $col] smallest largest + if {![info exists min]} { + set min $smallest + } + if {![info exists max]} { + set max $largest + } + } + + if {$min > $max} { + error "Invalid bucket range $min-$max." + } + + if {$coltype eq "double"} { + # Take care to compute as doubles in case values passed in + # as integers. Note that thanks to FP inexact representations + # this is not entirely accurate. The C code will take care + # of clamping values exceeding the highest bucket to that + # bucket. + set max [tcl::mathfunc::double $max] + set min [tcl::mathfunc::double $min] + set step [expr {($max - $min) / $nintervals}] + set upper [expr {$min + $nintervals * $step}] + if {$upper < $max} { + set step [expr {$step + (($max - $upper)/$nintervals)}] + } + # Some bogus heuristics - TBD + if {$step == 0} { + set step [expr {$max - $min}] + if {$step == 0} { + set step [tarray::_histogram_default_step $min] + if {$step == 0} { + set step 1.0 + } + } + } + } else { + set step [expr {(($max - $min + ($nintervals-1)) / $nintervals)}] + if {$step == 0} { + set step 1 + } + } + + return [tarray::table::create2 $cnames [_equalintervals $col $compute $nintervals $min $max $step]] +} + +proc tarray::column::categorize {args} { + parseargs args { + {collect.radio indices {values indices}} + categorizer.arg + {cnames.arg {Category Data}} + categorytype.arg + } -setvars + + if {[llength $args] != 1} { + error "Wrong #args: should be \"column categorize ?options? COLUMN\"." + } + set col [lindex $args 0] + + set buckets {} + + # Breaking out loops in various cases is verbose but significantly faster + if {[info exists categorizer]} { + set categorizer [tarray::_fqcp $categorizer] + if {$collect eq "indices"} { + tarray::loop i e $col { + switch -exact -- [catch { {*}$categorizer $i $e } bucket ropts] { + 0 {} + 3 { break } + 4 { continue } + default { + dict incr ropts -level + return -options $ropts $bucket + } + } + dict lappend buckets $bucket $i + } + } else { + tarray::loop i e $col { + switch -exact -- [catch { {*}$categorizer $i $e } bucket ropts] { + 0 {} + 3 { break } + 4 { continue } + default { + dict incr ropts -level + return -options $ropts $bucket + } + } + dict lappend buckets $bucket $e + } + } + if {![info exists categorytype]} { + set categorytype any + } + } else { + # Categorize based on value itself + if {$collect eq "indices"} { + tarray::loop i e $col { + dict lappend buckets $e $i + } + } else { + tarray::loop i e $col { + dict lappend buckets $e $e + } + } + if {![info exists categorytype]} { + set categorytype [type $col] + } + } + + if {$collect eq "indices"} { + set indices {} + foreach bucket [dict keys $buckets] { + lappend indices [create int [dict get $buckets $bucket]] + } + set groups [create any $indices] + } else { + set values {} + foreach bucket [dict keys $buckets] { + lappend values [create [type $col] [dict get $buckets $bucket]] + } + set groups [create any $values] + } + + return [tarray::table::create2 $cnames [list [create $categorytype [dict keys $buckets]] $groups]] +} + +proc tarray::column::summarize {args} { + array set opts [parseargs args { + count + summarizer.arg + {summarytype.arg any {boolean byte int uint wide double string any}} + sum + }] + + if {[llength $args] != 1} { + error "wrong # args: should be \"column summarize ?options? DATACOL\"." + } + set data_col [lindex $args 0] + set nbuckets [size $data_col] + set opttotal [expr {$opts(sum) + $opts(count) + [info exists opts(summarizer)]}] + if {$opttotal > 1} { + error "Only one among -count, -sum and -summarizer may be specified." + } + if {$opttotal == 0} { + set opts(count) 1 + } + + if {$opts(count)} { + set col [create int {} $nbuckets] + loop i e $data_col { + vfill col [size $e] $i + } + } elseif {$opts(sum)} { + if {$nbuckets == 0} { + set col [create wide] + } else { + if {[type [index $data_col 0]] eq "double"} { + set sum_type double + } else { + set sum_type wide + } + set col [create $sum_type {} $nbuckets] + loop i e $data_col { + vfill col [sum $e] $i + } + } + } else { + set fqcn [tarray::_fqcp $opts(summarizer)] + set col [create $opts(summarytype) {} $nbuckets] + loop i e $data_col { + vfill col [{*}$fqcn $i $e] $i + } + } + + return $col +} + +# TBD - rewrite in C, doc and test +# Maps column index or name to name +proc tarray::table::cname {tab colspec} { + set cnames [cnames $tab] + if {$colspec in $cnames} { + return $colspec + } + if {![string is integer -strict $colspec]} { + error "No column with specified name '$colspec'." + } + set cname [lindex $cnames $colspec] + if {$cname eq ""} { + error "Column index '$colspec' out of bounds." + } + return $cname +} + +proc tarray::table::summarize {args} { + # Retrieve our options + parseargs args { + {cname.arg Summary} + summarizer.arg + {labelcolumn.arg 0} + {datacolumn.arg 1} + } -setvars -ignoreunknown + + # Save remaining options to be passed on + set saved_args $args + + # Strip off options to get at table argument. + # Don't really care about the values + parseargs args { + count + {summarytype.arg any {boolean byte int uint wide double string any}} + sum + } + + if {[llength $args] != 1} { + error "wrong # args: should be \"table summarize ?options? TABLE\"." + } + set tab [lindex $args 0] + set label_col_name [cname $tab $labelcolumn] + set label_col [column $tab $labelcolumn] + set data_col [column $tab $datacolumn] + + # Remove table arg from options to be passed on + set saved_args [lrange $saved_args 0 end-1] + + # We had namespace qualified the summarizer call back + # with respect to our caller. Add back that option if it + # was specified + if {[info exists summarizer]} { + # Fully qualify callback before passing it on + set fqcn [tarray::_fqcp $summarizer] + lappend saved_args -summarizer $fqcn + } + + return [create2 \ + [list $label_col_name $cname] \ + [list $label_col \ + [tarray::column::summarize {*}$saved_args $data_col]]] +} + + +proc tarray::table::create {def {init {}} {size 0}} { + set colnames {} + set cols {} + array set seen {} + foreach {colname coltype} $def { + if {[info exists seen($colname)]} { + error "Duplicate column name '$colname'." + } + set seen($colname) 1 + lappend colnames $colname + lappend cols [tarray::column::create $coltype {} $size] + } + + return [inject [list tarray_table $colnames $cols] $init end] +} + +proc tarray::table::create2 {colnames columns} { + if {[llength $colnames] != [llength $columns]} { + error "Column names differ in number from specified columns." + } + if {[llength $columns] != 0} { + foreach colname $colnames { + if {![regexp {^[_[:alpha:]][-_[:alnum:]]*$} $colname]} { + error "Invalid column name syntax '$colname'." + } + if {[info exists seen($colname)]} { + error "Duplicate column name '$colname'." + } + set seen($colname) 1 + } + # Make sure all columns are the same length + set len [tarray::column::size [lindex $columns 0]] + foreach col [lrange $columns 1 end] { + if {[tarray::column::size $col] != $len} { + throw [list TARRAY TABLE LENGTH] "Columns in table have differing lengths." + } + } + } + # TBD - does this result in columns shimmering ? + return [list tarray_table $colnames $columns] +} + +proc tarray::table::columns {tab args} { + if {[llength $args] == 0} { + return [_columns $tab] + } + if {[llength $args] > 1} { + error "wrong # args: should be \"table columns TABLE ?COLNAMES?\"" + } + set columns {} + foreach colname [lindex $args 0] { + lappend columns [column $tab $colname] + } + return $columns +} + +proc tarray::table::ctype {tab cname} { + return [tarray::column type [tarray::table::column $tab $cname]] +} + +proc tarray::table::definition {tab {cnames {}}} { + if {[llength $cnames] == 0} { + set cnames [cnames $tab] + } + set def {} + foreach cname $cnames { + lappend def $cname [tarray::column type [column $tab $cname]] + } + return $def +} + +proc tarray::table::Sort {args} { + array set opts [parseargs args { + {order.radio increasing {increasing decreasing}} + nocase + indices + columns.arg + {format.radio table {table list dict}} + } -hyphenated]; # -hyphenated to get back "-increasing", not "increasing" etc. + if {[llength $args] != 2} { + error "wrong # args: should be \"[lindex [info level 0] 0] ?options? table column" + } + lassign $args tab colname + + set sort_opts [list $opts(-order)] + if {$opts(-nocase)} { + lappend sort_opts -nocase + } + + set format_opts [list $opts(-format)] + if {[info exists opts(-columns)]} { + lappend format_opts -columns $opts(-columns) + } + + set indices [tarray::column::Sort -indices {*}$sort_opts [column $tab $colname]] + if {$opts(-indices)} { + return $indices + } else { + return [get {*}$format_opts $tab $indices] + } +} + +proc tarray::table::Join {args} { + + parseargs args { + on.arg + nocase + t0cols.arg + t1cols.arg + {t1suffix.arg _t1} + } -setvars + + if {[llength $args] != 2} { + error "wrong # args: should be \"[lindex [info level 0] 0] ?options? TABLEA TABLEB" + } + + # Variable index: + + # tab0, tab1 - input data tables + lassign $args tab0 tab1 + # cnames0, cnames1 - column names of above + set cnames0 [cnames $tab0] + set cnames1 [cnames $tab1] + + # tab0col, tab1col - names of columns to be compared + if {![info exists on] || [llength $on] == 0} { + # Loop to find the first common name. + foreach c0 $cnames0 { + foreach c1 $cnames1 { + if {$c0 eq $c1} { + set tab0col $c0 + break + } + } + } + if {![info exists tab0col]} { + error "Unable to find matching column names for join." + } + set tab1col $tab0col + } elseif {[llength $on] == 1} { + set tab0col [lindex $on 0] + set tab1col $tab0col + } elseif {[llength $on] == 2} { + lassign $on tab0col tab1col + } else { + error "At most two column names may be specified for the -on option." + } + if {$tab0col ni $cnames0} { + error "Column $tab0col not in table." + } + if {$tab1col ni $cnames1} { + error "Column $tab1col not in table." + } + + if {![info exists t0cols]} { + set t0cols $cnames0; # By default include all columns + } + + if {![info exists t1cols]} { + set t1cols $cnames1 + } + + set col0 [column $tab0 $tab0col] + set col0indices [tarray::column sort -indices $col0] + set col1 [column $tab1 $tab1col] + set col1indices [tarray::column sort -indices $col1] + lassign [tarray::column::_sortmerge_helper \ + $col0indices $col0 \ + $col1indices $col1 \ + $nocase] tab0indices tab1indices + + # Move on to the output side. Collect the names of the columns to + # be included in the output. Moreover, rename columns in case of + # clashes or if caller requested it. + # cnames{0,1} contain column names of input tables + # t{0,1}cols are names of input columns to be included in result + # tab1out are names of output columns for tab1 (potentially renamed) + # (Note currently there is no tab0out as tab0 columns are not renamed.) + + if {[llength $t0cols] == 0} { + # No columns from tab0 to be included in output so no need + # to rename tab1 columns + set tab1out $t1cols + } else { + # Rename every tab1 column that is clashing with tab0 + set tab1out [lmap c1 $t1cols { + if {$c1 in $t0cols} { + append c1 $t1suffix + } + set c1 + }] + } + + # Now retrieve the actual data + if {[llength $t0cols]} { + set out0 [columns [get -columns $t0cols $tab0 $tab0indices]] + } else { + set out0 {} + } + if {[llength $t1cols]} { + set out1 [columns [get -columns $t1cols $tab1 $tab1indices]] + } else { + set out1 {} + } + + return [create2 [concat $t0cols $tab1out] [concat $out0 $out1]] +} + +proc tarray::table::csvimport {args} { + variable tclcsv_loaded + if {![info exists tclcsv_loaded]} { + uplevel #0 package require tclcsv + set tclcsv_loaded 1 + } + + parseargs args { + encoding.arg + translation.arg + sniff + } -setvars -ignoreunknown + + if {[llength $args] == 0} { + error "wrong # args: should be \"[lindex [info level 0] 0] ?options? PATH|CHANNEL" + } + + set source [lindex $args end] + set args [lrange $args 0 end-1] + if {$source in [chan names]} { + set fd $source + set close_fd 0 + } else { + set fd [open $source r] + set close_fd 1 + } + + try { + foreach opt {encoding translation} { + if {[info exists $opt]} { + chan configure $fd -$opt [set $opt] + } + } + if {$sniff} { + set args [dict merge [tclcsv::sniff $fd] $args] + } + # Get header if present. Otherwise we will just do it later based + # on data content. + if {! [catch { + lassign [tclcsv::sniff_header {*}$args $fd] types header + set def {} + foreach type $types title $header { + if {$title eq ""} { + set title "Col_[incr colnum]" + } else { + regsub -all {[^[:alnum:]_]} $title _ title + } + lappend def $title [dict get {integer wide real double string string} $type] + } + }]} { + set tab [create $def] + if {[llength $header]} { + lappend args -startline 1 + } + } + set reader [tclcsv::reader new {*}$args $fd] + while {1} { + set recs [$reader next 1000] + if {![info exists tab]} { + # We were not able to tell table format above. Do it here + # based on content. + set colnum -1 + set def {} + foreach field [lindex $recs 0] { + lappend def ColX_[incr colnum] any + } + set tab [create $def] + } + vput tab $recs + if {[llength $recs] < 1000} { + if {[$reader eof]} { + break + } + } + } + } finally { + if {[info exists reader]} { + $reader destroy + } + if {$close_fd} { + close $fd + } + } + return $tab +} + +proc tarray::table::csvexport {args} { + variable tclcsv_loaded + if {![info exists tclcsv_loaded]} { + uplevel #0 package require tclcsv + set tclcsv_loaded 1 + } + + parseargs args { + append + force + encoding.arg + translation.arg + header.arg + } -setvars -ignoreunknown + + if {[llength $args] < 2} { + error "wrong # args: should be \"[lindex [info level 0] 0] ?options? PATH TABLE" + } + set tab [lindex $args end] + set source [lindex $args end-1] + set args [lrange $args 0 end-2] + + if {$source in [chan names]} { + set fd $source + set close_fd 0 + } else { + if {[file exists $source] && ! $append && ! $force} { + error "File $source exists. Use -force to overwrite." + } + if {$append} { + set fd [open $source a] + } else { + set fd [open $source w] + } + set close_fd 1 + } + + try { + foreach opt {encoding translation} { + if {[info exists $opt]} { + chan configure $fd -$opt [set $opt] + } + } + + if {[info exists header]} { + tclcsv::csv_write {*}$args $fd [list $header] + } + + # To reduce memory usage, write out a 1000 rows at a time + set nrows [size $tab] + set n 0 + while {$n < $nrows} { + # Note: it's ok if we pass index beyond size to table::range + ::tclcsv::csv_write {*}$args $fd [range -list $tab $n [incr n 1000]] + } + } finally { + if {$close_fd} { + close $fd + } + } +} + +proc tarray::table::identical {ta tb} { + if {[cnames $ta] ne [cnames $tb]} { + return 0; + } + foreach ca [columns $ta] cb [columns $tb] { + if {![tarray::column identical $ca $cb]} { + return 0 + } + } + return 1; +} + +proc tarray::table::equal {ta tb} { + if {[width $ta] != [width $tb]} { + return 0; + } + foreach ca [columns $ta] cb [columns $tb] { + if {![tarray::column equal $ca $cb]} { + return 0 + } + } + return 1; +} + +proc tarray::column::width {col {format %s}} { + if {[size $col] == 0} { + return 0 + } + switch -exact -- [type $col] { + boolean { set len [string length [format $format 0]] } + byte - + int - + uint - + wide - + double { + # Note length of min can be greater (consider negative numbers) + lassign [minmax $col] min max + set minlen [string length [format $format $min]] + set maxlen [string length [format $format $max]] + if {$minlen > $maxlen} { + set len $minlen + } else { + set len $maxlen + } + } + string - + any { + set len 0 + tarray::loop val $col { + set n [string length [format $format $val]] + if {$n > $len} { + set len $n + } + } + } + } + return $len +} + +proc tarray::column::zeroes {n {type int}} { + return [fill [create $type {} $n] 0 0 [expr {$n-1}]] +} + +proc tarray::column::ones {n {type int}} { + return [fill [create $type {} $n] 1 0 [expr {$n-1}]] +} + +proc tarray::unsupported::build_info {} { + set result "" + catch {append result [encoding convertfrom utf-8 [critcl_info]]} + catch { + foreach {k val} [compiler_info] { + append result "\n [format %-15s $k] $val" + } + } + append result "\n [format %-15s source_revision] [hg_id]" + return $result +} + + +proc tarray::unsupported::crandom {varname type count} { + # Do not use lrandom because that will affect memory usage in benchmarks + upvar 1 $varname col + # TBD - return entire range of floats + # TBD - larger numbers are more likely. Change to return equal + # number from each range 0-9, 10-99, 100-999 etc. + switch $type { + boolean - + byte - + int - + uint - + wide - + double { + set col [tarray::column random $type $count] + } + string - + any { + set col [tarray::column create $type {} $count] + time { + set n [expr {round(100*rand())}] + tarray::column vput col [string repeat $n $n]$type + } $count + } + default {error "Unknown type $type"} + } + return +} + +# Replace with C +proc tarray::unsupported::lrandom {varname type count} { + upvar 1 $varname l + set l {} + # TBD - return entire range of floats + # TBD - larger numbers are more likely. Change to return equal + # number from each range 0-9, 10-99, 100-999 etc. + switch $type { + boolean - + byte - + int - + uint - + wide - + double { + set r [tarray::rng new $type] + set l [$r get $count] + $r destroy + } + string - + any { + time { + set n [expr {round(100*rand())}] + lappend l [string repeat $n $n]$type + } $count + } + default {error "Unknown type $type"} + } + return +} + +namespace eval tarray::samples {} +proc tarray::samples::init {} { + variable rainfall + + set rainfall [tarray::table::create { + Month string Rainfall double Temperature double + } { + {Jan 48.7 22.12} + {Feb 78.7 24.03} + {Mar 100.3 26.38} + {Apr 439.1 27.84} + {May 1118.9 27.11} + {Jun 797.4 24.92} + {Jul 1096.8 23.99} + {Aug 1388.1 24.13} + {Sep 1858.9 24.35} + {Oct 1616.6 24.1} + {Nov 592.4 22.88} + {Dec 172 21.76} + }] + + variable freelancers + set freelancers [tarray::table create { + Id int Name string Rate int Experience int City string + } { + {1 Peter 100 15 Boston} + {2 John 85 10 {New York}} + {3 Joan 90 10 {New York}} + {4 Marcos 110 20 Chicago} + {5 Kim 95 8 {San Francisco}} + {6 Mani 105 12 Boston} + {7 Idaman 70 5 Miami} + }] + + variable freelancer_skills + set freelancer_skills [tarray::table create { + Id int Language string + } { + {1 C} + {1 C++} + {1 Java} + {1 Tcl} + {2 Java} + {2 Javascript} + {3 Objective-C} + {3 Swift} + {4 Assembler} + {4 C} + {4 C++} + {4 Tcl} + {4 {Visual Basic}} + {4 SQL} + {5 Javascript} + {5 PHP} + {5 Ruby} + {6 Fortran} + {6 R} + {6 C++} + {7 Python} + }] + + proc init {args} {} +} + +proc tarray::samples::get {tabname} { + variable $tabname + init + return [set $tabname] +} + +interp alias {} tarray::column::+ {} tarray::column::math + +interp alias {} tarray::column::- {} tarray::column::math - +interp alias {} tarray::column::* {} tarray::column::math * +interp alias {} tarray::column::/ {} tarray::column::math / +interp alias {} tarray::column::&& {} tarray::column::math && +interp alias {} tarray::column::|| {} tarray::column::math || +interp alias {} tarray::column::^^ {} tarray::column::math ^^ +interp alias {} tarray::column::& {} tarray::column::math & +interp alias {} tarray::column::| {} tarray::column::math | +interp alias {} tarray::column::^ {} tarray::column::math ^ +interp alias {} tarray::column::== {} tarray::column::math == +interp alias {} tarray::column::!= {} tarray::column::math != +interp alias {} tarray::column::< {} tarray::column::math < +interp alias {} tarray::column::<= {} tarray::column::math <= +interp alias {} tarray::column::> {} tarray::column::math > +interp alias {} tarray::column::>= {} tarray::column::math >= +interp alias {} tarray::column::** {} tarray::column::math ** + +# TBD - document fold +interp alias {} tarray::column::sum {} tarray::column::fold + + +source [file join $::tarray::package_dir tabulate.tcl] +source [file join $::tarray::package_dir taprint.tcl] +source [file join $::tarray::package_dir tarbc.tcl] +source [file join $::tarray::package_dir dbimport.tcl] + +namespace eval tarray { + + namespace eval column { + namespace ensemble create -map { + bitmap0 bitmap0 + bitmap1 bitmap1 + bucketize bucketize + cast cast + categorize categorize + count count + create create + delete delete + dump dump + equal equal + fill fill + fold fold + get get + groupby groupby + histogram histogram + identical identical + index index + inject inject + insert insert + intersect3 intersect3 + linspace linspace + logspace logspace + lookup lookup + loop ::tarray::loop + math math + minmax minmax + ones ones + place place + prettify prettify + print print + put put + random random + range range + reverse reverse + size size + search search + series series + shuffle shuffle + sort Sort + sum sum + summarize summarize + type type + values values + vdelete vdelete + vfill vfill + vinject vinject + vinsert vinsert + vplace vplace + vput vput + vreverse vreverse + vshuffle vshuffle + vsort vsort + width width + zeroes zeroes + + + + - - + * * + / / + && && + || || + ^^ ^^ + & & + | | + ^ ^ + == == + != != + < < + <= <= + > > + >= >= + ** ** + } + } + + namespace eval table { + namespace ensemble create -map { + column column + columns columns + cname cname + cnames cnames + create create + create2 create2 + csvexport csvexport + csvimport csvimport + ctype ctype + dbimport dbimport + definition definition + delete delete + equal equal + fill fill + get get + identical identical + index index + inject inject + insert insert + join Join + loop ::tarray::loop + place place + prettify prettify + print print + put put + range range + reverse reverse + rows rows + size size + slice slice + sort Sort + summarize summarize + vcolumn vcolumn + vdelete vdelete + vfill vfill + vinject vinject + vinsert vinsert + vplace vplace + vput vput + vreverse vreverse + width width + } + } + + namespace export bitmap0 bitmap1 column loop parseargs oneopt prettify print randseed rng table + +} + diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/taversion.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/taversion.tcl new file mode 100644 index 00000000..fafe442e --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/taversion.tcl @@ -0,0 +1,10 @@ +namespace eval tarray { + proc version {} {return 2.0a0} + # Print version if this file is the main script. Used during builds. + # Also check if safe interp in which case argv0 will not be defined + if {[info exists ::argv0] && [file tail [info script]] eq [file tail [lindex $::argv0 0]]} { + puts [version] + return + } +} +return [tarray::version] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tclcompiler2.0a0/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tclcompiler2.0a0/pkgIndex.tcl new file mode 100644 index 00000000..6522869e --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tclcompiler2.0a0/pkgIndex.tcl @@ -0,0 +1,5 @@ +# -*- tcl -*- +# Tcl package index file, version 1.1 +# +package ifneeded tclcompiler 2.0a0 \ + [list load [file join $dir tcl9tclcompiler20a0.dll] [string totitle tclcompiler]] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tclcompiler2.0a0/tcl9tclcompiler20a0.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tclcompiler2.0a0/tcl9tclcompiler20a0.dll new file mode 100644 index 00000000..9b2551e5 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/tclcompiler2.0a0/tcl9tclcompiler20a0.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/win32-x86_64/tcl9tarray20a0.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/win32-x86_64/tcl9tarray20a0.dll new file mode 100644 index 00000000..dedb2efe Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray2.0a0/win32-x86_64/tcl9tarray20a0.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/build.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/build.tcl new file mode 100644 index 00000000..2203700a --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/build.tcl @@ -0,0 +1,21 @@ +# Simple Tcl script to build tarray_ui + +proc usage {} { + puts "Usage:\n [info script] package" + exit 1 +} +set buildarea [file normalize [file join [pwd] .. build]] + +# Note argv will override -target, -pkg and -libdir options if specified + +switch -exact -- [lindex $argv 0] { + "" - package { + set dir [file join $buildarea lib tarray_ui] + file delete -force -- $dir + file mkdir $dir + file copy widgets.tcl rbc.tcl color.tcl pkgIndex.tcl uiversion.tcl $dir + } + default { + usage + } +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/color.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/color.tcl new file mode 100644 index 00000000..c5885033 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/color.tcl @@ -0,0 +1,130 @@ +# From http://aspn.activestate.com/ASPN/Cookbook/Tcl/Recipe/133529 +# (original code by Jeff Hobbs) +# Color manipulation routines + +namespace eval tarray::ui::color { +} + +# rgb2dec -- +# +# Turns #rgb into 3 elem list of decimal vals. +# +# Arguments: +# c The #rgb hex of the color to translate +# Results: +# Returns a #RRGGBB or #RRRRGGGGBBBB color +# +proc tarray::ui::color::rgb2dec c { + set c [string tolower $c] + if {[regexp -nocase {^#([0-9a-f])([0-9a-f])([0-9a-f])$} $c x r g b]} { + # double'ing the value make #9fc == #99ffcc + scan "$r$r $g$g $b$b" "%x %x %x" r g b + } else { + if {![regexp {^#([0-9a-f]+)$} $c junk hex] || \ + [set len [string length $hex]]>12 || $len%3 != 0} { + if {[catch {winfo rgb . $c} rgb]} { + return -code error "bad color value \"$c\"" + } else { + return $rgb + } + } + set len [expr {$len/3}] + scan $hex "%${len}x%${len}x%${len}x" r g b + } + return [list $r $g $b] +} + +# dec2rgb -- +# +# Takes a color name or dec triplet and returns a #RRGGBB color. +# If any of the incoming values are greater than 255, +# then 16 bit value are assumed, and #RRRRGGGGBBBB is +# returned, unless $clip is set. +# +# Arguments: +# r red dec value, or list of {r g b} dec value or color name +# g green dec value, or the clip value, if $r is a list +# b blue dec value +# clip Whether to force clipping to 2 char hex +# Results: +# Returns a #RRGGBB or #RRRRGGGGBBBB color +# +proc tarray::ui::color::dec2rgb {r {g 0} {b UNSET} {clip 0}} { + if {![string compare $b "UNSET"]} { + set clip $g + if {[regexp {^-?(0-9)+$} $r]} { + foreach {r g b} $r {break} + } else { + foreach {r g b} [winfo rgb . $r] {break} + } + } + set max 255 + set len 2 + if {($r > 255) || ($g > 255) || ($b > 255)} { + if {$clip} { + set r [expr {$r>>8}]; set g [expr {$g>>8}]; set b [expr {$b>>8}] + } else { + set max 65535 + set len 4 + } + } + return [format "#%.${len}X%.${len}X%.${len}X" \ + [expr {($r>$max)?$max:(($r<0)?0:$r)}] \ + [expr {($g>$max)?$max:(($g<0)?0:$g)}] \ + [expr {($b>$max)?$max:(($b<0)?0:$b)}]] +} + +# shade -- +# +# Returns a shade between two colors +# +# Arguments: +# orig start #rgb color +# dest #rgb color to shade towards +# frac fraction (0.0-1.0) to move $orig towards $dest +# Results: +# Returns a shade between two colors based on the +# +proc tarray::ui::color::shade {orig dest frac} { + if {$frac >= 1.0} { return $dest } elseif {$frac <= 0.0} { return $orig } + foreach {origR origG origB} [rgb2dec $orig] \ + {destR destG destB} [rgb2dec $dest] { + if {0} { + set shade [format "\#%02x%02x%02x" \ + [expr {int($origR+double($destR-$origR)*$frac)}] \ + [expr {int($origG+double($destG-$origG)*$frac)}] \ + [expr {int($origB+double($destB-$origB)*$frac)}]] + return $shade + } else { + return [dec2rgb \ + [expr {int($origR+double($destR-$origR)*$frac)}] \ + [expr {int($origG+double($destG-$origG)*$frac)}] \ + [expr {int($origB+double($destB-$origB)*$frac)}]] + } + } +} + +# complement -- +# +# Returns a complementary color +# Does some magic to avoid bad complements of grays +# +# Arguments: +# orig start #rgb color +# Results: +# Returns a complement of a color +# +proc tarray::ui::color::complement {orig {grays 1}} { + foreach {r g b} [rgb2dec $orig] {break} + set R [expr {(~$r)%256}] + set G [expr {(~$g)%256}] + set B [expr {(~$b)%256}] + if {$grays && abs($R-$r) < 32 && abs($G-$g) < 32 && abs($B-$b) < 32} { + set R [expr {($r+128)%256}] + set G [expr {($g+128)%256}] + set B [expr {($b+128)%256}] + } + return [format "\#%02x%02x%02x" $R $G $B] +} + +package provide [string trimleft [namespace current]::color :] 0.2 diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/pkgIndex.tcl new file mode 100644 index 00000000..9ee50a12 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/pkgIndex.tcl @@ -0,0 +1 @@ +package ifneeded tarray_ui [source [file join $dir uiversion.tcl]] [list source [file join $dir widgets.tcl]] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/rbc.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/rbc.tcl new file mode 100644 index 00000000..fcb77060 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/rbc.tcl @@ -0,0 +1,490 @@ +# (c) 2018 Ashok P. Nadkarni +# All rights reserved. +# See the file license.terms for license + +lappend auto_path d:/tcl/lib [pwd] +package require snit + +::snit::widgetadaptor tarray::ui::rbcchart { + + ################################################################ + # Type variables + + # Rbc element option names. Array indexed by element type. + typevariable _rbc_plot_option_names + + ################################################################ + # Variables + + # Keeps track of the various plots in the chart. Dictionary indexed by + # the RBC plot name and each element being a nested inner dictionary + # with the following keys + # RbcType - "element", "bar" or "line" + # XColumn - name of the corresponding X column. Only exists if the + # the plot data came from a table column. + # YColumn - name of the corresponding Y column. Only exists if the + # the plot data came from a table column. + variable _plots {} + + # When plotting graphs, we sort the data values based on the + # X value. The _sorted_indices array, indexed by column name, + # keeps track of these sorted tarray index columns. + variable _sorted_indices + + # _vectors is an nested dictionary indexed by table column names. Each + # element is a dictionary with zero or more keys each of which is + # either the empty string or the name of another table column. + # In the case of the empty string, the corresponding value is the + # name of the RBC vector corresponding to the array index column + # with values in the same order. If a non-empty string, say X, + # X must be the name of a table column. The RBC vector elements + # are then ordered in the same order as the *ascending sorted* + # value of X. For example, if C is the array column index, + # [dict get $_vectors(C) ""] is the RBC vector with elements in + # same order as C. [dict get $_vectors(C) X] is the RBC vector + # with C's elements but sorted corresponding to X's ascending order. + variable _vectors {} + + # _table holds the data table being displayed + variable _table + + # Indicates when the widget has been constructed + variable _constructed 0 + + ################################################################ + # Options + + # The column that provides the X-axis values can be specified + # as an option to the plot method. If unspecifed there, the + # default is the column specified by the -xcolumn option. + option -xcolumn "" + + delegate option * to hull + + + ################################################################ + # Methods + constructor {tab args} { + + uplevel #0 package require rbc + + set _table $tab + + installhull using rbc::graph + $self configurelist $args + + # Do not show the default axis. We will show them explicitly by defining + # axis per column + foreach axis {xaxis x2axis yaxis y2axis} { + $hull $axis use {} + } + + # Widget is constructed + set _constructed 1 + } + + destructor { + dict for {ycol xcols} $_vectors { + dict for {xcol v} $xcols { + rbc::vector destroy $v + } + } + } + + method table {} { + return $_table + } + + method column {cname} { + return [tarray::table column $_table $cname] + } + + method _create {plot_type name args} { + if {$plot_type ni {bar line element}} { + throw {TARRAY RBC INVARGS} "Unknown plot type \"$plot_type\"." + } + + if {$name in [$win element names]} { + throw {TARRAY RBC EXISTS} "Plot \"$name\" already exists in chart \"$win\." + } + if {[dict exists $args -ycolumn]} { + set cname [dict get $args -ycolumn] + if {$cname ni [tarray::table cnames $_table]} { + throw {TARRAY RBC INVCOLUMN} "Unknown column '$cname'" + } + dict unset args -ycolumn + } elseif {$name in [tarray::table cnames $_table]} { + set cname $name + } + + dict set _plots $name RbcType $plot_type + + # cname set -> plotting a table column of that name + # else -> raw data passed directly to RBC widget. + if {[info exists cname]} { + # We are plotting table column data + dict set _plots $name YColumn $cname + + set yaxis_loc [from args -yaxisloc yaxis] + if {[dict exists $args -yaxis]} { + set yaxis_name [from args -yaxis] + } else { + $self _init_axis $cname $yaxis_loc + set yaxis_name $cname + } + + lappend args -mapy $yaxis_name + if {[dict exists $args -xdata]} { + if {[dict exists $args -xcolumn]} { + throw {TARRAY RBC INVARGS} "Options -xdata and -xcolumn must not be specified together." + } + # If caller has specified -xdata, then the table column + # is assumed to already be in the desired order corresponding + # to the -xdata values. + lappend args -ydata [$self _vector $cname] + } else { + set xcolname [from args -xcolumn ""] + set xcolname [$self _get_xcolumn $xcolname] + dict set _plots $name XColumn $xcolname + + set xaxis_loc [from args -xaxisloc xaxis] + if {[dict exists $args -xaxis]} { + set xaxis_name [from args -xaxis] + } else { + $self _init_axis $xcolname $xaxis_loc + set xaxis_name $xcolname + } + + # Create an sorted x-vector and y vector in the order + # of the x-vector values + lassign [$self _xyvector $xcolname $cname] xvec yvec + dict unset args -xdata + dict unset args -ydata + dict unset args -xcolumn + lappend args -xdata $xvec -ydata $yvec -mapx $xaxis_name + } + } + + $hull $plot_type create $name {*}$args + } + method {element create} {args} { + $self _create element {*}$args + } + method {line create} {args} { + $self _create line {*}$args + } + method {bar create} {args} { + $self _create bar {*}$args + } + method _cget_plot_option {plot_name optname} { + set optname [$self _plot_option_match $plot_name $optname { + -xcolumn -ycolumn + }] + switch -exact -- $optname { + -xcolumn { + if {[dict exists $_plots $plot_name XColumn]} { + return [dict get $_plots $plot_name XColumn] + } else { + return "" + } + } + -ycolumn { + if {[dict exists $_plots $plot_name YColumn]} { + return [dict get $_plots $plot_name YColumn] + } else { + return "" + } + } + default { + return [$hull [dict get $_plots $plot_name RbcType] cget $plot_name $optname] + } + } + } + method {element cget} {plot_name optname} { + $self _cget_plot_option $plot_name $optname + } + method {line cget} {plot_name optname} { + $self _cget_plot_option $plot_name $optname + } + method {bar cget} {plot_name optname} { + $self _cget_plot_option $plot_name $optname + } + + method _configure_plot_option {plot_name optname args} { + set optname [$self _plot_option_match $plot_name $optname { + -xcolumn -ycolumn + }] + + if {[llength $args] == 0} { + # Return the corresponding option record + switch -exact -- $optname { + -xcolumn - + -ycolumn { + return [list $optname {} {} {} \ + [$self _cget_plot_option $plot_name $optname]] + } + default { + return [$hull [dict get $_plots $plot_name RbcType] configure $plot_name $optname] + } + } + } + + set optval [lindex $args 0] + switch -exact -- $optname { + -xcolumn - + -ycolumn { + error "The $optname option for a plot can only be set at plot creation time." + } + default { + return [$hull [dict get $_plots $plot_name RbcType] configure $plot_name $optname] $optval + } + } + } + + method _configure_plot {plot_name args} { + + set rbctype [dict get $_plots $plot_name RbcType] + + # If no args, return list of all options, the base RBC ones + # as well as our added ones + if {[llength $args] == 0} { + set retval [$hull $rbctype configure $plot_name] + lappend retval [$self _configure_plot_option $plot_name -xcolumn] \ + [$self _configure_plot_option $plot_name -ycolumn] + return $retval + } + + # Single option -> return its option record + if {[llength $args] == 1} { + return [$self _get_plot_option $plot_name [lindex $args 0]] + } + + if {[llength $args] & 1} { + error "Missing value for option [lindex $args end]." + } + + set rbcopts {} + foreach {optname optval} $args { + set optname [$self _plot_option_match $plot_name $optname { + -xcolumn -ycolumn + }] + switch -exact -- $optname { + -xcolumn - + -ycolumn { + $self _configure_plot_option $plot_name $optname $optval + } + default { + lappend rbcopts $optname $optval + } + } + } + + if {[llength $rbcopts]} { + $hull $rbctype configure $plot_name {*}$rbcopts + } + return + } + + method {element configure} {plot_name args} { + $self _configure_plot $plot_name {*}$args + } + method {line configure} {plot_name args} { + $self _configure_plot $plot_name {*}$args + } + method {bar configure} {plot_name args} { + $self _configure_plot $plot_name {*}$args + } + + delegate method {element *} to hull using "%c element %m" + delegate method {line *} to hull using "%c line %m" + delegate method {bar *} to hull using "%c bar %m" + + method _setup_sorted_column {cname} { + set tcol [tarray::table column $_table $cname] + set ctype [tarray::column type $tcol] + if {$ctype in {any string}} { + set n [tarray::column size $tcol] + set _sorted_indices($cname) [tarray::column series $n] + } else { + set _sorted_indices($cname) [tarray::column sort -indices $tcol] + } + return + } + + # Return an RBC vector whose elements are in the same order as + # the specfied table column. + method _vector {cname} { + # If we have already created this vector, return it. + if {[dict exists $_vectors $cname ""]} { + return [dict get $_vectors $cname ""] + } + # Create a new RBC vector + set vec [::rbc::vector create #auto] + # Copy the column elements to it + if {[catch { + tarray::rbc::tovector $vec [tarray::table::column $_table $cname] + } result ropts]} { + rbc::vector destroy $vec + return -options $ropts $result + } + # Remember it for further use + dict set _vectors $cname "" $vec + return $vec + } + + # Returns a (X RBC vector, Y RBC vector) pair for the yname table + # column whose elements are ordered based on the ascending sort + # order of the xname table column. + method _xyvector {xname yname} { + set ycol [tarray::table column $_table $yname] + if {[tarray::column type $ycol] in {string any}} { + error "Column $yname is not numeric and cannot be used for the Y-component of a graph." + } + + # The vectors generated for the graph have to be in the ascending + # sort order for the X column. So generate the indices of the + # X column in order of sorted values. + if {![info exists _sorted_indices($xname)]} { + $self _setup_sorted_column $xname + } + + # Now generate the X vector in sorted order if it does not exist + if {[dict exists $_vectors $xname $xname]} { + set xvec [dict get $_vectors $xname $xname] + } else { + set xvec [rbc::vector create #auto] + set xcol [tarray::table column $_table $xname] + if {[tarray::column type $xcol] in {any string}} { + # For non-numeric columns, the index in the table will + # act as the numeric value. That is what will be displayed + # on the axis. If a label is to be shown instead, the + # application can register an appropriate callback + # using the RBC axis configure command. + $xvec seq 0 [expr {[tarray::column size $xcol]-1}] + } else { + # Create a RBC vector for the X column in sorted order + tarray::rbc::tovector $xvec $xcol $_sorted_indices($xname) + } + dict set _vectors $xname $xname $xvec + } + + # Now generate the Y vector in sort order of X + if {[dict exists $_vectors $yname $xname]} { + set yvec [dict get $_vectors $yname $xname] + } else { + set yvec [rbc::vector create #auto] + tarray::rbc::tovector $yvec $ycol $_sorted_indices($xname) + dict set _vectors $yname $xname $yvec + } + + # Return the sorted RBC vector pair + return [list $xvec $yvec] + } + + method _get_xcolumn {{xname ""}} { + if {$xname eq ""} { + set xname $options(-xcolumn) + } + set cnames [tarray::table cnames $_table] + if {$xname ne ""} { + if {$xname in $cnames} { + return $xname + } else { + throw {TARRAY TABLE NOTFOUND} "Column $xname not found in table." + } + } + return [lindex $cnames 0] + } + + # Returns the full option name of an element configure option + # taking into account the core RBC element options as well as + # additional options passed in as $args + method _plot_option_match {plot_name optname {extra_opts {}}} { + return [tcl::prefix match \ + [concat \ + [$self _rbc_plot_options $plot_name] \ + $extra_opts \ + ] \ + $optname] + } + + # Returns RBC option names for the chart plot identified by $plot_name + method _rbc_plot_options {plot_name} { + set rbc_elem_type [dict get $_plots $plot_name RbcType] + if {! [info exists _rbc_plot_option_names($rbc_elem_type)]} { + set _rbc_plot_option_names($rbc_elem_type) \ + [lmap optrec [$hull $rbc_elem_type configure $plot_name] { + lindex $optrec 0 + }] + } + return $_rbc_plot_option_names($rbc_elem_type) + } + + # Returns 1 if the specified optname is a valid RBC option for + # the specified plot + method _is_rbc_plot_option {plot_name optname} { + return [expr {$optname in [$self _rbc_plot_options $plot_name]}] + } + + # Sets up an axis corresponding to the column $cname. + # $location should be one of xaxis, x2axis, yaxis or y2axis. + method _init_axis {cname location} { + variable _table + + set current_location [$self _find_axis $cname] + if {$current_location ne ""} { + if {$current_location eq $location} { + return; # Already set up + } + # Moving to a different physical location. Remove existing ones + $self $location use [lsearch -all -not -inline -exact [$self $location use] $cname] + } else { + # Not currently at any physical axis location but the axis might + # still exist. Create it only if it does not. + if {$location ni [$self axis names]} { + $self axis create $cname + if {[tarray::table ctype $_table $cname] in {string any}} { + # For non-numeric columns, set up callback to + $self axis configure $cname -command [mymethod _tick_label $cname] -stepsize 1 -minorticks 1.0 + } + } + } + + # Insert this axis at the end of all axes at this location + $self $location use [linsert [$self $location use] end $cname] + } + + # Gets the axis location for a column or empty string if none exists + method _find_axis {cname} { + foreach location {xaxis x2axis yaxis y2axis} { + if {$cname in [$hull $location use]} { + return $location + } + } + return "" + } + + method _tick_label {cname w tick} { + variable _table + set col [tarray::table column $_table $cname] + if {[string is integer -strict $tick] && $tick >= 0 && $tick < [tarray::column size $col]} { + return [tarray::column index $col $tick] + } + return $tick + } + + delegate method * to hull +} + +return + +#Test snippet +package require Tk +lappend auto_path ../build/lib d:/tcl/lib ; package require tarray_ui +set rain [tarray::samples::get rainfall] +tarray::ui::rbcchart .chart $rain -title "Rainfall and Temperature by Month" +.chart line create Temperature -pixels .02i +.chart axis configure Temperature -loose 1 -title "Temp (\u00b0C)" +.chart bar create Rainfall -fg green -yaxisloc y2axis +.chart axis configure Rainfall -title "Rainfall (mm)" +pack .chart diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/uiversion.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/uiversion.tcl new file mode 100644 index 00000000..75c447c5 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/uiversion.tcl @@ -0,0 +1,10 @@ +namespace eval tarray::ui { + proc version {} {return 1.0.0} + # Print version if this file is the main script. Used during builds. + # Also check if safe interp in which case argv0 will not be defined + if {[info exists ::argv0] && [file tail [info script]] eq [file tail [lindex $::argv0 0]]} { + puts [version] + return + } +} +return [tarray::ui::version] diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/widgets.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/widgets.tcl new file mode 100644 index 00000000..bc3c0050 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tarray_ui1.0.0/widgets.tcl @@ -0,0 +1,1897 @@ +# (c) 2018 Ashok P. Nadkarni +# All rights reserved. +# See the file license.terms for license + +package require Tk +package require snit +package require tarray + +namespace eval tarray::ui { + variable script_dir [file normalize [file dirname [info script]]] + proc setup_nspath {} { + uplevel 1 {namespace path [linsert [namespace path] end [namespace parent [namespace parent]]]} + } +} + +# Provide a unmanaged toplevel with basic functionality like a close button +# and ability to drag using the title bar. +snit::widget tarray::ui::unmanaged { + hulltype toplevel + + ### Option definitions + + option -title -default "" + option -closehandler -default "" + + delegate option * to hull + + ### Components + + component _titlef; # Title frame + + component _clientf; # Client frame + + ### Variables + + # Position of mouse within window while it's being dragged + variable _drag_pointer_offset_x + variable _drag_pointer_offset_y + + constructor {args} { + $hull configure -highlightthickness 1 -highlightcolor grey -highlightbackground lightgrey + + $self configurelist $args + + install _titlef using ttk::frame $win.f-title + install _clientf using ttk::frame $win.f-client + + label $_titlef.l-title -textvariable [myvar options(-title)] -font TkSmallCaptionFont -anchor c + # Bind to label for dragging window since window manager will not do + # it for us. + bind $_titlef.l-title "$win configure -cursor size" + bind $_titlef.l-title "$win configure -cursor {}" + bind $_titlef.l-title [mymethod _startdrag %W %x %y] + bind $_titlef.l-title [mymethod _drag %W %X %Y] + + label $_titlef.l-close -text X -bg [tarray::ui::color::shade [$_titlef.l-title cget -bg] black 0.2] -padx 5 + bind $_titlef.l-close "destroy $win" + + ttk::separator $_clientf.sep + + pack $_titlef.l-close -side right -fill none -expand 0 + pack $_titlef.l-title -side left -fill both -expand 1 + + pack $_clientf.sep -side top -fill both -expand 1 + + pack $_titlef -fill x -expand 0 -padx 5 + pack $_clientf -fill both -expand 1 -padx 5 + + wm overrideredirect $win 1 + } + + method getframe {} { + return $_clientf + } + + # + # Called when mouse is clicked in title bar to start dragging + method _startdrag {w x y} { + if {$w ne "$_titlef.l-title"} return + set _drag_pointer_offset_x $x + set _drag_pointer_offset_y $y + } + + # + # Called when mouse is dragged in title bar to move window + method _drag {w screenx screeny} { + if {$w ne "$_titlef.l-title"} return + wm geometry $win +[expr {$screenx - $_drag_pointer_offset_x}]+[expr {$screeny - $_drag_pointer_offset_y}] + } + +} + +snit::widget tarray::ui::dataview { + hulltype ttk::frame + + ### Type constructor + typevariable _select_foreground + typevariable _select_background + typeconstructor { + setup_nspath + set l .selcolorpicker + listbox $l + set _select_foreground [$l cget -selectforeground] + set _select_background [$l cget -selectbackground] + destroy $l + } + + option -undefinedfiltertext -default "" + + option -showfilter -default 0 -configuremethod SetShowFilter + + option -defaultsortorder -default "-increasing" + + # TBD - no need to be readonly except that we have not written the + # code to update the display on the fly when the option is changed + option -formatter -default "" -readonly 1 + option -visuals -default "" -readonly 1 + + component _treectrl + + #delegate method * to _treectrl + #delegate option * to _treectrl + delegate option -yscrolldelay to _treectrl + delegate option -xscrolldelay to _treectrl + + variable _datasource + + variable _constructed 0 + + variable _columns {} + variable _column_order {} + + variable _sort_column "" + variable _sort_order "" ;# -increasing or -decreasing + + variable _item_style_phrase {} + variable _visuals_reset_phrase {}; # Used to reset all user defined visual states + + # Column of row id's where the row id identifies a row for the data source + variable _row_ids + # Column of tktreectrl item id's. One-to-one correspondence between + # _row_ids and _item_ids, both indexed by physical (0-based) location + # in table. TBD - do we really need _item_ids? We can get it from + # $_treectrl item id [list rnc $row_index 0] + variable _item_ids + + # Saves visible state like anchor, active item, selection etc + variable _display_state {} + + # Stores various state info related to tooltips shown when mouse + # hovers over an item + variable _tooltip_state + + # Dictionary containing display strings for filters + variable _filters {} + + # Contains the name of the filter column being edited, if any + variable _filter_column_being_edited + + constructor {datasource coldefs args} { + $hull configure -borderwidth 0 + + set _datasource $datasource + + $self _parse_visuals -visuals [from args -visuals ""] + + # TBD - do we need all these scroll options? Could they impact + # shimmering + install _treectrl using treectrl $win.tbl \ + -highlightthickness 1 \ + -borderwidth 0 \ + -showroot no -showbuttons no -showlines no \ + -selectmode extended -xscrollincrement 20 -xscrollsmoothing 1 \ + -canvaspadx {2 0} -canvaspady {2 0} \ + -scrollmargin 16 -xscrolldelay "500 50" -yscrolldelay "500 50" + + # item and column identify where the mouse is hovering + # -1 indicates invalid (ie mouse is outside an item) + array set _tooltip_state {item -1 column -1 schedule_id -1} + + $_treectrl header create -tags H2 + + $_treectrl notify bind $_treectrl [mymethod %h %v] + $_treectrl notify bind $_treectrl [mymethod %D %S ] + bind $_treectrl [mymethod %x %y] + + # Define the filter header row + $_treectrl element create h2Elem text -lines 1 -justify left -statedomain header -fill blue + $_treectrl style create h2Style -orient horizontal -statedomain header + $_treectrl style elements h2Style {h2Elem} + $_treectrl style layout h2Style h2Elem -squeeze x -expand ns -padx 5 + + ttk::scrollbar $win.vscroll \ + -orient vertical \ + -command "$_treectrl yview" + $_treectrl notify bind $win.vscroll [mymethod PositionVerticalScrollbar %W %l %u] + bind $win.vscroll "focus $_treectrl" + ttk::scrollbar $win.hscroll \ + -orient horizontal \ + -command "$_treectrl xview" + $_treectrl notify bind $win.hscroll [mymethod PositionHorizontalScrollbar %W %l %u] + bind $win.hscroll "focus $_treectrl" + + grid columnconfigure $win 0 -weight 1 + grid rowconfigure $win 0 -weight 1 + grid configure $_treectrl -row 0 -column 0 -sticky news + grid configure $win.hscroll -row 1 -column 0 -sticky we + grid configure $win.vscroll -row 0 -column 1 -sticky ns + # Do not show the scroll bars right away before widget is populated. + # Otherwise, when there are too few rows, blank space appears in + # the scroll bar area whereas it should have been taken up by the + # main window. + grid remove $win.hscroll + grid remove $win.vscroll + + # Bind common keys + bind $_treectrl <> [list %W selection add all] + bind $_treectrl <> [list event generate $win <>] + bind $_treectrl <> [list event generate $win <>] + bind $_treectrl <> [list %W selection clear] + bind $_treectrl [list %W selection clear] + + # Standard mouse bindings + bind $_treectrl [mymethod ProxyMouseClicks <> %x %y] + bind $_treectrl [mymethod ProxyMouseClicks <> %x %y] + + # Create the gradient element used for coloring + $_treectrl gradient create gradientSelected \ + -stops [list [list 0.0 $_select_background 0.5] [list 1.0 $_select_background 0.0]] \ + -orient vertical + + # Define states used to control selection highlighting - which + # cell borders are merged with next cell + $_treectrl state define openW + $_treectrl state define openE + $_treectrl state define openWE + + # Do we show plain selection highlighting or a gradient-based + # fancy one ? Right now use plain version as the gradient one + # does not look that great with multiple consecutive selections. + set gradient_select 0 + #set sel_color [color::shade $_select_background white 0.7] + set sel_color $_select_background + set sel_color_nofocus lightgray + + # Define the states used for controlling visuals and collect + # the corresponding attributes for assigning to treectrl elements + set font_visuals {} + set fg_visuals {} + if {$gradient_select} { + set bg_visuals [list gradientSelected selected] + } else { + set bg_visuals [list $sel_color {selected focus}] + } + dict for {name attrs} $options(-visuals) { + $_treectrl state define $name + if {[dict exists $attrs Background]} { + lappend bg_visuals [dict get $attrs Background] $name + } + if {[dict exists $attrs Foreground]} { + lappend fg_visuals [dict get $attrs Foreground] $name + } + if {[dict exists $attrs Font]} { + lappend font_visuals [dict get $attrs Font] $name + } + } + if {! $gradient_select} { + # Background for selected items when widget does not have focus + lappend bg_visuals $sel_color_nofocus {selected !focus} + } + + if {$gradient_select} { + # The visuals corresponding to the built-in "selected" state + # always appear first as they override anything else. + $_treectrl element create bgElem rect \ + -fill $bg_visuals \ + -outline [list $sel_color selected] -rx 1 \ + -open [list we openWE w openW e openE] \ + -outlinewidth 1 + } else { + # Setting outlinewidth to 1 will show an outline around + # selected items like Win8 but when consecutive items are + # selected, the line between them is 2px wide unlike Win8 + # TBD - make this an option? + set outlinewidth 0 + if {$outlinewidth} { + $_treectrl element create bgElem rect \ + -fill $bg_visuals \ + -open [list we openWE w openW e openE] \ + -outline [list $_select_background selected] -rx 0 \ + -outlinewidth $outlinewidth + } else { + # Note - -outlinewidth has to be 1 here else only one + # item is displayed. Not sure why + $_treectrl element create bgElem rect \ + -fill $bg_visuals \ + -open [list we openWE w openW e openE] \ + -outline "" -rx 0 \ + -outlinewidth 1 + } + } + + # Create the elements for actual text + $_treectrl element create leftJustifyElem text -lines 1 -justify left -fill $fg_visuals -font $font_visuals + $_treectrl element create rightJustifyElem text -lines 1 -justify right -fill $fg_visuals -font $font_visuals + + # Create the corresponding styles + $_treectrl style create leftJustifyStyle -orient horizontal + $_treectrl style elements leftJustifyStyle {bgElem leftJustifyElem} + $_treectrl style layout leftJustifyStyle leftJustifyElem -squeeze x -expand ns -padx 5 + $_treectrl style layout leftJustifyStyle bgElem -detach yes -iexpand xy + + $_treectrl style create rightJustifyStyle -orient horizontal + $_treectrl style elements rightJustifyStyle {bgElem rightJustifyElem} + $_treectrl style layout rightJustifyStyle rightJustifyElem -squeeze x -expand ns -padx 5 + $_treectrl style layout rightJustifyStyle bgElem -detach yes -iexpand xy + + $self configurelist $args + + $_treectrl notify install + $_treectrl notify bind MyHeaderTag [mymethod %H %C] + + $_treectrl notify install + $_treectrl notify install + $_treectrl notify install + $_treectrl notify install + + $_treectrl notify bind MyHeaderTag [mymethod %C %b] + + $_treectrl header dragconfigure -enable yes + $_treectrl header dragconfigure all -enable yes -draw yes + + $self definecolumns $coldefs + set _constructed 1 + after 0 "focus $_treectrl" + } + + destructor { + } + + method _parse_visuals {opt optval} { + set visuals_reset_phrase {} + set visuals {} + dict for {name attrs} $optval { + if {![regexp {^visual[1-7]$} $name]} { + error "Unknown visual name \"$name\"." + } + lappend visuals_reset_phrase "!$name" + dict for {attr val} $attrs { + switch -exact -- $attr { + "-fg" - "-foreground" { + dict set visuals $name Foreground $val + } + "-bg" - "-background" { + dict set visuals $name Background $val + } + "-font" { dict set visuals $name Font $val } + default { + error "Unknown visual attribute \"$attr\"." + } + } + } + } + set options(-visuals) $visuals + set _visuals_reset_phrase [join $visuals_reset_phrase { }] + return + } + + method PositionHorizontalScrollbar {sb first last} { + if {$first <= 0 && $last >= 1} { + grid remove $sb + } else { + grid $sb + } + $sb set $first $last + return + } + + method PositionVerticalScrollbar {sb first last} { + if {0} { + We cannot use the PositionHorizontalScrollbar method because + gets infinite loop due to infighting between horizontal and + vertical scrollbars + if {$first <= 0 && $last >= 1} { + grid remove $sb + } else { + grid $sb + } + } + + if {0} { + This does not work because the last item may not be fully + visible but scroll bars do not show up + lassign [$self DisplayItemBounds] top_item bot_item + if {$top_item == 0 || + ($top_item == [tarray::column::index $_item_ids 0] && + $bot_item == [tarray::column::index $_item_ids end])} { + # Either table empty/too small display area, or + # both first and last items are displayed in content area + grid remove $sb + } else { + grid $sb + } + } + + # Note: The shimmering issue depends on content, font, and window + # dimensions. When tested with the test proc, setting column filter + # B to >60 followed by Col A filter to ~1 often (not always) produced + # the effect. Also Setting B to > 100 + + # Compare bottom of last item with content area bounds. + # If not visible or greater than content area, show the scroll bar + # We have to account for potential width of scrollbars to prevent + # shimmering + if {[tarray::column::size $_item_ids] == 0} { + grid remove $sb + } else { + # Bounding boxes are {left top right bottom} + set bbox [$_treectrl bbox content] + set content_top [lindex $bbox 1] + set content_bottom [lindex $bbox 3] + set first_bbox [$_treectrl item bbox [tarray::column::index $_item_ids 0]] + set first_top [lindex $first_bbox 1] + set last_bbox [$_treectrl item bbox [tarray::column::index $_item_ids end]] + set last_bottom [lindex $last_bbox 3] + # To prevent infinite shimmering between horizontal and vertical + # scrollbars, take into consideration height of the (potential) + # horizontal scrollbar. This means scrollbar will be present + # unnecessarily in some cases but no other workaround + set scroll_size [winfo height $win.hscroll] + + # treectrl docs say bbox may be empty for some reason + # so to be safe check for that and show scrollbars in that + # case as well + if {$first_top eq "" || + $last_bottom eq "" || + $first_top < $content_top || + ($last_bottom+$scroll_size) > $content_bottom} { + # Last item not visible or partially visible + grid $sb + } else { + grid remove $sb + } + } + + $sb set $first $last + return + } + + method gettreectrlpath {} { + return $_treectrl + } + + ### + # Handling of mouse clicks within table + method ProxyMouseClicks {event winx winy} { + lassign [$_treectrl identify -array state $winx $winy] type item_id col_id + if {$state(where) eq "item"} { + event generate $win $event \ + -data [list Row [ + $self ItemToRowId $state(item) + ] Column [ + $self column_id_to_name $state(column) + ]] + } + return + } + + ### + # Header event handlers + method {hdr_id col_id} { + if {$hdr_id == 0} { + set colname [$self column_id_to_name $col_id] + if {![dict get $_columns $colname Sortable]} { + return + } + # Column header, sort accordingly + if {$colname eq $_sort_column && $_sort_order eq "-increasing"} { + set order -decreasing + } else { + set order -increasing + } + $self Sort $colname $order + } elseif {$hdr_id == 1} { + $self OpenEditFilter [$self column_id_to_name $col_id] + } + return + } + + method UpdateSortIndicators {cname order} { + # Reset the existing arrow indicator on the sort column + if {$_sort_column ne ""} { + $_treectrl column configure [$self column_name_to_id $_sort_column] -arrow none -itembackground {} + } + set _sort_column $cname + set _sort_order $order + + # Set the indicator on the new sort column + if {$cname ne ""} { + if {$order eq "-increasing"} { + set arrow up + } else { + set arrow down + } + $_treectrl column configure [$self column_name_to_id $cname] -arrow $arrow -itembackground [color::shade [$_treectrl cget -background] black 0.05] + } + return + } + + ### + # Tooltip handling + method CancelTooltip {} { + if {[winfo exists $win.tooltip]} { + wm withdraw $win.tooltip + } + + set _tooltip_state(item) -1 + set _tooltip_state(column) -1 + if {$_tooltip_state(schedule_id) != -1} { + after cancel $_tooltip_state(schedule_id) + set _tooltip_state(schedule_id) -1 + } + } + + method ScheduleTooltip {item column winx winy} { + $self CancelTooltip; # Cancel pending tooltip if any + set _tooltip_state(item) $item + set _tooltip_state(column) $column + set _tooltip_state(winx) $winx + set _tooltip_state(winy) $winy + set _tooltip_state(schedule_id) [after 100 [mymethod ShowTooltip]] + } + + method ShowTooltip {} { + # Called back from event loop + set _tooltip_state(schedule_id) -1 + + if {$_tooltip_state(item) == -1 || $_tooltip_state(column) == -1} { + # No longer in an item + return + } + + # Get current font as it can be changed by user + set font [$_treectrl cget -font] + + + # Find the cell position and add to tree control position + lassign [$_treectrl item bbox $_tooltip_state(item) $_tooltip_state(column)] xpos ypos width height + set width [expr {$width - $xpos}] + set height [expr {$height -$ypos}] + + # Figure out whether the cell needs a tooltip + set text [$_treectrl item text $_tooltip_state(item) $_tooltip_state(column)] + set required_width [font measure $font -displayof $_treectrl $text] + # The margin "10" is to take care of ellipsis + if {$required_width <= ($width-10)} { + return; # Whole text is displayed, no need for tooltip + } + + # Position just above the row. That way we can see the + # whole row of interest. More important, double clicks on + # the row work. Note we position with a gap of 5 vertical pixels + # so that when the mouse moves, it enters the preceding row + # thereby canceling the tooltip + set xpos [expr {$xpos + [winfo rootx $_treectrl] + 30}] + set ypos [expr {$ypos + [winfo rooty $_treectrl] - $height - 0}] + + # Create window if it does not exist + if {![winfo exists $win.tooltip]} { + toplevel $win.tooltip + # Padding is for alignment with treectrl + label $win.tooltip.l -background [$_treectrl cget -background] -relief solid -borderwidth 1 -padx 4 -pady 0 + # We are showing tooltips ABOVE the row now so if mouse + # enters the tooltip, it means the row is not being hovered + #bind $win.tooltip [mymethod CancelTooltip] + bind $win.tooltip [mymethod ProxyMouse Enter "" %X %Y] + + # Bind mouse clicks so they get passed on to parent frame + foreach event { + Button + Shift-Button + Control-Button + Double-Button + } { + bind $win.tooltip <$event> [mymethod ProxyMouse $event %b %X %Y] + } + bind $win.tooltip "event generate $_treectrl -delta %D" + + pack $win.tooltip.l -side left -fill y + wm overrideredirect $win.tooltip 1 + wm withdraw $win.tooltip + } + + $win.tooltip.l configure -text $text -font $font + wm deiconify $win.tooltip + wm geometry $win.tooltip +$xpos+$ypos + raise $win.tooltip + } + + method ProxyMouse {event button screenx screeny} { + + if {$_tooltip_state(item) == -1} { + return; # Cannot happen, can it ? + } + + set item $_tooltip_state(item); # Save before cancel + set col $_tooltip_state(column); # Save before cancel + set winx $_tooltip_state(winx); # Save before cancel + set winy $_tooltip_state(winy); # Save before cancel + + $self CancelTooltip + focus $_treectrl + switch -exact -- "$event-$button" { + Enter- { + set rootx [winfo rootx $_treectrl] + set rooty [winfo rooty $_treectrl] + event generate $_treectrl -when tail -x [expr {$screenx-$rootx}] -y [expr {$screeny-$rooty}] + } + Button-1 { + if {0} { + # Instead, event generate below so any other actions + # will also be taken (just in case) + $_treectrl selection clear + $_treectrl selection add $item + $_treectrl selection anchor $item + } + event generate $_treectrl