#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 ('', \&update_setup ) ; $cw -> bind ('<1>' , \&update_setup ) ; $cw -> bind ('' , \&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 () { 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 ('', 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 ( "", sub { insert_request(shift, $chr) } ) } $mw -> bind ( "", 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 ( "", sub { delete_request } ) ; sub new_request { $request -> delete (0,'end') ; handle_request } $mw -> bind ( "", 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 ;