diff options
Diffstat (limited to 'Master/texmf-dist/scripts/context/perl/cont_set.pm')
-rw-r--r-- | Master/texmf-dist/scripts/context/perl/cont_set.pm | 670 |
1 files changed, 0 insertions, 670 deletions
diff --git a/Master/texmf-dist/scripts/context/perl/cont_set.pm b/Master/texmf-dist/scripts/context/perl/cont_set.pm deleted file mode 100644 index 41c62e75440..00000000000 --- a/Master/texmf-dist/scripts/context/perl/cont_set.pm +++ /dev/null @@ -1,670 +0,0 @@ -#D \module -#D [ file=cont\_set.pm, -#D version=1999.04.01, -#D title=General modules, -#D subtitle=showing \CONTEXT\ commands, -#D author=Hans Hagen, -#D date=\currentdate, -#D copyright={PRAGMA / Hans Hagen \& Ton Otten}, -#D suggestions={Tobias Burnus \& Taco Hoekater}] -#C -#C This module is part of the \CONTEXT\ macro||package and is -#C therefore copyrighted by \PRAGMA. See licen-en.pdf for -#C details. - -# todo: tacos speed patch - -#D As always: thanks to Taco and Tobias for testing this -#D module and providing suggestions and code snippets as -#D well as haunting bugs. - -package cont_set ; - -#D This module (package) deals with providing help information -#D about the \CONTEXT\ commands. The data needed is derived -#D from the setup files by \CONTEXT\ itself. The data is -#D stored in files with suffix \type {tws} (tex work setup). -#D This module introduces some subroutines: -#D -#D \starttabulatie[|Tl|p|] -#D \NC \type {set\_setup\_interface} \NC sets the primary interface -#D to search in \NC \NR -#D \NC \type {set\_setup\_title} \NC sets the title of the main -#D window title \NC \NR -#D \NC \type {setups\_found} \NC locate the \type {tws} files -#D using the \type {kpsewhich} -#D program \NC \NR -#D \NC \type {show\_setups} \NC allocate the radio buttons -#D that can be used to select a -#D command set \NC \NR -#D \NC \type {load\_setup(filename)} \NC load the names \type {tws} -#D file \NC \NR -#D \NC \type {load\_setups} \NC all found command files can -#D be loaded at once \NC \NR -#D \NC \type {setup\_found(filename)} \NC this routine returns~1 when -#D the file is loaded \NC \NR -#D \NC \type {update\_setup} \NC when we browse the list with -#D commands, this routine takes care -#D of updating the text area \NC \NR -#D \NC \type {change\_setup} \NC we can manually set the -#D command set we want to browse, -#D and this routine takes care of -#D this \NC \NR -#D \NC \type {show\_setup(command)} \NC context sensitive help can be -#D provided by calling this sub \NC \NR -#D \stoptabulatie -#D -#D First we load some packages and set some constants. - -use Tk ; -use Tk::ROText ; -use Config ; - -use strict; - -use subs qw/ update_setup / ; - -my $dosish = ($Config{'osname'} =~ /dos|win/i) ; -my $default_size = $dosish ? 9 : 12 ; - -my $textfont = "Courier $default_size " ; -my $userfont = "Courier $default_size italic" ; -my $buttonfont = "Helvetica $default_size bold " ; - -unless ($dosish) - { $textfont = "-adobe-courier-bold-r-normal--$default_size-120-75-75-m-70-iso8859-1" ; - $userfont = "-adobe-courier-bold-o-normal--$default_size-120-75-75-m-70-iso8859-1" ; - $buttonfont = "-adobe-helvetica-bold-r-normal--$default_size-120-75-75-p-69-iso8859-1" } - -my $s_vertical = 30 ; -my $s_horizontal = 72 ; -my $c_horizontal = 24 ; - -#D The main window is not resizable, but the text area and -#D command list will have scrollbars. - -my %lw ; # stack of lists - -my $mw = MainWindow -> new ( -title => 'ConTeXt commands' ) ; - -$mw -> withdraw() ; $mw -> resizable ('y', 'y') ; - -sub SetupWindow { return $mw } ; - -my $bw = $mw -> Frame () ; # buttons -my $tw = $mw -> Frame () ; # sw + fw -my $fw = $tw -> Frame () ; # string + list - -my $request = $fw -> Entry ( -font => $textfont , - -background => 'ivory1' , - -width => $c_horizontal ) ; - -my $cw = $fw -> Scrolled ( 'Listbox' , - -scrollbars => 'e' , - -font => $textfont , - -width => $c_horizontal , - -selectbackground => 'gray' , - -background => 'ivory1' , - -selectmode => 'browse' ) ; - -$cw -> pack ( -side => 'bottom' , -fill => 'both' , -expand => 1 ) ; -$request -> pack ( -side => 'top' , -fill => 'x' ) ; - -my $sw = $tw -> Scrolled ( 'ROText' , - -scrollbars => 'se' , - -height => $s_vertical , - -width => $s_horizontal , - -wrap => 'none' , - -background => 'ivory1' , - -font => $textfont ) ; - - -#D And the whole bunch of widgets are packed in the main -#D window. - -sub pack_them_all - { $sw -> pack ( -side => 'left' , -fill => 'both' , -expand => 1 ) ; - $fw -> pack ( -side => 'right' , -fill => 'y' , -expand => 0 ) ; - $bw -> pack ( -side => 'top' , -fill => 'x' , -anchor => 'w' , -expand => 1 ) ; - $tw -> pack ( -side => 'bottom', -fill => 'both' , -expand => 1 ) } - -sub unpack_them_all - { } - -pack_them_all ; - -#D We scan for available setup files, with suffix \type {tws}. -#D These should be somewhere on the system, grouped in one -#D directory. At least the english file \type {cont-en.tws} -#D should be found. - -my $tws_path = '' ; -my @setup_files = ('cont-en.tws') ; -my $setup_file = $setup_files[0] ; -my $setup_interface = 'en' ; -my $old_setup_file = '' ; - -sub set_setup_interface - { $setup_interface = shift } - -sub set_setup_title - { $mw -> configure ( -title => shift ) } - -sub setups_found - { $tws_path = `kpsewhich --format="other text files" --progname=context cont-en.tws` ; - $tws_path =~ s/cont-en\.tws.*// ; - chop $tws_path ; - @setup_files = glob ("$tws_path*.tws") ; - if (@setup_files) - { foreach (@setup_files) { s/\.tws// ; s/.*\/// } - $setup_file = $setup_files[0] ; - return 1 } - else - { return 0 } } - -#D A hide button - -sub show_hide_button - { my $hb = $bw -> Button ( -text => "hide" , - -font => $buttonfont , - -command => \&hide_widget ) ; - $hb -> pack ( -padx => '2p', - -pady => '2p', - -side => 'right' ) } - -sub hide_widget - { $mw -> withdraw() } - -#D The setup files can be shown and chosen. - -sub show_setups - { unpack_them_all ; - foreach (@setup_files) - { $lw{$_} = $bw -> Radiobutton ( -text => lc $_ , - -value => $_ , - -font => $buttonfont , - -selectcolor => 'ivory1' , - -indicatoron => 0 , - -command => \&change_setup , - -variable => \$setup_file ) ; - $lw{$_} -> pack ( -padx => '2p', - -pady => '2p', - -side => 'left' ) } - pack_them_all } - -$cw -> bind ('<B1-Motion>', \&update_setup ) ; -$cw -> bind ('<1>' , \&update_setup ) ; -$cw -> bind ('<Key>' , \&update_setup ) ; - -$sw -> tag ('configure', 'user' , -font => $userfont ) ; -$sw -> tag ('configure', 'command' , -foreground => 'green3' ) ; -$sw -> tag ('configure', 'variable' , -font => $userfont ) ; -$sw -> tag ('configure', 'default' , -underline => 1 ) ; -$sw -> tag ('configure', 'symbol' , -foreground => 'blue3' ) ; -$sw -> tag ('configure', 'or' , -foreground => 'yellow3' ) ; -$sw -> tag ('configure', 'argument' , -foreground => 'red3' ) ; -$sw -> tag ('configure', 'par' , -lmargin1 => '4m' , - -lmargin2 => '6m' ) ; - -my %setups ; -my %commands ; -my %loadedsetups ; -my %positions ; -my %crosslinks ; - -my $current_setup = '' ; - -#D Setups are organized in files called \type {*.tws} and -#D alike. Several files can be loaded simultaneously. When -#D loading, we grab whole paragraphs. The variables and values -#D belonging to a command, are stored in the hash table \type -#D {setups}, one per language. The command templates are -#D stored in \type {commands}. -#D -#D A \type {tws} file is generated by \CONTEXT\ from the setup -#D definition files. Only \CONTEXT\ knows the current meaning -#D of commands and keywords. The files are generating by -#D simply saying something like: -#D -#D \starttypen -#D texexec --interface=en setupd -#D texexec --interface=de setupd -#D texexec --interface=nl setupd -#D texexec --interface=cz setupd -#D texexec --interface=it setupd -#D \stoptypen -#D -#D This results in files formatted as: -#D -#D \starttypen -#D startsetup -#D com:setupcolors -#D typ:vars/ -#D var:state:start,stop,global,local: -#D var:conversion:yes,no,always: -#D var:reduction:yes,no: -#D var:rgb:yes,no: -#D var:cmyk:yes,no: -#D stopsetup -#D \stoptypen -#D -#D This format can be stored rather efficient and parsed rather -#D fast. What more do we need. - -sub load_setup - { my $filename = shift ; - unless (keys %{$commands{$filename}}) - { local $/ = 'stopsetup' ; # in plaats van '' ivm unix ; (taco) - $current_setup = '' ; - if (open(SETUP, "$tws_path$filename.tws" )) - { my $position = 0 ; - while (<SETUP>) - { chomp ; - s/startsetup//mso ; - s/stopsetup//mso ; # redundant geworden - s/\r\n //gms ; # in plaats van s/ //gms ; (taco) - s/com\:(.*?)\:\s(.*)//mso ; - my $string = $1 ; - my $command = $1 ; - my $setup = $2 ; - ++$position ; - $string =~ s/(.*?)\<\<(.*?)\>\>(.*?)/$1$2$3/o ; - $setups {$filename}{$string} = $setup ; - $commands {$filename}{$string} = $command ; - $positions {$filename}{$string} = $position ; - $crosslinks{$filename}[$position] = $string } - close (SETUP) } } - my @list = sort {lc $a cmp lc $b} keys %{$commands{$filename}} ; - $cw -> delete ('0.0', 'end') ; - $cw -> insert ('end', @list) ; - $cw -> selectionSet ('0.0', '0.0') ; - $cw -> activate ('0.0') ; - $setup_file = $filename ; - update_setup } - -sub load_setups - { foreach my $setup (@setup_files) { load_setup ($setup) } ; - $mw -> deiconify() } - -#D The core of this module deals with transforming the -#D definitions like shown earlier. Details on the format -#D can be found in the file \type {setupd.tex}. We use the -#D \type {Tk::Text} automatic hanging identation features. -#D The next subs are examples of the kind you write once -#D and never look at again. - -my @arguments = () ; -my $nested_setup = 0 ; -my $continue_setup = 0 ; -my $argument = 0 ; -my $stopsuffix = '' ; -my $stopcommand = '' ; - -my %arg ; - -$arg {repeat} = '//n*/' ; -$arg {arg} = 'argument/{/.../}' ; -$arg {args} = 'argument/{/..,...,../}' ; -$arg {dis} = 'argument/$$/.../$$' ; -$arg {idx} = 'argument/{/.../}' ; -$arg {idxs} = 'argument/{/..+...+../}' ; -$arg {mat} = 'argument/$/...:$' ; -$arg {nop} = '//.../' ; -$arg {fil} = '//.../' ; -$arg {pos} = 'symbol/(/.../)' ; -$arg {poss} = 'symbol/(/...,.../)' ; -$arg {sep} = 'command//\\\\/' ; -$arg {ref} = 'symbol/[/ref/]' ; -$arg {refs} = 'symbol/[/ref,../]' ; -$arg {val} = 'symbol/[/.../]' ; -$arg {vals} = 'symbol/[/..,...,../]' ; -$arg {var} = 'symbol/[/..=../]' ; -$arg {vars} = 'symbol/[/..,..=..,../]' ; -$arg {cmd} = 'command//\cmd/' ; -$arg {dest} = 'symbol/[/..ref/]' ; -$arg {dests} = 'symbol/[/..,..refs,../]' ; -$arg {trip} = 'symbol/[/x:y:z=/]' ; -$arg {trips} = 'symbol/[/x:y:z=,../]' ; -$arg {wrd} = 'argument/{/.../}' ; -$arg {wrds} = 'argument/{/......./}' ; -$arg {par} = 'command//\par/' ; -$arg {stp} = '//stop/' ; -$arg {par} = 'command///' ; - -sub show_command - { my $command = shift ; - local $_ = $commands{$setup_file}{$command} ; - if ($command eq $_) - { $sw -> insert ('end', "\\$command", 'command' ) } - elsif (/(.*?)\<\<(.*?)\>\>(.*?)/o) - { $sw -> insert ('end', "\\", 'command' ) ; - if ($1) { $sw -> insert ('end', $1, 'command' ) } - if ($2) { $sw -> insert ('end', $2, ['command','user'] ) } - if ($3) { $sw -> insert ('end', $3, 'command' ) } - $stopsuffix = $2 } } - -sub show_left_argument - { local $_ = shift ; - my @thearg = split (/\//, $arg{$arguments[$_]}) ; - $sw -> insert ('end', $thearg[1], ['par',$thearg[0]] ) } - -sub show_middle_argument - { local $_ = shift ; - my @thearg = split (/\//, $arg{$arguments[$_]}) ; - if ($thearg[1]) - { $sw -> insert ('end', $thearg[2], 'par' ) } - else - { $sw -> insert ('end', $thearg[2], ['par',$thearg[0]] ) } } - -sub show_right_argument - { local $_ = shift ; - my @thearg = split (/\//, $arg{$arguments[$_]}) ; - $sw -> insert ('end', $thearg[3], ['par',$thearg[0]] ) ; - ++$argument } - -sub show_reference - { if (($nested_setup<=1)&&(defined($arguments[$argument]))) - { if ($arguments[$argument]=~/ref/) - { $sw -> insert ('end', "\n" ) ; - show_left_argument ($argument) ; - show_middle_argument ($argument) ; - show_right_argument ($argument) } } } - -sub show_stop_command - { my $before_stop = shift ; - if ($stopcommand) - { if ($stopsuffix) - { $sw -> insert ('end', '\\stop', 'command' ) ; - $sw -> insert ('end', $stopsuffix, ['command','user'] ) } - else - { $sw -> insert ('end', $stopcommand, 'command' ) } } } - -sub show_whatever_left - { while ($argument<@arguments) - { $sw -> insert ('end', "\n" ) ; - show_left_argument ($argument) ; - show_middle_argument ($argument) ; - show_right_argument ($argument) ; - ++$argument } - if ($stopcommand) - { $sw -> insert ('end', "\n...\n...\n...\n", 'par') ; - show_stop_command } } - -sub do_update_setup # type: 0=all 1=vars 2=vals - { my ($command, $type) = @_ ; - my $setup = $setups{$setup_file}{$command} ; - my $default = '' ; - my $key = '' ; - my $meaning = '' ; - my @values = () ; - local $_ ; - ++$nested_setup ; - while ($setup=~/(typ|var|val|ivr|ivl)\:(.*?)\:\s/mgo) - { $key = $1 ; - $meaning = $2 ; - if (($key=~/var/o)&&($type!=2)) - { $_ = $meaning ; s/(.*?)\:(.*?)\:(.*)//o ; - if (($nested_setup>1)&&(!$2)) { next } - $key = $1 ; - if ($3) { $default = $3 } else { $default = '' } - $_= $2 ; s/\s//go ; @values = split (/,/,$_) ; - if ($continue_setup) - { $sw -> insert ('end', ",\n ", 'par') } - else - { $continue_setup = 1 ; - $sw -> insert ('end', "\n", 'par') ; - show_left_argument($argument) } - $sw -> insert ('end', $key , 'par' ) ; - $sw -> insert ('end', '=', ['symbol','par'] ) ; - #while (1) - while (@values) - { my $value = shift @values ; - if ($value =~ /^\*/o) - { $value =~ s/^\*//o ; - $sw -> insert ('end', lc $value, ['variable','par'] ) } - elsif ($value eq $default) - { $sw -> insert ('end', $value, ['default','par'] ) } - else - { $sw -> insert ('end', $value, 'par' ) } - if (@values) - { $sw -> insert ('end', '|' , ['or','par'] ) } - else - { last } } } - elsif (($key=~/val/o)&&($type!=1)) - { $_ = $meaning ; s/(.*)\:(.*)//o ; - if (($nested_setup>1)&&(!$2)) { next } - $_ = $1 ; s/\s//go ; @values = split (/,/,$_) ; - if ($2) { $default = $2 } else { $default = '' } - if ($continue_setup) - { $continue_setup = 0 ; - show_right_argument($argument) } - $sw -> insert ('end', "\n" , 'par') ; - show_left_argument($argument) ; - #while (1) - while (@values) - { unless (@values) { last } - my $value = shift (@values) ; - if ($value =~ /^\*/o) - { $value =~ s/^\*//o ; - $sw -> insert ('end', lc $value, ['variable','par'] ) } - elsif ($value eq $default) - { $sw -> insert ('end', $value, ['default','par'] ) } - else - { $sw -> insert ('end', $value, 'par' ) } - if (@values) - { $sw -> insert ('end', ', ', 'par' ) } - else - { last } } - show_right_argument($argument) } - elsif ($key=~/typ/o) - { if ($nested_setup==1) - { show_command ($command) ; - my $arguments = $meaning ; - if ($arguments=~/stp/) - { $_ = $command ; - s/start(.*)/$1/o ; - $stopcommand = "\\stop$_" ; - $arguments =~ s/stp//go } - @arguments = split (/\//,$arguments) ; - if (@arguments) - { for (my $i=0;$i<@arguments;$i++) - { show_left_argument ($i) ; - show_middle_argument ($i) ; - show_right_argument ($i) } - if ($stopcommand) - { $sw -> insert ('end', ' ... ') ; - show_stop_command } - $sw -> insert ('end', "\n\n") ; - show_command ($command) } - $argument = 0 ; - $continue_setup = 0 } } - elsif ($key=~/ivr/o) - { $meaning =~ s/(.*)\:(.*)//o ; - do_update_setup ($1,1) } - elsif ($key=~/ivl/o) - { $meaning =~ s/(.*)\:(.*)//o ; - do_update_setup ($1,2) } - show_reference } - --$nested_setup ; - if (($continue_setup)&&(!$nested_setup)) - { show_right_argument ; - show_whatever_left } } - -#D Now the real work is done, we only have to define a few -#D housekeeping routines. The next sub adapts the text area -#D to the current selected command and normally is bound to -#D the list browsing commands. - -sub update_setup - { $old_setup_file = $setup_file ; - if (keys %{$commands{$setup_file}}) - { my $key ; - unless ($cw->curselection) - { $cw -> selectionSet('0.0','0.0') } - $key = $cw -> get($cw->curselection) ; - if ($current_setup ne $key) - { $current_setup = $key ; - $sw -> delete ('1.0', 'end' ) ; - $nested_setup = 0 ; - $argument = 0 ; - $stopcommand = '' ; - $stopsuffix = '' ; - do_update_setup ($key,0) ; - $mw -> raise ; - $mw -> focus } } } - -#D In editors we want to provide context sensitive help -#D information. The next sub first tries to locate the -#D commands asked for in the setup data currently selected, -#D and when not found takes a look at all the loaded files. - -sub show_setup - { my $asked_for = shift ; - unless ($asked_for) { return } - my $found = 0 ; - $asked_for =~ s/^\\// ; - if ($setup_interface) - { $found = 0 ; - foreach my $name (@setup_files) - { if (($name=~/\-$setup_interface/)&&(exists($commands{$name}{$asked_for}))) - { $found = 1 ; - $setup_file = $name ; - last } } } - if (!($found)&&(exists($commands{$setup_file}{$asked_for}))) - { $found = 1 } - else - { $found = 0 ; - foreach my $name (@setup_files) - { if (exists($commands{$name}{$asked_for})) - { $found = 1 ; - $setup_file = $name ; - last } } } - if ($found) - { my @list = sort {lc $a cmp lc $b} keys %{$commands{$setup_file}} ; - $cw -> delete ('0.0', 'end') ; - $cw -> insert ('end', @list) ; - $found = 0 ; - foreach (@list) { if ($_ eq $asked_for) { last } ++$found } - my $index = "$found.0" ; - $cw -> selectionSet ($index, $index) ; - $cw -> activate ($index) ; - $cw -> see ($index) ; - update_setup ; - $mw -> raise ; - $mw -> focus } } - -#D Whenever a new set of commands is selected (by means of the -#D buttons on top the screen) the list and text are to be -#D updated. - -sub change_setup - { my $command = '' ; - if ($old_setup_file) - { unless ($cw->curselection) - { $cw -> selectionSet('0.0','0.0') } - $command = $cw -> get($cw->curselection) ; - my $position = $positions{$old_setup_file}{$command} ; - $command = $crosslinks{$setup_file}[$position] } - load_setup($setup_file) ; - my @list = sort {lc $a cmp lc $b} keys %{$commands{$setup_file}} ; - $cw -> delete ('0.0', 'end') ; - $cw -> insert ('end', @list) ; - if ($command) - { show_setup($command) } - else - { $cw -> selectionClear ('0.0','end') ; - $cw -> selectionSet ('0.0', '0.0') ; - $cw -> see ('0.0') ; - $cw -> activate ('0.0') } - update_setup ; - $mw -> raise ; - $mw -> focus } - -#D Sometimes we want to make sure the dat is loaded indeed: - -sub setup_found - { my $filename = shift ; - if (-e "$tws_path$filename.tws") - { $setup_file = $filename ; - return 1 } - else - { return 0 } } - -#D The next feature is dedicated to Tobias, who suggested -#D it, and Taco, who saw it as yet another proof of the -#D speed of \PERL. It's also dedicated to Ton, who needs it -#D for translating the big manual. - -sub handle_request - { my $index = $cw -> index('end') ; - unless ($index) { return } - my $req = $request -> get ; - unless ($req) { return } - $req =~ s/\\//o ; - $req =~ s/\s//go ; - $request -> delete('0','end') ; - $request -> insert('0',$req) ; - unless ($req) { return } - my ($l,$c) = split (/\./,$index) ; - for (my $i=0;$i<=$l;$i++) - { $index = "$i.0" ; - my $str = $cw -> get ($index, $index) ; - if ($str =~ /^$req/) - { $cw -> selectionClear ('0.0','end') ; - $cw -> selectionSet ($index, $index) ; - $cw -> activate ($index) ; - $cw -> see ($index) ; - update_setup ; - $mw -> raise ; - $mw -> focus ; - return } } } - -$request -> bind ('<Return>', sub { handle_request } ) ; - -sub insert_request - { my ($self, $chr) = @_ ; - if ($self ne $request) - { $request -> insert ('end', $chr) } - handle_request } - -foreach my $chr ('a'..'z','A'..'Z') - { $mw -> bind ( "<KeyPress-$chr>", sub { insert_request(shift, $chr) } ) } - -$mw -> bind ( "<backslash>", sub { insert_request(shift, "\\") } ) ; - -sub delete_request - { my $self = shift ; - if ($self ne $request) - { my $to = $request -> index ('end') ; - my $from = $to - 1 ; - if ($from<0) { $from = 0 } - $request -> delete ($from,$to) } - handle_request } - -$mw -> bind ( "<BackSpace>", sub { delete_request } ) ; - -sub new_request - { $request -> delete (0,'end') ; - handle_request } - -$mw -> bind ( "<space>", sub { new_request } ) ; - -#D Just in case: - -sub raise_setup - { $mw -> raise } - -sub dont_exit - { $mw -> protocol( 'WM_DELETE_WINDOW' => sub { } ) } - -#D An example use is: -#D -#D \starttypen -#D load_setup ("cont-$nl") ; -#D show_setup ('omlijnd') ; -#D MainLoop () ; -#D \stoptypen -#D -#D Now everything is done, we return 1: - -1 ; |