diff options
author | Hans Hagen <pragma@wxs.nl> | 2005-01-12 00:00:00 +0100 |
---|---|---|
committer | Hans Hagen <pragma@wxs.nl> | 2005-01-12 00:00:00 +0100 |
commit | 0fece0253ad71930dc23890d1ae3e1f76b296acb (patch) | |
tree | ee4101915a66616c98023bf6456d5615817b0766 /scripts/context/perl | |
parent | 5604cb0a875f6114b67391fd279060678a9b7937 (diff) | |
download | context-0fece0253ad71930dc23890d1ae3e1f76b296acb.tar.gz |
stable 2005.01.12
Diffstat (limited to 'scripts/context/perl')
-rw-r--r-- | scripts/context/perl/cont_set.pm | 2 | ||||
-rw-r--r-- | scripts/context/perl/makempy.pl | 18 | ||||
-rw-r--r-- | scripts/context/perl/texshow.pl | 1003 | ||||
-rw-r--r-- | scripts/context/perl/texutil.pl | 52 |
4 files changed, 932 insertions, 143 deletions
diff --git a/scripts/context/perl/cont_set.pm b/scripts/context/perl/cont_set.pm index c14cc679c..41c62e754 100644 --- a/scripts/context/perl/cont_set.pm +++ b/scripts/context/perl/cont_set.pm @@ -185,7 +185,7 @@ sub show_setups -font => $buttonfont , -selectcolor => 'ivory1' , -indicatoron => 0 , - command => \&change_setup , + -command => \&change_setup , -variable => \$setup_file ) ; $lw{$_} -> pack ( -padx => '2p', -pady => '2p', diff --git a/scripts/context/perl/makempy.pl b/scripts/context/perl/makempy.pl index c2a1bba51..49298f318 100644 --- a/scripts/context/perl/makempy.pl +++ b/scripts/context/perl/makempy.pl @@ -317,21 +317,20 @@ sub make_pdf_pages sub make_mp_figures { process ("postscript file") ; if ($pmethod) { run($posfile, "$pdftops", - #~ "-paperw 10000 -paperh 10000 $pdffile $posfile") } "-paper match $pdffile $posfile") } if ($gmethod) { run($posfile, "$ghostscript", "-q -sOutputFile=$posfile -dNOPAUSE -dBATCH -dSAFER -sDEVICE=pswrite $pdffile") } if ($amethod) { run($posfile, "$acroread", "-toPostScript -pairs $pdffile $posfile") } } -sub make_mp_pictures +sub make_mp_pictures_ps { process ("metapost file") ; - #~ if ($wereondos) - #~ { my $safeguard = `pstoedit -gstest` ; - #~ if ($safeguard =~ /\-I(.*?[\\\/])lib/mois) - #~ { $ENV{'PATH'} .= ";$1bin;" } } run ($tmpfile, "$pstoedit", "-ssp -dt -f mpost $posfile $tmpfile") } +sub make_mp_pictures_pdf + { process ("metapost file") ; + run ($tmpfile, "$pstoedit", "-ssp -dt -f mpost $pdffile $tmpfile") } + if ($help) { show_help_info } check_input_file ; @@ -339,8 +338,11 @@ verify_check_sum ; cleanup_files ; construct_tex_file ; make_pdf_pages ; -make_mp_figures ; -make_mp_pictures ; +if (1) + { make_mp_pictures_pdf ; } +else + { make_mp_figures ; + make_mp_pictures_ps ; } construct_mpy_file ; # less save : rename $tmpfile, $mpyfile ; unless ($noclean) { cleanup_files } diff --git a/scripts/context/perl/texshow.pl b/scripts/context/perl/texshow.pl index cc56a78a1..ec6f3fc07 100644 --- a/scripts/context/perl/texshow.pl +++ b/scripts/context/perl/texshow.pl @@ -1,97 +1,936 @@ -eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q' +eval '(exit $?0)' && eval 'exec perl -w -S $0 ${1+"$@"}' && eval 'exec perl -w -S $0 $argv:q' if 0; #D \module #D [ file=texshow.pl, -#D version=1999.03.30, -#D title=\TEXSHOW, +#D version=2005.01.06, +#D title=TeXShow, #D subtitle=showing \CONTEXT\ commands, -#D author=Hans Hagen, +#D author=Taco Hoekwater, #D date=\currentdate, -#D copyright={PRAGMA / Hans Hagen \& Ton Otten}, -#D suggestions={Tobias Burnus \& Taco Hoekwater}] -#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 We need to find the module path. We could have used: -#D -#D \starttypen -#D use FindBin ; -#D use lib $FindBin::Bin ; -#D \stoptypen -#D -#D But because we're sort of depending on \WEBC\ anyway, the -#D next few lines are more appropriate: - -BEGIN { - $cont_pm_path = `kpsewhich --format="texmfscripts" --progname=context cont_mis.pm` ; - chomp($cont_pm_path) ; - if ($cont_pm_path eq '') { - $cont_pm_path = `kpsewhich --format="other text files" --progname=context cont_mis.pm` ; - chomp($cont_pm_path) ; - } - $cont_pm_path =~ s/cont_mis\.pm.*// ; -} - -use lib $cont_pm_path ; +#D copyright={Taco Hoekwater}] -#D Now we can load some modules: +#D Early 1999 \TEXSHOW\ showed up in the \CONTEXT\ distribution. At that time +#D the user interface was described in files named \type {setup*.tex}. The +#D program used a stripped down version of these definition files, generated +#D by \CONTEXT\ itself. \TEXSHOW\ shows you the commands, their (optional) +#D arguments, as well as the parameters and their values. For some five years +#D there was no need to change \TEXSHOW. However, when a few years ago we +#D started providing an \XML\ variant of the user interface definitions, Taco +#D came up with \TEXSHOW||\XML. Because Patricks \CONTEXT\ garden and tools +#D like \CTXTOOLS\ also use the \XML\ definitions, it's time to drop the old +#D \TEX\ based definitions and move forward. From now on Taco's version is the +#D one to be used. +#D +#D Hans Hagen - Januari 2005 +use strict; use Getopt::Long ; +use XML::Parser; +use Data::Dumper; +use Tk; +use Tk::ROText ; +use Config; +use Time::HiRes; $Getopt::Long::passthrough = 1 ; # no error message $Getopt::Long::autoabbrev = 1 ; # partial switch accepted +my $ShowHelp = 0; +my $Debug = 0; +my $Editmode = 0; +my $Interface = 'cont-en'; +my $current_command; +my $current_interface; +my $current_part; +my @setup_files; + +my %setups; +my %commes; +my %descrs; +my %examps; +my %trees; +my %positions; +my %locations; +my %crosslinks; + + &GetOptions ( "help" => \$ShowHelp , - "interface" => \$Interface ) ; - -cont_mis::banner ('TeXShow 0.1 - ConTeXt', 'PRAGMA ADE 1999') ; - -if ($ShowHelp) - { cont_mis::help ('--help', "print this help") ; - cont_mis::help ('--interface', "primary interface") ; - cont_mis::help ('string', "show info about command 'string'") ; - cont_mis::help ('string lg', "show info about 'string' in language 'lg'") ; - cont_mis::crlf () ; - exit 0 } - -use cont_mis ; -use cont_set ; - -use Tk ; - -#D This scripts is rather simple, because most of the action -#D takes place in the module \type {cont_set.pm}. - -cont_mis::status ('searching for setup files') ; - -if (cont_set::setups_found) - { cont_mis::status ('loading setups') ; - cont_set::load_setups ; - cont_mis::status ('preparing display') ; - cont_set::show_setups ; - $command = $ARGV[0] ; - $interface = $ARGV[1] ; - if ($interface) - { $Interface = $interface } - if ($Interface) - { cont_set::set_setup_interface($Interface) ; - cont_mis::message ('primary interface', $Interface) } - if ($command) - { cont_mis::message ('searching command', $command) ; - cont_set::show_setup ($command) } - else - { cont_mis::warning ('no command specified') ; - cont_set::set_setup_title('TeXShow : ConTeXt commands') } - cont_mis::status ('entering main loop') ; - #$mw -> bind ('<ctrl-q>', exit ) ; - #$mw -> bind ('<esc>', exit ) ; - MainLoop () } -else - { cont_mis::error ('no setup files found') } - -END { cont_mis::crlf ; - cont_mis::status ('closing down') } + "interface=s" => \$Interface , + "debug" => \$Debug, + "edit" => \$Editmode) ; + +print "\n"; + +show('TeXShow-XML 0.2 beta','Taco Hoekwater 2004',"/"); + +print "\n"; + +if ($ShowHelp) { + show('--help','print this help'); + show('--interface=lg','primary interface'); + show('--debug','print debugging info'); + show('string','show info about command \'string\''); + show('string lg','show info about \'string\' in language \'lg\''); + print "\n"; + exit 0; +} + +my $command = $ARGV[0] || ''; +my $interface = $ARGV[1] || ''; +if ($interface =~ /^[a-z][a-z]$/i) { + $Interface = 'cont-' . lc($interface); +} elsif ($interface && $command =~ /^[a-z][a-z]$/i) { + show('debug',"switching '$interface' and '$command'"); + $Interface = 'cont-' . lc($command); + $command = $interface; +} + +if ($command =~ s/^\\//) { + show('debug','removed initial command backslash'); +} + +show('interface', $Interface); +if ($command){ + show ('command', "\\$command") ; +} + +print "\n"; + +show('status','searching for setup files'); + +my $setup_path; +my ($mainwindow,$interfaceframe,$partframe,$leftframe,$rightframe,$buttonframe); +my ($request,$listbox,$textwindow,%interfacebuttons,%partbuttons); + +my ($textfont,$userfont,$buttonfont); + +my $Part; + +if (setups_found($Interface)) { + $current_interface = ''; + $current_command = ''; + $current_part = 'Command'; + show('status','loading setups') ; + load_setups($Interface) ; + show ('status','initializing display') ; + initialize_display(); + change_setup(); + show_command ($command); + $mainwindow->deiconify(); + show ('status','entering main loop') ; + MainLoop () ; + show ('status','closing down') ; +} else { + show ('error','no setup files found') ; +} +print "\n"; + +sub initialize_display { + my $dosish = ($Config{'osname'} =~ /dos|win/i) ; + my $default_size = $dosish ? 9 : 12 ; + my $s_vertical = 30 ; + my $s_horizontal = 72 ; + my $c_horizontal = 24 ; + if (!$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"; + } else { + $textfont = "Courier $default_size " ; + $userfont = "Courier $default_size italic" ; + $buttonfont = "Helvetica $default_size bold " ; + } + $mainwindow = MainWindow -> new ( -title => 'ConTeXt commands' ) ; + $buttonframe = $mainwindow -> Frame () ; # buttons + $leftframe = $mainwindow -> Frame () ; # leftside + $rightframe = $mainwindow -> Frame(); + $request = $rightframe -> Entry (-font => $textfont, + -background => 'ivory1', + -width => $c_horizontal); + $listbox = $rightframe -> Scrolled ('Listbox', + -scrollbars => 'e', + -font => $textfont, + -width => $c_horizontal, + -selectbackground => 'gray', + -background => 'ivory1', + -selectmode => 'browse') ; + $textwindow = $leftframe -> Scrolled ('ROText', + -scrollbars => 'se', + -height => $s_vertical, + -width => $s_horizontal, + -wrap => 'none', + -background => 'ivory1', + -font => $textfont); + $interfaceframe = $leftframe -> Frame(); + $mainwindow -> withdraw() ; + $mainwindow -> resizable ('y', 'y') ; + foreach (@setup_files) { + $interfacebuttons{$_} = $buttonframe -> Radiobutton (-text => $_, + -value => $_, + -font => $buttonfont, + -selectcolor => 'ivory1', + -indicatoron => 0, + -command => \&change_setup, + -variable => \$Interface ); + + $interfacebuttons{$_} -> pack (-padx => '2p',-pady => '2p','-side' => 'left' ); + } + foreach (qw(Command Description Comments Examples)) { + $partbuttons{$_} = $interfaceframe -> Radiobutton (-text => $_, + -value => $_, + -font => $buttonfont, + -selectcolor => 'ivory1', + -indicatoron => 0, + -command => \&change_part, + -variable => \$Part ); + $partbuttons{$_} -> pack (-padx => '2p',-pady => '2p','-side' => 'left' ); + } + # global top + $buttonframe -> pack ( -side => 'top' , -fill => 'x' , -expand => 0 ) ; + # top in left + $interfaceframe -> pack ( -side => 'top' , -fill => 'x' , -expand => 0 ) ; + $textwindow -> pack ( -side => 'top' , -fill => 'both' , -expand => 1 ) ; + $leftframe -> pack ( -side => 'left' , -fill => 'both' , -expand => 1 ) ; + # right + $request -> pack ( -side => 'top' , -fill => 'x' ) ; + $listbox -> pack ( -side => 'bottom' , -fill => 'both' , -expand => 1 ) ; + $rightframe -> pack ( -side => 'right' , -fill => 'both' , -expand => 1 ) ; + $listbox -> bind ('<B1-Motion>', \&show_command ) ; + $listbox -> bind ('<1>' , \&show_command ) ; + $listbox -> bind ('<Key>' , \&show_command ) ; + $textwindow -> tag ('configure', 'user' , -font => $userfont ) ; + $textwindow -> tag ('configure', 'optional' , -font => $userfont ) ; + $textwindow -> tag ('configure', 'command' , -foreground => 'green3' ) ; + $textwindow -> tag ('configure', 'variable' , -font => $userfont ) ; + $textwindow -> tag ('configure', 'default' , -underline => 1 ) ; + $textwindow -> tag ('configure', 'symbol' , -foreground => 'blue3' ) ; + $textwindow -> tag ('configure', 'or' , -foreground => 'yellow3' ) ; + $textwindow -> tag ('configure', 'argument' , -foreground => 'red3' ) ; + $textwindow -> tag ('configure', 'par' , -lmargin1 => '4m' , + -wrap => 'word' , + -lmargin2 => '6m' ) ; + foreach my $chr ('a'..'z','A'..'Z') { + $mainwindow -> bind ( "<KeyPress-$chr>", sub { insert_request(shift, $chr) } ); + } + $request -> bind ('<Return>', sub { handle_request() } ) ; + $mainwindow -> bind ( "<backslash>", sub { insert_request(shift, "\\") } ) ; + $mainwindow -> bind ( "<space>", sub { new_request() } ) ; + $mainwindow -> bind ( "<BackSpace>", sub { delete_request() } ) ; + $mainwindow -> bind ( "<Prior>", sub { prev_command() } ) ; + $mainwindow -> bind ( "<Next>", sub { next_command() } ) ; +} + +sub show { + my ($pre,$post,$sep) = @_; + unless ($pre eq 'debug' && !$Debug) { + $sep = ':' unless defined $sep; + print sprintf("%22s $sep %+s\n",$pre,$post); + } +} + +sub change_setup { + # switches to another setup file + if ($current_interface ne $Interface ) { + my $loc = 0; + if ($current_command) { + $loc = $positions{$Interface}{$current_command} || 0; + } + my @list = sort {lc $a cmp lc $b} keys %{$setups{$Interface}} ; + my $num = 0; + map { $locations{$Interface}{$_} = $num++; } @list; + $listbox -> delete ('0.0', 'end') ; + $listbox -> insert ('end', @list) ; + # try to switch to other command as well, here. + if ($current_command ne '') { + show_command($crosslinks{$Interface}[$loc] || ''); + } else { + $listbox -> selectionSet ('0.0', '0.0') ; + $listbox -> activate ('0.0') ; + } + } + $current_interface = $Interface; + $mainwindow -> focus ; +} + +sub change_part { + if ($Part ne $current_part) { + if($Part eq 'Command') { + show_command(); + } elsif ($Part eq 'Description') { + show_description(); + } elsif ($Part eq 'Comments') { + show_comments(); + } elsif ($Part eq 'Examples') { + show_examples(); + } + } + $current_part = $Part; +} + + +sub setups_found { + # find the setup files + my ($primary) = @_; + $setup_path = `kpsewhich --format="other text files" --progname=context cont-en.xml` ; + chomp $setup_path; + show ('debug', "path = '$setup_path'"); + if ($setup_path) { + $setup_path =~ s/cont-en\.xml.*// ; + @setup_files = glob ("${setup_path}cont\-??.xml") ; # HH: pattern patched, too greedy + show ('debug', "globbed path into '@setup_files'"); + if (@setup_files) { + my $found = 0; + foreach (@setup_files) { + s/\.xml.*$//; + s/^.*?cont-/cont-/; + if ($_ eq $primary) { + $found = 1; + show ('debug', "found primary setup '$primary'"); + } else { + show ('debug', "found non-primary setup '$_'"); + } + } + if ($found) { + return 1; + } else { + show('error',"setup file for '$primary' not found, using 'cont-en'"); + $Interface = 'cont-en'; + return 1; + } + } else { + show('error',"setup file glob failed"); + } + } elsif ($!) { + show('error','kpsewhich not found'); + } else { + show('error','setup files not found'); + } + return 0; +} + +sub load_setup { + my ($path,$filename) = @_; + unless (keys %{$setups{$filename}}) { + if (open(IN,"<${path}$filename.xml")) { + my $position = 0 ; + local $/ = '</cd:command>'; + while (my $data= <IN>) { + if ($data =~ /\<\/cd:interface/) { + next; + } + if ($data =~ /\<cd:interface/) { + $data =~ s/^(.*?)\<cd:command/\<cd:command/sm; + my $meta = $1; + } + # + $data =~ s/\s*\n\s*//g; + $data =~ /\<cd:command(.*?)\>/; + my $info = $1; + my ($name,$environment) = ('',''); + while ($info =~ s/^\s*(.*?)\s*=\s*(["'])(.*?)\2\s*//) { + my $a = $1; my $b = $3; + if ($a eq 'name') { + $name = $b; + } elsif ($a eq 'type') { + $environment = $b; + } + } + my $cmd = $name; + if ($environment) { + $cmd = "start" . $name; + } + $setups {$filename}{$cmd} = $data ; + $trees {$filename}{$cmd} = undef; + $positions {$filename}{$cmd} = ++$position ; + $crosslinks{$filename}[$position] = $cmd ; + } + close IN; + # now get explanations as well ... + my $explname = $filename; + $explname =~ s/cont-/expl-/; + my $extras = 0 ; + if (open(IN,"<${path}$explname.xml")) { + local $/ = '</cd:explanation>'; + while (my $data= <IN>) { + if ($data =~ /\<\/cd:explanations/) { + next; + } + if ($data =~ /\<cd:explanations/) { + $data =~ s/^(.*?)\<cd:explanation /\<cd:explanation /sm; + my $meta = $1; + } + # + $extras++; + $data =~ /\<cd:explanation(.*?)\>/; + my $info = $1; + my ($name,$environment) = ('',''); + while ($info =~ s/^\s*(.*?)\s*=\s*(["'])(.*?)\2\s*//) { + my $a = $1; my $b = $3; + if ($a eq 'name') { + $name = $b; + } elsif ($a eq 'type') { + $environment = $b; + } + } + my $cmd = $name; + if ($environment) { + $cmd = "start" . $name; + } + my $comment = ''; + my $description = ''; + my @examples = (); + $data =~ /\<cd:description\>(.*)\<\/cd:description\>/s and $description = $1; + $data =~ /\<cd:comment\>(.*)\<\/cd:comment\>/s and $comment = $1; + while ($data =~ s/\<cd:example\>(.*?)\<\/cd:example\>//s) { + push @examples, $1; + } + if (length($comment) && $comment =~ /\S/) { + $commes {$filename}{$cmd} = $comment; + } + if (length($description) && $description =~ /\S/) { + $descrs {$filename}{$cmd} = $description; + } + my $testex = "@examples"; + if (length($testex) && $testex =~ /\S/) { + $examps {$filename}{$cmd} = [@examples]; + } + } + } + if ($extras) { + show('debug',"interface '$filename', $position\&$extras commands"); + } else { + show('debug',"interface '$filename', $position commands"); + } + } else { + show ('debug',"open() of ${path}$filename.xml failed"); + } + } + $Interface = $filename ; +} + +sub load_setups { + my ($primary) = @_; + # load all setup files, but default to $primary + my $t0 = [Time::HiRes::gettimeofday()]; + foreach my $setup (@setup_files) { + if ($setup ne $primary) { + load_setup ($setup_path,$setup); + show('status',"loading '$setup' took " .Time::HiRes::tv_interval($t0) . " seconds"); + $t0 = [Time::HiRes::gettimeofday()]; + }; + }; + load_setup ($setup_path,$primary); + show('status',"loading '$primary' took " .Time::HiRes::tv_interval($t0) . " seconds"); +} + +my @history = (); +my $current_history = 0; + +sub show_command { + my ($command,$nofix) = @_; + if (keys %{$setups{$Interface}}) { + my $key = ''; + if (defined $command && $command && + (defined $setups{$Interface}{$command} || + defined $setups{$Interface}{"start" . $command})) { + $key = $command; + my $whence =$locations{$Interface}{$command}; + $listbox -> selectionClear ('0.0','end') ; + $listbox -> selectionSet($whence,$whence); + $listbox -> activate($whence); + $listbox -> see($whence); + } else { + $listbox -> selectionSet('0.0','0.0') unless $listbox->curselection(); + $key = $listbox -> get($listbox->curselection()) ; + } + show('debug',"current command: $current_command"); + show('debug'," new command: $key"); + $current_command = $key ; + $textwindow -> delete ('1.0', 'end' ) ; + $partbuttons{"Command"}->select(); + $partbuttons{"Command"}->configure('-state' => 'normal'); + $partbuttons{"Description"}->configure('-state' => 'disabled'); + $partbuttons{"Comments"}->configure('-state' => 'disabled'); + $partbuttons{"Examples"}->configure('-state' => 'disabled'); + if (defined $commes{$Interface}{$key}) { + $partbuttons{"Comments"}->configure('-state' => 'normal'); + } + if (defined $descrs{$Interface}{$key}) { + $partbuttons{"Description"}->configure('-state' => 'normal'); + } + if (defined $examps{$Interface}{$key}) { + $partbuttons{"Examples"}->configure('-state' => 'normal'); + } + unless (defined $nofix && $nofix) { + push @history, $key; + $current_history = $#history; + } + do_update_command ($key) ; + $mainwindow -> update(); + $mainwindow -> focus() ; + } +} + +sub prev_command { + if ($current_history > 0) { + $current_history--; + show_command($history[$current_history],1); + } +} + +sub next_command { + unless ($current_history == $#history) { + $current_history++; + show_command($history[$current_history],1); + } +} + +sub show_description { + $textwindow -> delete ('1.0', 'end' ) ; + if (defined $descrs{$current_interface}{$current_command}) { + $textwindow-> insert ('end',$descrs{$current_interface}{$current_command}); + } + $mainwindow -> update(); + $mainwindow -> focus() ; +} + +sub show_comments { + $textwindow -> delete ('1.0', 'end' ) ; + if (defined $commes{$current_interface}{$current_command}) { + $textwindow-> insert ('end',$commes{$current_interface}{$current_command}); + } + $mainwindow -> update(); + $mainwindow -> focus() ; +} + + +sub show_examples { + $textwindow -> delete ('1.0', 'end' ) ; + if (defined $examps{$current_interface}{$current_command}) { + $textwindow-> insert ('end',join("\n\n",@{$examps{$current_interface}{$current_command}})); + } + $mainwindow -> update(); + $mainwindow -> focus() ; +} + + + + +sub has_attr { + my ($elem,$att,$val) = @_; + return 1 if (attribute($elem,$att) eq $val); + return 0; +} + + +sub view_post { + my ($stuff,$extra) = @_; + $extra = '' unless defined $extra; + $stuff =~ /^(.)(.*?)(.)$/; + my ($l,$c,$r) = ($1,$2,$3); + if ($l eq '[' || $l eq '(') { + return ($l,['symbol','par',$extra],$c,['par',$extra],$r,['symbol','par',$extra],"\n",'par'); + } else { + return ($l,['argument','par',$extra],$c,['par',$extra],$r,['argument','par',$extra],"\n",'par'); + } +} + +sub view_pre { + my ($stuff) = @_; + $stuff =~ /^(.)(.*?)(.)$/; + my ($l,$c,$r) = ($1,$2,$3); + if ($l eq '[' || $l eq '(') { + return ($l,['symbol'],$c,'',$r,['symbol']); + } else { + return ($l,['argument'],$c,'',$r,['argument']); + } +} + +sub create_setup_arguments { + my $argx = shift; + my @predisp = (); + my @postdisp = (); + foreach my $arg (children($argx)) { + if (name($arg) eq 'cd:keywords') { + # children are Constant* & Inherit? & Variable* + my @children = children($arg); + my $optional = (attribute($arg,'optional') eq 'yes' ? 'optional' : ''); + if (@children){ + push @predisp,'[', ['symbol',$optional]; + if (has_attr($arg,'list', 'yes')) { + if (has_attr($arg,'interactive', 'exclusive')) { + push @predisp, '...', ''; + } else { + push @predisp, '..,...,..', ''; + } + } else { + push @predisp,'...', ''; + } + push @predisp,']', ['symbol',$optional]; + } + push @postdisp,'[', ['symbol','par',$optional]; + my $firsttrue = 1; + foreach my $kwd (@children) { + if ($firsttrue) { + $firsttrue = 0; + } else { + push @postdisp,', ', ['symbol','par']; + } + if (name($kwd) eq 'cd:constant' || + name($kwd) eq 'cd:variable') { + my $v = attribute($kwd,'type'); + my $def = ''; + my $var = ''; + $var = 'variable' if (name($kwd) eq 'cd:variable') ; + $def = 'default' if (has_attr($kwd,'default', 'yes')); + if ($v =~ /^cd:/) { + $v =~ s/^cd://; + $v .= "s" if (has_attr($arg,'list', 'yes')); + push @postdisp, $v, ['user',$def,'par',$var]; + } else { + push @postdisp, $v, [$def,'par',$var]; + } + } elsif (name($kwd) eq 'cd:inherit') { + my $v = attribute($kwd,'name'); + $textwindow -> tag ('configure', $v , -foreground => 'blue3',-underline => 1 ) ; + $textwindow -> tagBind($v,'<ButtonPress>',sub {show_command($v)} ); + push @postdisp,"see ","par", "$v", [$v,'par']; + } + } + push @postdisp,']', ['symbol','par',$optional]; + push @postdisp,"\n", 'par'; + } elsif (name($arg) eq 'cd:assignments') { + # children are Parameter* & Inherit? + my @children = children($arg); + my $optional = (attribute($arg,'optional') eq 'yes' ? 'optional' : ''); + if (@children) { + push @predisp,'[', ['symbol',$optional]; + if (has_attr($arg,'list', 'yes')) { + push @predisp, '..,..=..,..', ''; + } else { + push @predisp,'..=..', ''; + } + push @predisp,']', ['symbol',$optional]; + push @postdisp,'[', ['symbol','par',$optional]; + my $isfirst = 1; + foreach my $assn (@children) { + if ($isfirst) { + $isfirst = 0; + } else { + push @postdisp,",\n ", ['symbol','par']; + } + if (name($assn) eq 'cd:parameter') { + push @postdisp,attribute($assn,'name'), 'par'; + push @postdisp,'=', ['symbol','par']; + my $firstxtrue = 1; + foreach my $par (children($assn)) { + if ($firstxtrue) { + $firstxtrue = 0; + } else { + push @postdisp,'|', ['or','par']; + } + if (name($par) eq 'cd:constant' || name($par) eq 'cd:variable') { + my $var = ''; + $var = 'variable' if name($par) eq 'cd:variable'; + my $v = attribute($par,'type'); + if ($v =~ /^cd:/) { + $v =~ s/^cd://; + push @postdisp,$v, ['user','par',$var]; + } else { + push @postdisp,$v, ['par',$var]; + } + } + } + } elsif (name($assn) eq 'cd:inherit') { + my $v = attribute($assn,'name'); + $textwindow -> tag ('configure', $v , -foreground => 'blue3',-underline => 1 ) ; + $textwindow -> tagBind($v,'<ButtonPress>',sub {show_command($v)} ); + push @postdisp,"see ","par", "$v", [$v,'par']; + } + } + push @postdisp,"]", ['symbol','par',$optional], "\n", ''; + } + } elsif (name($arg) eq 'cd:content') { + push @predisp, view_pre('{...}'); + push @postdisp, view_post('{...}'); + } elsif (name($arg) eq 'cd:triplet') { + if (has_attr($arg,'list','yes')) { + push @predisp, view_pre('[x:y:z=,..]'); + push @postdisp,view_post('[x:y:z=,..]'); + } else { + push @predisp, view_pre('[x:y:z=]'); + push @postdisp,view_post('[x:y:z=]'); + } + } elsif (name($arg) eq 'cd:reference') { + my $optional = (attribute($arg,'optional') eq 'yes' ? 'optional' : ''); + if (has_attr($arg,'list','yes')) { + push @postdisp, view_post('[ref,..]',$optional); + push @predisp, view_pre('[ref,..]'); + } else { + push @postdisp, view_post('[ref]',$optional); + push @predisp, view_pre('[ref]');; + } + } elsif (name($arg) eq 'cd:word') { + if (has_attr($arg,'list','yes')) { + push @predisp, view_pre ('{...,...}'); + push @postdisp,view_post('{...,...}'); + } else { + push @predisp, view_pre('{...}'); + push @postdisp, view_post('{...}'); + } + } elsif (name($arg) eq 'cd:nothing') { + my $sep = attribute($arg,'separator'); + if ($sep) { + if($sep eq 'backslash') { +# push @postdisp,'\\\\','par'; + push @predisp,'\\\\',''; + } else { +# push @postdisp,$sep,'par'; + push @predisp,$sep,''; + } + } + push @predisp,'...',''; + push @postdisp,'text',['variable','par'],"\n",'par'; + } elsif (name($arg) eq 'cd:file') { + push @predisp,'...',['default']; + push @postdisp,'...',['default','par'],"\n",'par'; + } elsif (name($arg) eq 'cd:csname') { + push @predisp,'\command',['command']; + push @postdisp,'\command',['command','par'],"\n",'par'; + } elsif (name($arg) eq 'cd:index') { + if (has_attr($arg,'list','yes')) { + push @predisp,view_pre('{..+...+..}'); + push @postdisp,view_post('{..+...+..}'); + } else { + push @predisp, view_pre('{...}'); + push @postdisp,view_post('{...}'); + } + } elsif (name($arg) eq 'cd:position') { + if (has_attr($arg,'list','yes')) { + push @predisp,view_pre('(...,...)'); + push @postdisp,view_post('(...,...)'); + } else { + push @predisp,view_pre('(...)'); + push @postdisp,view_post('(...)'); + } + } elsif (name($arg) eq 'cd:displaymath') { + push @predisp, ('$$',['argument'],'...','','$$',['argument']); + push @postdisp, ('$$',['argument','par'],'...',['par'],'$$',['argument','par']); + } elsif (name($arg) eq 'cd:tex') { + my $sep = attribute($arg,'separator'); + if ($sep) { + if($sep eq 'backslash') { +# push @postdisp,'\\\\','par'; + push @predisp,'\\\\',''; + } else { +# push @postdisp,$sep,'par'; + push @predisp,$sep,''; + } + } + my $cmd = "\\" . attribute($arg,'command'); + push @predisp,$cmd,''; +# push @postdisp,$cmd,['command','par'],"\n",'par'; + } + } + return (\@predisp,\@postdisp); +} + + +# <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo> +# +# would be: +# +# Tag Content +# ================================================================== +# [foo, [{}, head, [{id => "a"}, 0, "Hello ", em, [{}, 0, "there"]], +# bar, [ {}, 0, "Howdy", ref, [{}]], +# 0, "do" +# ] +# ] + +sub attribute { + my ($elem,$att) = @_; + if (defined $elem->[1] && defined $elem->[1]->[0] && defined $elem->[1]->[0]->{$att}) { + my $ret = $elem->[1]->[0]->{$att}; + show ('debug',"returning attribute $att=$ret"); + return $elem->[1]->[0]->{$att}; + } else { + return ''; + } +} + +sub name { + my ($elem) = @_; + if (defined $elem->[0] ) { + return $elem->[0]; + } else { + return ''; + } +} + +# return all children at a certain level +sub children { + my ($elem) = @_; + if (defined $elem->[1] && defined $elem->[1]->[1]) { + my @items = @{$elem->[1]}; + shift @items ; # deletes the attribute. + my @ret = (); + while (@items) { + push @ret, [shift @items, shift @items]; + } + return @ret; + } else { + return (); + } +} + +# return the first child with the right name +sub find { + my ($elem,$name) = @_; + if ($elem->[0] eq $name) { + return $elem; + } + if (ref($elem->[1]) eq 'ARRAY') { + my @contents = @{$elem->[1]}; + shift @contents; + while (my $ename = shift @contents) { + my $con = shift @contents; + if ($ename eq $name) { + return [$ename,$con]; + } + } + } + return []; +} + +sub do_update_command # type: 0=display, 1=compute only + { my ($command, $type) = @_ ; + $type = 0 unless defined $type; + my $setup; + if (!defined $trees{$Interface}{$command}) { + my $parser = XML::Parser->new('Style' => 'Tree'); + $trees{$Interface}{$command} = $parser->parse($setups{$Interface}{$command}); + } + $setup = $trees{$Interface}{$command} ; + my $predisp = undef; + my $postdisp = undef; + my @cmddisp = (); + my @cmddispafter = (); + my $pradisp = undef; + my $altdisp = undef; + if (attribute($setup,'file')) { + my $filename = attribute($setup,'file'); + my $fileline = attribute($setup,'line') || 0; + $textwindow->insert ('end',"$filename:${fileline}::\n\n", '' ); + } + # start with backslash + push @cmddisp, "\\", 'command' ; + my $env = 0; + if (has_attr($setup,'type','environment')) { + $env = 1; + } + if ($env) { push @cmddisp, "start", 'command' ; } + if ($env) { push @cmddispafter, " ... ", '', "\\stop", 'command' ; } + my $seq = find($setup,'cd:sequence'); + # display rest of command name + foreach my $seqpart (children($seq)) { + my $text = attribute($seqpart,'value'); + if (name($seqpart) eq 'cd:variable') { + push @cmddisp, $text, ['command','user']; + if ($env) { push @cmddispafter, $text, ['command','user']; } + } elsif (name($seqpart) eq 'cd:string') { + push @cmddisp, $text, 'command'; + if ($env) { push @cmddispafter, $text, 'command'; } + } + } + # + my $args = find($setup,'cd:arguments'); + # display commands + if ($args) { + my $curarg = 0; + foreach my $arg (children($args)) { + if (name($arg) eq 'cd:choice') { + my ($a,$b) = children($arg); + ($predisp,$postdisp) = create_setup_arguments(['cd:arguments',[{}, @$a]]); + ($pradisp,$altdisp) = create_setup_arguments(['cd:arguments',[{}, @$b]]); + } else { + ($predisp,$postdisp) = create_setup_arguments($args); + } + $curarg++; + } + } + return if $type; + if(defined $postdisp) { + if(defined $altdisp) { + $textwindow->insert('end',@cmddisp,@$predisp,@cmddispafter, "\n",'', + @cmddisp,@$pradisp,@cmddispafter, "\n\n",'', + @cmddisp, "\n",'', + @$postdisp, "\n",'', + @cmddisp, "\n",'', + @$altdisp); + } else { + $textwindow->insert('end',@cmddisp,@$predisp, @cmddispafter ,"\n\n",'', + @cmddisp,"\n",'', + @$postdisp); + } + } else { + $textwindow->insert('end',@cmddisp); + } +} + + +#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 = $listbox -> index('end') ; + return unless $index; + my $req = $request -> get ; + return unless $req; + $req =~ s/\\//o ; + $req =~ s/\s//go ; + $request -> delete('0','end') ; + $request -> insert('0',$req) ; + return unless $req; + my ($l,$c) = split (/\./,$index) ; + for (my $i=0;$i<=$l;$i++) { + $index = "$i.0" ; + my $str = $listbox -> get ($index, $index) ; + if (defined $str && ref($str) eq 'ARRAY') { + $str = "@{$str}"; + } + if (defined $str && $str =~ /^$req/) { + show_command($str) ; + return ; + } + } +} + +sub insert_request { + my ($self, $chr) = @_ ; + # don't echo duplicate if $chr was keyed in in the (focussed) entrybox + $request -> insert ('end', $chr) unless $self eq $request; + handle_request(); +} + +sub delete_request { + my $self = shift ; + # delete last character, carefully + if ($self ne $request) { + my $to = $request -> index ('end') ; + my $from = $to - 1 ; + if ($from<0) { $from = 0 } + $request -> delete ($from,$to); + } + handle_request(); +} + +sub new_request { + $request -> delete (0,'end') ; + handle_request(); +} + diff --git a/scripts/context/perl/texutil.pl b/scripts/context/perl/texutil.pl index 31c5c1874..0d80b3a98 100644 --- a/scripts/context/perl/texutil.pl +++ b/scripts/context/perl/texutil.pl @@ -125,7 +125,6 @@ my $dosish = ($Config{'osname'} =~ /^(ms)?dos|^os\/2|^(ms|cyg)win/i) ; "purgeall" => \$PurgeAllFiles, "analyze" => \$AnalyzeFile, "filter" => \$FilterPages, - "sciteapi" => \$SciteApi, "help" => \$ProcessHelp, "silent" => \$ProcessSilent, "verbose" => \$ProcessVerbose, @@ -2815,57 +2814,6 @@ sub FilterPages # temp feature / no reporting close(PDF) ; close(TUO) } } -sub GenerateSciteApi # ugly, not generic, but fast, will become xsltproc based - { my $interface = $ARGV[0] ; - my $commands = 0 ; - my $environments = 0 ; - my %collection ; - my %mappings ; - return unless -f "cont-en.xml" ; - print " scite api file : cont-$interface-scite.api\n" ; - print " scite lexer file : cont-$interface-scite.properties\n" ; - if (open(XML,"<keys-$interface.xml")) - { while (<XML>) - { if (/\<cd\:command\s+name=\"(.*?)\"\s+value=\"(.*?)\".*?\>/o) - { $mappings{"$1"} = $2 } } - close(XML) } - else - { print " missing file : keys-$interface.xml\n" ; - return } - if (open(XML,"<cont-en.xml")) - { while (<XML>) - { chomp ; - if (/\<cd\:command\s+name=\"(.*?)\"\s+type=\"environment\".*?\>/o) - { $environments++ ; - $collection{"start$mappings{$1}"} = '' ; - $collection{"stop$mappings{$1}"} = '' } - elsif (/\<cd\:command\s+name=\"(.*?)\".*?\>/o) - { $commands++ ; - $collection{"$mappings{$1}"} = '' } } - close(XML) ; - if (open(API,">cont-$interface-scite.api")) - { foreach $name (keys %collection) - { print API "\\$name\n" } - print API "\n" ; - close(API) } - if (open(API,">cont-$interface-scite.properties")) - { my $i = 0 ; - print API "keywordclass.macros.context.$interface=" ; - foreach $name (keys %collection) - { if ($i==0) - { print API "\\\n " ; - $i = 5 } - else - { $i-- } - print API "$name " } - print API "\n" ; - close(API) } } - print " commands : $commands\n" ; - print " environments : $environments\n" } - -#D We're done! All this actions and options are organized in -#D one large conditional: - ShowBanner ; if ($UnknownOptions ) { ShowHelpInfo } # not yet done |