1#--------------------------------------------------------------------- 2# TITLE: 3# expander.tcl 4# 5# AUTHOR: 6# Will Duquette 7# 8# DESCRIPTION: 9# 10# An expander is an object that takes as input text with embedded 11# Tcl code and returns text with the embedded code expanded. The 12# text can be provided all at once or incrementally. 13# 14# See expander.[e]html for usage info. 15# Also expander.n 16# 17# LICENSE: 18# Copyright (C) 2001 by William H. Duquette. See expander_license.txt, 19# distributed with this file, for license information. 20# 21# CHANGE LOG: 22# 23# 10/31/01: V0.9 code is complete. 24# 11/23/01: Added "evalcmd"; V1.0 code is complete. 25 26# Provide the package. 27 28# Create the package's namespace. 29 30namespace eval ::textutil { 31 namespace eval expander { 32 # All indices are prefixed by "$exp-". 33 # 34 # lb The left bracket sequence 35 # rb The right bracket sequence 36 # errmode How to handle macro errors: 37 # nothing, macro, error, fail. 38 # evalcmd The evaluation command. 39 # textcmd The plain text processing command. 40 # level The context level 41 # output-$level The accumulated text at this context level. 42 # name-$level The tag name of this context level 43 # data-$level-$var A variable of this context level 44 45 variable Info 46 47 # In methods, the current object: 48 variable This "" 49 50 # Export public commands 51 namespace export expander 52 } 53 54 #namespace import expander::* 55 namespace export expander 56 57 proc expander {name} {uplevel ::textutil::expander::expander [list $name]} 58} 59 60#--------------------------------------------------------------------- 61# FUNCTION: 62# expander name 63# 64# INPUTS: 65# name A proc name for the new object. If not 66# fully-qualified, it is assumed to be relative 67# to the caller's namespace. 68# 69# RETURNS: 70# nothing 71# 72# DESCRIPTION: 73# Creates a new expander object. 74 75proc ::textutil::expander::expander {name} { 76 variable Info 77 78 # FIRST, qualify the name. 79 if {![string match "::*" $name]} { 80 # Get caller's namespace; append :: if not global namespace. 81 set ns [uplevel 1 namespace current] 82 if {"::" != $ns} { 83 append ns "::" 84 } 85 86 set name "$ns$name" 87 } 88 89 # NEXT, Check the name 90 if {"" != [info commands $name]} { 91 return -code error "command name \"$name\" already exists" 92 } 93 94 # NEXT, Create the object. 95 proc $name {method args} [format { 96 if {[catch {::textutil::expander::Methods %s $method $args} result]} { 97 return -code error $result 98 } else { 99 return $result 100 } 101 } $name] 102 103 # NEXT, Initialize the object 104 Op_reset $name 105 106 return $name 107} 108 109#--------------------------------------------------------------------- 110# FUNCTION: 111# Methods name method argList 112# 113# INPUTS: 114# name The object's fully qualified procedure name. 115# This argument is provided by the object command 116# itself. 117# method The method to call. 118# argList Arguments for the specific method. 119# 120# RETURNS: 121# Depends on the method 122# 123# DESCRIPTION: 124# Handles all method dispatch for a expander object. 125# The expander's object command merely passes its arguments to 126# this function, which dispatches the arguments to the 127# appropriate method procedure. If the method raises an error, 128# the method procedure's name in the error message is replaced 129# by the object and method names. 130 131proc ::textutil::expander::Methods {name method argList} { 132 variable Info 133 variable This 134 135 switch -exact -- $method { 136 expand - 137 lb - 138 rb - 139 setbrackets - 140 errmode - 141 evalcmd - 142 textcmd - 143 cpush - 144 ctopandclear - 145 cis - 146 cname - 147 cset - 148 cget - 149 cvar - 150 cpop - 151 cappend - 152 where - 153 reset { 154 # FIRST, execute the method, first setting This to the object 155 # name; then, after the method has been called, restore the 156 # old object name. 157 set oldThis $This 158 set This $name 159 160 set retval [catch "Op_$method $name $argList" result] 161 162 set This $oldThis 163 164 # NEXT, handle the result based on the retval. 165 if {$retval} { 166 regsub -- "Op_$method" $result "$name $method" result 167 return -code error $result 168 } else { 169 return $result 170 } 171 } 172 default { 173 return -code error "\"$name $method\" is not defined" 174 } 175 } 176} 177 178#--------------------------------------------------------------------- 179# FUNCTION: 180# Get key 181# 182# INPUTS: 183# key A key into the Info array, excluding the 184# object name. E.g., "lb" 185# 186# RETURNS: 187# The value from the array 188# 189# DESCRIPTION: 190# Gets the value of an entry from Info for This. 191 192proc ::textutil::expander::Get {key} { 193 variable Info 194 variable This 195 196 return $Info($This-$key) 197} 198 199#--------------------------------------------------------------------- 200# FUNCTION: 201# Set key value 202# 203# INPUTS: 204# key A key into the Info array, excluding the 205# object name. E.g., "lb" 206# 207# value A Tcl value 208# 209# RETURNS: 210# The value 211# 212# DESCRIPTION: 213# Sets the value of an entry in Info for This. 214 215proc ::textutil::expander::Set {key value} { 216 variable Info 217 variable This 218 219 return [set Info($This-$key) $value] 220} 221 222#--------------------------------------------------------------------- 223# FUNCTION: 224# Var key 225# 226# INPUTS: 227# key A key into the Info array, excluding the 228# object name. E.g., "lb" 229# 230# RETURNS: 231# The full variable name, suitable for setting or lappending 232 233proc ::textutil::expander::Var {key} { 234 variable Info 235 variable This 236 237 return ::textutil::expander::Info($This-$key) 238} 239 240#--------------------------------------------------------------------- 241# FUNCTION: 242# Contains list value 243# 244# INPUTS: 245# list any list 246# value any value 247# 248# RETURNS: 249# TRUE if the list contains the value, and false otherwise. 250 251proc ::textutil::expander::Contains {list value} { 252 if {[lsearch -exact $list $value] == -1} { 253 return 0 254 } else { 255 return 1 256 } 257} 258 259 260#--------------------------------------------------------------------- 261# FUNCTION: 262# Op_lb ?newbracket? 263# 264# INPUTS: 265# newbracket If given, the new bracket token. 266# 267# RETURNS: 268# The current left bracket 269# 270# DESCRIPTION: 271# Returns the current left bracket token. 272 273proc ::textutil::expander::Op_lb {name {newbracket ""}} { 274 if {[string length $newbracket] != 0} { 275 Set lb $newbracket 276 } 277 return [Get lb] 278} 279 280#--------------------------------------------------------------------- 281# FUNCTION: 282# Op_rb ?newbracket? 283# 284# INPUTS: 285# newbracket If given, the new bracket token. 286# 287# RETURNS: 288# The current left bracket 289# 290# DESCRIPTION: 291# Returns the current left bracket token. 292 293proc ::textutil::expander::Op_rb {name {newbracket ""}} { 294 if {[string length $newbracket] != 0} { 295 Set rb $newbracket 296 } 297 return [Get rb] 298} 299 300#--------------------------------------------------------------------- 301# FUNCTION: 302# Op_setbrackets lbrack rbrack 303# 304# INPUTS: 305# lbrack The new left bracket 306# rbrack The new right bracket 307# 308# RETURNS: 309# nothing 310# 311# DESCRIPTION: 312# Sets the brackets as a pair. 313 314proc ::textutil::expander::Op_setbrackets {name lbrack rbrack} { 315 Set lb $lbrack 316 Set rb $rbrack 317 return 318} 319 320#--------------------------------------------------------------------- 321# FUNCTION: 322# Op_errmode ?newErrmode? 323# 324# INPUTS: 325# newErrmode If given, the new error mode. 326# 327# RETURNS: 328# The current error mode 329# 330# DESCRIPTION: 331# Returns the current error mode. 332 333proc ::textutil::expander::Op_errmode {name {newErrmode ""}} { 334 if {[string length $newErrmode] != 0} { 335 if {![Contains "macro nothing error fail" $newErrmode]} { 336 error "$name errmode: Invalid error mode: $newErrmode" 337 } 338 339 Set errmode $newErrmode 340 } 341 return [Get errmode] 342} 343 344#--------------------------------------------------------------------- 345# FUNCTION: 346# Op_evalcmd ?newEvalCmd? 347# 348# INPUTS: 349# newEvalCmd If given, the new eval command. 350# 351# RETURNS: 352# The current eval command 353# 354# DESCRIPTION: 355# Returns the current eval command. This is the command used to 356# evaluate macros; it defaults to "uplevel #0". 357 358proc ::textutil::expander::Op_evalcmd {name {newEvalCmd ""}} { 359 if {[string length $newEvalCmd] != 0} { 360 Set evalcmd $newEvalCmd 361 } 362 return [Get evalcmd] 363} 364 365#--------------------------------------------------------------------- 366# FUNCTION: 367# Op_textcmd ?newTextCmd? 368# 369# INPUTS: 370# newTextCmd If given, the new text command. 371# 372# RETURNS: 373# The current text command 374# 375# DESCRIPTION: 376# Returns the current text command. This is the command used to 377# process plain text. It defaults to {}, meaning identity. 378 379proc ::textutil::expander::Op_textcmd {name args} { 380 switch -exact [llength $args] { 381 0 {} 382 1 {Set textcmd [lindex $args 0]} 383 default { 384 return -code error "wrong#args for textcmd: name ?newTextcmd?" 385 } 386 } 387 return [Get textcmd] 388} 389 390#--------------------------------------------------------------------- 391# FUNCTION: 392# Op_reset 393# 394# INPUTS: 395# none 396# 397# RETURNS: 398# nothing 399# 400# DESCRIPTION: 401# Resets all object values, as though it were brand new. 402 403proc ::textutil::expander::Op_reset {name} { 404 variable Info 405 406 if {[info exists Info($name-lb)]} { 407 foreach elt [array names Info "$name-*"] { 408 unset Info($elt) 409 } 410 } 411 412 set Info($name-lb) "\[" 413 set Info($name-rb) "\]" 414 set Info($name-errmode) "fail" 415 set Info($name-evalcmd) "uplevel #0" 416 set Info($name-textcmd) "" 417 set Info($name-level) 0 418 set Info($name-output-0) "" 419 set Info($name-name-0) ":0" 420 421 return 422} 423 424#------------------------------------------------------------------------- 425# Context: Every expansion takes place in its own context; however, 426# a macro can push a new context, causing the text it returns and all 427# subsequent text to be saved separately. Later, a matching macro can 428# pop the context, acquiring all text saved since the first command, 429# and use that in its own output. 430 431#--------------------------------------------------------------------- 432# FUNCTION: 433# Op_cpush cname 434# 435# INPUTS: 436# cname The context name 437# 438# RETURNS: 439# nothing 440# 441# DESCRIPTION: 442# Pushes an empty macro context onto the stack. All expanded text 443# will be added to this context until it is popped. 444 445proc ::textutil::expander::Op_cpush {name cname} { 446 # FRINK: nocheck 447 incr [Var level] 448 # FRINK: nocheck 449 set [Var output-[Get level]] {} 450 # FRINK: nocheck 451 set [Var name-[Get level]] $cname 452 453 # The first level is init'd elsewhere (Op_expand) 454 if {[set [Var level]] < 2} return 455 456 # Initialize the location information, inherit from the outer 457 # context. 458 459 LocInit $cname 460 catch {LocSet $cname [LocGet $name]} 461 return 462} 463 464#--------------------------------------------------------------------- 465# FUNCTION: 466# Op_cis cname 467# 468# INPUTS: 469# cname A context name 470# 471# RETURNS: 472# true or false 473# 474# DESCRIPTION: 475# Returns true if the current context has the specified name, and 476# false otherwise. 477 478proc ::textutil::expander::Op_cis {name cname} { 479 return [expr {[string compare $cname [Op_cname $name]] == 0}] 480} 481 482#--------------------------------------------------------------------- 483# FUNCTION: 484# Op_cname 485# 486# INPUTS: 487# none 488# 489# RETURNS: 490# The context name 491# 492# DESCRIPTION: 493# Returns the name of the current context. 494 495proc ::textutil::expander::Op_cname {name} { 496 return [Get name-[Get level]] 497} 498 499#--------------------------------------------------------------------- 500# FUNCTION: 501# Op_cset varname value 502# 503# INPUTS: 504# varname The name of a context variable 505# value The new value for the context variable 506# 507# RETURNS: 508# The value 509# 510# DESCRIPTION: 511# Sets a variable in the current context. 512 513proc ::textutil::expander::Op_cset {name varname value} { 514 Set data-[Get level]-$varname $value 515} 516 517#--------------------------------------------------------------------- 518# FUNCTION: 519# Op_cget varname 520# 521# INPUTS: 522# varname The name of a context variable 523# 524# RETURNS: 525# The value 526# 527# DESCRIPTION: 528# Returns the value of a context variable. It's an error if 529# the variable doesn't exist. 530 531proc ::textutil::expander::Op_cget {name varname} { 532 if {![info exists [Var data-[Get level]-$varname]]} { 533 error "$name cget: $varname doesn't exist in this context ([Get level])" 534 } 535 return [Get data-[Get level]-$varname] 536} 537 538#--------------------------------------------------------------------- 539# FUNCTION: 540# Op_cvar varname 541# 542# INPUTS: 543# varname The name of a context variable 544# 545# RETURNS: 546# The index to the variable 547# 548# DESCRIPTION: 549# Returns the index to a context variable, for use with set, 550# lappend, etc. 551 552proc ::textutil::expander::Op_cvar {name varname} { 553 if {![info exists [Var data-[Get level]-$varname]]} { 554 error "$name cvar: $varname doesn't exist in this context" 555 } 556 557 return [Var data-[Get level]-$varname] 558} 559 560#--------------------------------------------------------------------- 561# FUNCTION: 562# Op_cpop cname 563# 564# INPUTS: 565# cname The expected context name. 566# 567# RETURNS: 568# The accumulated output in this context 569# 570# DESCRIPTION: 571# Returns the accumulated output for the current context, first 572# popping the context from the stack. The expected context name 573# must match the real name, or an error occurs. 574 575proc ::textutil::expander::Op_cpop {name cname} { 576 variable Info 577 578 if {[Get level] == 0} { 579 error "$name cpop underflow on '$cname'" 580 } 581 582 if {[string compare [Op_cname $name] $cname] != 0} { 583 error "$name cpop context mismatch: expected [Op_cname $name], got $cname" 584 } 585 586 set result [Get output-[Get level]] 587 # FRINK: nocheck 588 set [Var output-[Get level]] "" 589 # FRINK: nocheck 590 set [Var name-[Get level]] "" 591 592 foreach elt [array names "Info data-[Get level]-*"] { 593 unset Info($elt) 594 } 595 596 # FRINK: nocheck 597 incr [Var level] -1 598 return $result 599} 600 601#--------------------------------------------------------------------- 602# FUNCTION: 603# Op_ctopandclear 604# 605# INPUTS: 606# None. 607# 608# RETURNS: 609# The accumulated output in the topmost context, clears the context, 610# but does not pop it. 611# 612# DESCRIPTION: 613# Returns the accumulated output for the current context, first 614# popping the context from the stack. The expected context name 615# must match the real name, or an error occurs. 616 617proc ::textutil::expander::Op_ctopandclear {name} { 618 variable Info 619 620 if {[Get level] == 0} { 621 error "$name cpop underflow on '[Op_cname $name]'" 622 } 623 624 set result [Get output-[Get level]] 625 Set output-[Get level] "" 626 return $result 627} 628 629#--------------------------------------------------------------------- 630# FUNCTION: 631# Op_cappend text 632# 633# INPUTS: 634# text Text to add to the output 635# 636# RETURNS: 637# The accumulated output 638# 639# DESCRIPTION: 640# Appends the text to the accumulated output in the current context. 641 642proc ::textutil::expander::Op_cappend {name text} { 643 # FRINK: nocheck 644 append [Var output-[Get level]] $text 645} 646 647#------------------------------------------------------------------------- 648# Macro-expansion: The following code is the heart of the module. 649# Given a text string, and the current variable settings, this code 650# returns an expanded string, with all macros replaced. 651 652#--------------------------------------------------------------------- 653# FUNCTION: 654# Op_expand inputString ?brackets? 655# 656# INPUTS: 657# inputString The text to expand. 658# brackets A list of two bracket tokens. 659# 660# RETURNS: 661# The expanded text. 662# 663# DESCRIPTION: 664# Finds all embedded macros in the input string, and expands them. 665# If ?brackets? is given, it must be list of length 2, containing 666# replacement left and right macro brackets; otherwise the default 667# brackets are used. 668 669proc ::textutil::expander::Op_expand {name inputString {brackets ""}} { 670 # FIRST, push a new context onto the stack, and save the current 671 # brackets. 672 673 Op_cpush $name expand 674 Op_cset $name lb [Get lb] 675 Op_cset $name rb [Get rb] 676 677 # Keep position information in context variables as well. 678 # Line we are in, counting from 1; column we are at, 679 # counting from 0, and index of character we are at, 680 # counting from 0. Tabs counts as '1' when computing 681 # the column. 682 683 LocInit $name 684 685 # SF Tcllib Bug #530056. 686 set start_level [Get level] ; # remember this for check at end 687 688 # NEXT, use the user's brackets, if given. 689 if {[llength $brackets] == 2} { 690 Set lb [lindex $brackets 0] 691 Set rb [lindex $brackets 1] 692 } 693 694 # NEXT, loop over the string, finding and expanding macros. 695 while {[string length $inputString] > 0} { 696 set plainText [ExtractToToken inputString [Get lb] exclude] 697 698 # FIRST, If there was plain text, append it to the output, and 699 # continue. 700 if {$plainText != ""} { 701 set input $plainText 702 set tc [Get textcmd] 703 if {[string length $tc] > 0} { 704 lappend tc $plainText 705 706 if {![catch "[Get evalcmd] [list $tc]" result]} { 707 set plainText $result 708 } else { 709 HandleError $name {plain text} $tc $result 710 } 711 } 712 Op_cappend $name $plainText 713 LocUpdate $name $input 714 715 if {[string length $inputString] == 0} { 716 break 717 } 718 } 719 720 # NEXT, A macro is the next thing; process it. 721 if {[catch {GetMacro inputString} macro]} { 722 # SF tcllib bug 781973 ... Do not throw a regular 723 # error. Use HandleError to give the user control of the 724 # situation, via the defined error mode. The continue 725 # intercepts if the user allows the expansion to run on, 726 # yet we must not try to run the non-existing macro. 727 728 HandleError $name {reading macro} $inputString $macro 729 continue 730 } 731 732 # Expand the macro, and output the result, or 733 # handle an error. 734 if {![catch "[Get evalcmd] [list $macro]" result]} { 735 Op_cappend $name $result 736 737 # We have to advance the location by the length of the 738 # macro, plus the two brackets. They were stripped by 739 # GetMacro, so we have to add them here again to make 740 # computation correct. 741 742 LocUpdate $name [Get lb]${macro}[Get rb] 743 continue 744 } 745 746 HandleError $name macro $macro $result 747 } 748 749 # SF Tcllib Bug #530056. 750 if {[Get level] > $start_level} { 751 # The user macros pushed additional contexts, but forgot to 752 # pop them all. The main work here is to place all the still 753 # open contexts into the error message, and to produce 754 # syntactically correct english. 755 756 set c [list] 757 set n [expr {[Get level] - $start_level}] 758 if {$n == 1} { 759 set ctx context 760 set verb was 761 } else { 762 set ctx contexts 763 set verb were 764 } 765 for {incr n -1} {$n >= 0} {incr n -1} { 766 lappend c [Get name-[expr {[Get level]-$n}]] 767 } 768 return -code error \ 769 "The following $ctx pushed by the macros $verb not popped: [join $c ,]." 770 } elseif {[Get level] < $start_level} { 771 set n [expr {$start_level - [Get level]}] 772 if {$n == 1} { 773 set ctx context 774 } else { 775 set ctx contexts 776 } 777 return -code error \ 778 "The macros popped $n more $ctx than they had pushed." 779 } 780 781 Op_lb $name [Op_cget $name lb] 782 Op_rb $name [Op_cget $name rb] 783 784 return [Op_cpop $name expand] 785} 786 787#--------------------------------------------------------------------- 788# FUNCTION: 789# Op_where 790# 791# INPUTS: 792# None. 793# 794# RETURNS: 795# The current location in the input. 796# 797# DESCRIPTION: 798# Retrieves the current location the expander 799# is at during processing. 800 801proc ::textutil::expander::Op_where {name} { 802 return [LocGet $name] 803} 804 805#--------------------------------------------------------------------- 806# FUNCTION 807# HandleError name title command errmsg 808# 809# INPUTS: 810# name The name of the expander object in question. 811# title A title text 812# command The command which caused the error. 813# errmsg The error message to report 814# 815# RETURNS: 816# Nothing 817# 818# DESCRIPTIONS 819# Is executed when an error in a macro or the plain text handler 820# occurs. Generates an error message according to the current 821# error mode. 822 823proc ::textutil::expander::HandleError {name title command errmsg} { 824 switch [Get errmode] { 825 nothing { } 826 macro { 827 # The location is irrelevant here. 828 Op_cappend $name "[Get lb]$command[Get rb]" 829 } 830 error { 831 foreach {ch line col} [LocGet $name] break 832 set display [DisplayOf $command] 833 834 Op_cappend $name "\n=================================\n" 835 Op_cappend $name "*** Error in $title at line $line, column $col:\n" 836 Op_cappend $name "*** [Get lb]$display[Get rb]\n--> $errmsg\n" 837 Op_cappend $name "=================================\n" 838 } 839 fail { 840 foreach {ch line col} [LocGet $name] break 841 set display [DisplayOf $command] 842 843 return -code error "Error in $title at line $line,\ 844 column $col:\n[Get lb]$display[Get rb]\n-->\ 845 $errmsg" 846 } 847 default { 848 return -code error "Unknown error mode: [Get errmode]" 849 } 850 } 851} 852 853#--------------------------------------------------------------------- 854# FUNCTION: 855# ExtractToToken string token mode 856# 857# INPUTS: 858# string The text to process. 859# token The token to look for 860# mode include or exclude 861# 862# RETURNS: 863# The extracted text 864# 865# DESCRIPTION: 866# Extract text from a string, up to or including a particular 867# token. Remove the extracted text from the string. 868# mode determines whether the found token is removed; 869# it should be "include" or "exclude". The string is 870# modified in place, and the extracted text is returned. 871 872proc ::textutil::expander::ExtractToToken {string token mode} { 873 upvar $string theString 874 875 # First, determine the offset 876 switch $mode { 877 include { set offset [expr {[string length $token] - 1}] } 878 exclude { set offset -1 } 879 default { error "::expander::ExtractToToken: unknown mode $mode" } 880 } 881 882 # Next, find the first occurrence of the token. 883 set tokenPos [string first $token $theString] 884 885 # Next, return the entire string if it wasn't found, or just 886 # the part upto or including the character. 887 if {$tokenPos == -1} { 888 set theText $theString 889 set theString "" 890 } else { 891 set newEnd [expr {$tokenPos + $offset}] 892 set newBegin [expr {$newEnd + 1}] 893 set theText [string range $theString 0 $newEnd] 894 set theString [string range $theString $newBegin end] 895 } 896 897 return $theText 898} 899 900#--------------------------------------------------------------------- 901# FUNCTION: 902# GetMacro string 903# 904# INPUTS: 905# string The text to process. 906# 907# RETURNS: 908# The macro, stripped of its brackets. 909# 910# DESCRIPTION: 911 912proc ::textutil::expander::GetMacro {string} { 913 upvar $string theString 914 915 # FIRST, it's an error if the string doesn't begin with a 916 # bracket. 917 if {[string first [Get lb] $theString] != 0} { 918 error "::expander::GetMacro: assertion failure, next text isn't a command! '$theString'" 919 } 920 921 # NEXT, extract a full macro 922 set macro [ExtractToToken theString [Get lb] include] 923 while {[string length $theString] > 0} { 924 append macro [ExtractToToken theString [Get rb] include] 925 926 # Verify that the command really ends with the [rb] characters, 927 # whatever they are. If not, break because of unexpected 928 # end of file. 929 if {![IsBracketed $macro]} { 930 break; 931 } 932 933 set strippedMacro [StripBrackets $macro] 934 935 if {[info complete "puts \[$strippedMacro\]"]} { 936 return $strippedMacro 937 } 938 } 939 940 if {[string length $macro] > 40} { 941 set macro "[string range $macro 0 39]...\n" 942 } 943 error "Unexpected EOF in macro:\n$macro" 944} 945 946# Strip left and right bracket tokens from the ends of a macro, 947# provided that it's properly bracketed. 948proc ::textutil::expander::StripBrackets {macro} { 949 set llen [string length [Get lb]] 950 set rlen [string length [Get rb]] 951 set tlen [string length $macro] 952 953 return [string range $macro $llen [expr {$tlen - $rlen - 1}]] 954} 955 956# Return 1 if the macro is properly bracketed, and 0 otherwise. 957proc ::textutil::expander::IsBracketed {macro} { 958 set llen [string length [Get lb]] 959 set rlen [string length [Get rb]] 960 set tlen [string length $macro] 961 962 set leftEnd [string range $macro 0 [expr {$llen - 1}]] 963 set rightEnd [string range $macro [expr {$tlen - $rlen}] end] 964 965 if {$leftEnd != [Get lb]} { 966 return 0 967 } elseif {$rightEnd != [Get rb]} { 968 return 0 969 } else { 970 return 1 971 } 972} 973 974#--------------------------------------------------------------------- 975# FUNCTION: 976# LocInit name 977# 978# INPUTS: 979# name The expander object to use. 980# 981# RETURNS: 982# No result. 983# 984# DESCRIPTION: 985# A convenience wrapper around LocSet. Initializes the location 986# to the start of the input (char 0, line 1, column 0). 987 988proc ::textutil::expander::LocInit {name} { 989 LocSet $name {0 1 0} 990 return 991} 992 993#--------------------------------------------------------------------- 994# FUNCTION: 995# LocSet name loc 996# 997# INPUTS: 998# name The expander object to use. 999# loc Location, list containing character position, 1000# line number and column, in this order. 1001# 1002# RETURNS: 1003# No result. 1004# 1005# DESCRIPTION: 1006# Sets the current location in the expander to 'loc'. 1007 1008proc ::textutil::expander::LocSet {name loc} { 1009 foreach {ch line col} $loc break 1010 Op_cset $name char $ch 1011 Op_cset $name line $line 1012 Op_cset $name col $col 1013 return 1014} 1015 1016#--------------------------------------------------------------------- 1017# FUNCTION: 1018# LocGet name 1019# 1020# INPUTS: 1021# name The expander object to use. 1022# 1023# RETURNS: 1024# A list containing the current character position, line number 1025# and column, in this order. 1026# 1027# DESCRIPTION: 1028# Returns the current location as stored in the expander. 1029 1030proc ::textutil::expander::LocGet {name} { 1031 list [Op_cget $name char] [Op_cget $name line] [Op_cget $name col] 1032} 1033 1034#--------------------------------------------------------------------- 1035# FUNCTION: 1036# LocUpdate name text 1037# 1038# INPUTS: 1039# name The expander object to use. 1040# text The text to process. 1041# 1042# RETURNS: 1043# No result. 1044# 1045# DESCRIPTION: 1046# Takes the current location as stored in the expander, computes 1047# a new location based on the string (its length and contents 1048# (number of lines)), and makes that new location the current 1049# location. 1050 1051proc ::textutil::expander::LocUpdate {name text} { 1052 foreach {ch line col} [LocGet $name] break 1053 set numchars [string length $text] 1054 #8.4+ set numlines [regexp -all "\n" $text] 1055 set numlines [expr {[llength [split $text \n]]-1}] 1056 1057 incr ch $numchars 1058 incr line $numlines 1059 if {$numlines} { 1060 set col [expr {$numchars - [string last \n $text] - 1}] 1061 } else { 1062 incr col $numchars 1063 } 1064 1065 LocSet $name [list $ch $line $col] 1066 return 1067} 1068 1069#--------------------------------------------------------------------- 1070# FUNCTION: 1071# LocRange name text 1072# 1073# INPUTS: 1074# name The expander object to use. 1075# text The text to process. 1076# 1077# RETURNS: 1078# A text range description, compatible with the 'location' data 1079# used in the tcl debugger/checker. 1080# 1081# DESCRIPTION: 1082# Takes the current location as stored in the expander object 1083# and the length of the text to generate a character range. 1084 1085proc ::textutil::expander::LocRange {name text} { 1086 # Note that the structure is compatible with 1087 # the ranges uses by tcl debugger and checker. 1088 # {line {charpos length}} 1089 1090 foreach {ch line col} [LocGet $name] break 1091 return [list $line [list $ch [string length $text]]] 1092} 1093 1094#--------------------------------------------------------------------- 1095# FUNCTION: 1096# DisplayOf text 1097# 1098# INPUTS: 1099# text The text to process. 1100# 1101# RETURNS: 1102# The text, cut down to at most 30 bytes. 1103# 1104# DESCRIPTION: 1105# Cuts the incoming text down to contain no more than 30 1106# characters of the input. Adds an ellipsis (...) if characters 1107# were actually removed from the input. 1108 1109proc ::textutil::expander::DisplayOf {text} { 1110 set ellip "" 1111 while {[string bytelength $text] > 30} { 1112 set ellip ... 1113 set text [string range $text 0 end-1] 1114 } 1115 set display $text$ellip 1116} 1117 1118#--------------------------------------------------------------------- 1119# Provide the package only if the code above was read and executed 1120# without error. 1121 1122package provide textutil::expander 1.3.1 1123