diff options
Diffstat (limited to 'context/perltk/cont_set.pm')
| -rw-r--r-- | context/perltk/cont_set.pm | 650 |
1 files changed, 650 insertions, 0 deletions
diff --git a/context/perltk/cont_set.pm b/context/perltk/cont_set.pm new file mode 100644 index 000000000..a7c9c5a2f --- /dev/null +++ b/context/perltk/cont_set.pm @@ -0,0 +1,650 @@ +#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. + +#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 $mw = MainWindow -> new ( -title => 'ConTeXt commands' ) ; + +$mw -> resizable ('n', 'n') ; + +sub SetupWindow { return $mw } ; + +my $sw = $mw -> Scrolled ( 'ROText' , + -scrollbars => 'se' , + -height => $s_vertical , + -width => $s_horizontal , + -wrap => 'none' , + -background => 'ivory1' , + -font => $textfont ) ; + +my $cw = $mw -> Scrolled ( 'Listbox' , + -scrollbars => 'e' , + -font => $textfont , + -width => $c_horizontal , + -selectbackground => 'gray' , + -background => 'ivory1' , + -selectmode => 'browse' ) ; + +#D The (optional) file buttons are packed in a frame. + +my $fw = $mw -> Frame () ; + +my %lw ; + +#D We can search for commands, using: + +my $request = $fw -> Entry ( -font => $textfont , + -background => 'ivory1' , + -width => 20 ) ; + +#D And the whole bunch of widgets are packed in the main +#D window. + +$fw -> pack ( -fill => 'x' , + -side => 'top' ) ; +$sw -> pack ( #-fill => 'both' , + #-expand => 1 , + -side => 'left' ) ; +$cw -> pack ( -fill => 'both' , + -expand => 1 ) ; + +#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 The setup files can be shown and chosen. + +sub show_setups + { foreach (@setup_files) + { $lw{$_} = $fw -> Radiobutton ( -text => lc $_ , + -value => $_ , + -font => $buttonfont , + -selectcolor => 'ivory1' , + -indicatoron => 0 , + command => \&change_setup , + -variable => \$setup_file ) ; + $lw{$_} -> pack ( -padx => '2p', + -pady => '2p', + -side => 'left' ) } + $request -> pack ( -padx => '6p', + -pady => '2p', + -side => 'left' ) } + +$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) } } + +#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 ; |