diff options
author | Hans Hagen <pragma@wxs.nl> | 2009-10-16 16:13:00 +0200 |
---|---|---|
committer | Hans Hagen <pragma@wxs.nl> | 2009-10-16 16:13:00 +0200 |
commit | 7f9b179ad5be5000f67192f283d20e7120402bd9 (patch) | |
tree | 18f83a8cbfe7fed1c2a6939fb4b2cf10473abbbe /scripts | |
parent | c878054f6360d50885dbdab96643a8f3ac61c46c (diff) | |
download | context-7f9b179ad5be5000f67192f283d20e7120402bd9.tar.gz |
beta 2009.10.16 16:13
Diffstat (limited to 'scripts')
-rw-r--r-- | scripts/context/lua/mtx-context.lua | 15 | ||||
-rw-r--r-- | scripts/context/lua/mtx-fonts.lua | 4 | ||||
-rw-r--r-- | scripts/context/lua/mtx-profile.lua | 2 | ||||
-rw-r--r-- | scripts/context/lua/mtx-update.lua | 1 | ||||
-rw-r--r-- | scripts/context/perl/texshow.pl | 956 |
5 files changed, 15 insertions, 963 deletions
diff --git a/scripts/context/lua/mtx-context.lua b/scripts/context/lua/mtx-context.lua index b94b330bd..418387fce 100644 --- a/scripts/context/lua/mtx-context.lua +++ b/scripts/context/lua/mtx-context.lua @@ -299,7 +299,6 @@ found = usedname ~= "" xml.each(command,"ctx:new", function(r,d,k) d[k] = ctxrunner.substitute(newfile) end) - -- message: preprocessing #{oldfile} into #{newfile} using #{pp} ctxdata.variables['old'] = oldfile ctxdata.variables['new'] = newfile xml.each(command,"ctx:value", function(r,d,k) @@ -750,6 +749,10 @@ function scripts.context.run(ctxdata,filename) if environment.argument("batchmode") then flags[#flags+1] = "--interaction=batchmode" end + if environment.argument("synctex") then + logs.simple("warning: syntex is enabled") -- can add upto 5% runtime + flags[#flags+1] = "--synctex=1" + end flags[#flags+1] = "--fmt=" .. string.quote(formatfile) flags[#flags+1] = "--lua=" .. string.quote(scriptfile) flags[#flags+1] = "--backend=pdf" @@ -769,16 +772,16 @@ function scripts.context.run(ctxdata,filename) --~ scripts.context.make(formatname) --~ returncode, errorstring = os.spawn(command) --~ if returncode == 3 then - --~ logs.simple("fatal error, return code 3, message: %s",errorstring or "?") + --~ logs.simple("ks: return code 3, message: %s",errorstring or "?") --~ os.exit(1) --~ end --~ end if not returncode then - logs.simple("fatal error, no return code, message: %s",errorstring or "?") + logs.simple("fatal error: no return code, message: %s",errorstring or "?") os.exit(1) break elseif returncode > 0 then - logs.simple("fatal error, return code: %s",returncode or "?") + logs.simple("fatal error: return code: %s",returncode or "?") os.exit(returncode) break else @@ -799,10 +802,10 @@ function scripts.context.run(ctxdata,filename) logs.simple("arrange run: %s",command) local returncode, errorstring = os.spawn(command) if not returncode then - logs.simple("fatal error, no return code, message: %s",errorstring or "?") + logs.simple("fatal error: no return code, message: %s",errorstring or "?") os.exit(1) elseif returncode > 0 then - logs.simple("fatal error, return code: %s",returncode or "?") + logs.simple("fatal error: return code: %s",returncode or "?") os.exit(returncode) end end diff --git a/scripts/context/lua/mtx-fonts.lua b/scripts/context/lua/mtx-fonts.lua index dd3190475..42e5e3f2c 100644 --- a/scripts/context/lua/mtx-fonts.lua +++ b/scripts/context/lua/mtx-fonts.lua @@ -134,6 +134,8 @@ function scripts.fonts.save(name,sub) else save(fontinfo.fullname,fontloader.open(filename)) end + else + logs.simple("font: %s cannot be read",filename) end else logs.simple("font: %s not saved",filename) @@ -141,6 +143,8 @@ function scripts.fonts.save(name,sub) else logs.simple("font: %s not found",name) end + else + logs.simple("font: no name given") end end diff --git a/scripts/context/lua/mtx-profile.lua b/scripts/context/lua/mtx-profile.lua index d99f7e926..1db9682ac 100644 --- a/scripts/context/lua/mtx-profile.lua +++ b/scripts/context/lua/mtx-profile.lua @@ -95,7 +95,7 @@ function scripts.profiler.analyse(filename) end end -function scripts.profiler.analyse(filename) +function scripts.profiler.x_analyse(filename) local f = io.open(filename) local calls = { } local lines = 0 diff --git a/scripts/context/lua/mtx-update.lua b/scripts/context/lua/mtx-update.lua index bc6ca4026..ef05f087d 100644 --- a/scripts/context/lua/mtx-update.lua +++ b/scripts/context/lua/mtx-update.lua @@ -69,6 +69,7 @@ scripts.update.base = { { "context/img/", "texmf-context" }, { "misc/setuptex/", "." }, { "misc/web2c", "texmf" }, + { "bin/common/luatex/", "texmf-<platform>" }, { "bin/common/<platform>/", "texmf-<platform>" }, { "bin/context/<platform>/", "texmf-<platform>" }, { "bin/metapost/<platform>/", "texmf-<platform>" }, diff --git a/scripts/context/perl/texshow.pl b/scripts/context/perl/texshow.pl deleted file mode 100644 index 629c28f99..000000000 --- a/scripts/context/perl/texshow.pl +++ /dev/null @@ -1,956 +0,0 @@ -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=2006.08.04, -#D title=TeXShow, -#D subtitle=showing \CONTEXT\ commands, -#D author=Taco Hoekwater, -#D date=\currentdate, -#D copyright={Taco Hoekwater}] - -#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 -#D -#D ChangeLog: -#D \startitemize -#D \item Add keyboard bindings for quitting the app: Ctrl-q,Ctrl-x,Alt-F4 (2006/07/19) -#D \item Support for define --resolve (2006/08/04) -#D \stopitemize - -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=s" => \$Interface , - "debug" => \$Debug, - "edit" => \$Editmode) ; - -print "\n"; - -show('TeXShow-XML 0.3 beta','Taco Hoekwater 2006',"/"); - -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() } ) ; - $mainwindow -> bind ( "<Control-x>", sub { exit(0) } ) ; - $mainwindow -> bind ( "<Control-X>", sub { exit(0) } ) ; - $mainwindow -> bind ( "<Control-q>", sub { exit(0) } ) ; - $mainwindow -> bind ( "<Control-Q>", sub { exit(0) } ) ; - $mainwindow -> bind ( "<Alt-F4>", sub { exit(0) } ) ; -} - -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 --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) = @_; - my $localdefs = {}; - unless (keys %{$setups{$filename}}) { - if (open(IN,"<${path}$filename.xml")) { - my $position = 0 ; - local $/ = '</cd:command>'; - while (my $data= <IN>) { - next if $data =~ /\<\/cd:interface/; - if ($data =~ /\<cd:interface/) { - $data =~ s/^(.*?)\<cd:command/\<cd:command/sm; - my $meta = $1; - while ($meta =~ s!<cd:define name=(['"])(.*?)\1>(.*?)</cd:define>!!sm) { - my $localdef = $2; - my $localval = $3; - $localdefs->{$localdef} = $localval; - } - } - # - if (keys %$localdefs) { - while ($data =~ /<cd:resolve/) { - $data =~ s/<cd:resolve name=(['"])(.*?)\1\/>/$localdefs->{$2}/ms; - } - } - $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(); -} - |