blob: 8c73da50fce72df426cf8c929606889f724abbf2 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
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;
|