summaryrefslogtreecommitdiff
path: root/Build/source/utils/sam2p/contrib/sam2ptol.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/sam2p/contrib/sam2ptol.pm')
-rw-r--r--Build/source/utils/sam2p/contrib/sam2ptol.pm77
1 files changed, 77 insertions, 0 deletions
diff --git a/Build/source/utils/sam2p/contrib/sam2ptol.pm b/Build/source/utils/sam2p/contrib/sam2ptol.pm
new file mode 100644
index 00000000000..8c73da50fce
--- /dev/null
+++ b/Build/source/utils/sam2p/contrib/sam2ptol.pm
@@ -0,0 +1,77 @@
+# sam2ptol.pm by pts@math.bme.hu at Sun Apr 7 14:48:27 CEST 2002
+package sam2ptol;
+BEGIN{$^W=1}
+use integer;
+use strict;
+
+my %keys=qw{/InputFile 1 /OutputFile 1 /TmpRemove 1 /Profile 1
+ /FileFormat 1 /SampleFormat 1 /WarningOK 1 /TransferEncoding 1 /Compression 1
+ /Predictor 1 /Transparent 1 /Hints 1
+ /Effort 1 /RecordSize 1 /K 1 /Quality 1 /ColorTransform 1 /TransferCPL 1
+ /EncoderColumns 1 /EncoderRows 1 /EncoderColors 1
+ /PredictorColumns 1 /PredictorBPC 1 /PredictorColors 1
+ /Comment 1 /Title 1 /Subject 1 /Author 1 /Creator 1 /Producer 1
+ /Created 1 /Produced 1 /LoadHints 1 /Templates 1};
+# Dat: DCT is not key!
+my %values=qw{
+ /PSL1 1 /PSLC 1 /PSL2 1 /PSL3 1 /PDFB1.0 1 /PDFB1.2 1 /PDF1.0 1 /PDF1.2 1
+ /GIF89a 1 /Empty 1 /Meta 1 /PNM 1 /PAM 1 /PIP 1 /Opaque 1 /Transparent 1
+ /Transparent2 1 /Transparent4 1 /Transparent8 1 /Gray1 1 /Gray2 1 /Gray4 1
+ /Gray8 1 /Indexed1 1 /Indexed2 1 /Indexed4 1 /Indexed8 1 /Mask 1 /Rgb1 1
+ /Rgb2 1 /Rgb4 1 /Rgb8 1 /RGB1 1 /RGB2 1 /RGB4 1 /RGB8 1 /Asis 1 /Binary 1
+ /ASCII 1 /Hex 1 /AHx 1 /ASCIIHex 1 /A85 1 /ASCII85 1 /None 1 /LZW 1 /ZIP 1
+ /Flate 1 /Fl 1 /RLE 1 /RunLength 1 /RunLengthEncoded 1 /RL 1 /PackBits 1
+ /Fax 1 /CCITTFax 1 /CCF 1 /DCT 1 /JPEG 1 /JPG 1 /JFIF 1 /IJG 1 /JAI 1
+};
+
+sub highlight {
+ #** Example: perl -I. -Msam2ptol -e sam2ptol::highlight alma <examples/a_jpg.job
+ die "$0: 1arg, tclPath expected\n" if @ARGV!=1;
+ my $w=$ARGV[0]; # name of the widget
+ $_=join'',<STDIN>;
+ my($beg,$end,$c,$ta,$tb);
+ for (qw{tError tInt tComment tString tSing tKey tNameval tBrac}) { print "$w tag remove tString 1.0 end\n" }
+ while (m@(
+ \((\\.|[^\\()]+)*\) # String. Imp: nesting??
+ |/([^\000-\040/\%{}<>\[\]()\177-\377]*) # Sname
+ |[_A-Za-z_]([^\000-\040/\%{}<>\[\]()\177-\377]*) # Ename
+ |<<|>>|\[|\]
+ |true|false|pop|null
+ |%[^\r\n]*
+ |-?\d+
+ )@gsx) {
+ my $e=$1;
+ $beg=($end=pos())-length($e);
+ $c=substr($e,0,1);
+ $ta="$w tag add"; $tb=" {1.0 + $beg chars} {1.0 + $end chars}\n";
+ if ($c eq'/') {
+ if (exists $keys{$e}) {
+ print "$ta tKey$tb";
+ # print STDERR "($e)\n";
+ } elsif (exists $values{$e}) {
+ print "$ta tNameval$tb";
+ } else {
+ print "$ta tError$tb";
+ }
+ } elsif ($c eq'(') {
+ print "$ta tString$tb";
+ print "$w tag add tString {1.0 + $beg chars} {1.0 + $end chars}\n"
+ } elsif ($e eq'true' or $e eq'false' or $e eq'pop' or $e eq'null') {
+ print "$ta tSing$tb";
+ } elsif ($e=~/\A[_A-Za-z]/) {
+ # } elsif ($e=~/\A\w/) {
+ # print STDERR "($e)\n";
+ print "$ta tError$tb";
+ } elsif ($c eq'%') {
+ print "$ta tComment$tb";
+ } elsif ($c eq'-' or ord($c)>=ord('0') and ord($c)<=ord('9')) {
+ print "$ta tInt$tb";
+ } else {
+ print "$ta tBrac$tb";
+ }
+ print "$ta tAny$tb";
+ # print "[".pos()."]\n";
+ }
+}
+
+1;