ViewVC Help

View File | Revision Log | Show Annotations | Root Listing

root/cvsroot/COMP/SCRAM/src/Utilities/Switcher.pm

Comparing COMP/SCRAM/src/Utilities/Switcher.pm (file contents):
Revision 1.1 by williamc, Mon Mar 1 10:35:01 1999 UTC vs.
Revision 1.9 by williamc, Thu Jul 1 12:28:09 1999 UTC

#	Line 1 | Line 1
1	–	#!/usr/local/bin/perl5
2	–	#
1		# Switcher Module
2		#
3		# Look for elements given in input has in a string
4		# If found then call a routine name with the same name
5		# Implemented as an object to maintain state info between each line
6		# processed.
7	+	# Interface
8	+	# ---------
9	+	# new(file,objectref) : A new object -  filename of file to parse
10	+	#                                   objectref->of the methods
11	+	# usetags(tagobjref)               : Specify a tagcontainer set to direct to
12	+	#                                    to the desired routines
13	+	# usegroupchecker(groupchecker)    : Set a groupchecker
14	+	# parse()                          : Parse the file
15	+	# checkparam($name,$par)    : Exit with an error message if parameter
16	+	#                             is undefined in tag $name
17	+	# line()                    : return the current line number of the parse
18
19		package Switcher;
20	<	require Exporter;
20	>	require 5.001;
21		use Carp;
13	–	@ISA    = qw(Exporter);
22
23		sub new {
24		my $class=shift;
17	–	my $hash=shift;
25		my $file=shift;
26	+	my $objectname=shift;
27	+	my $groupchecker=shift;
28	+
29		my $self = {};
30	+	$self->{allw}=$objectname;
31		bless $self, $class;
32	<	$self->_initialise($hash,$file);
32	>	$self->_initialise($file);
33		return $self;
34		}
35
36		sub _initialise (hash1) {
37		my $self=shift;
27	–	my $inlabelhash=shift;
28	–	my $newkey;
29	–	my $key;
38		$self->{filename}=shift;
31	–	$self->{labelhash}={};
32	–	$self->{Strict_no_cr}='yes'; # set to 'no' to retain \n's
39
40	<	# setup SGML type tag definitions
41	<	# Others may be added without problems but ensure to provide
42	<	# a closure with a hash value of the correct type
43	<	# No capitals thanks.
44	<	%{$self->{opencontext}}=(
45	<	'<' => 'starttag',
46	<	'</' => 'endtag'
47	<	);
48	<	%{$self->{closecontext}}= (
49	<	">" => 'tag'
44	<	);
45	<
46	<	# Fill in the blanks in the user supplied hash
47	<	if ( ! ( defined $$inlabelhash{'none'} )) { # check for none target
48	<	$$inlabelhash{'none'}='none';
49	<	}
50	<	block1: foreach $key ( keys %$inlabelhash ) {
51	<	($newkey=$key)=~tr[A-Z][a-z];
52	<	${$self->{labelhash}}{$newkey}=$$inlabelhash{$key};
53	<	foreach $context ( values %{$self->{opencontext}} ) {
54	<	next block1 if $newkey=~/$context/i;
55	<	}
56	<	foreach $context ( values %{$self->{opencontext}} ) {
57	<	if ( defined ${$self->{labelhash}}{$newkey."_".$context} ) {
58	<	next block1;
59	<	}
60	<	#               print "Setting ".$newkey."_".$context." = 'none'\n";
61	<	${$self->{labelhash}}{$newkey."_".$context}='none';
62	<	}
63	<	}
64	<
40	>	# add a default groupchecker
41	>	use Utilities::GroupChecker;
42	>	$self->{groupchecker}=GroupChecker->new();
43	>	$self->{groupchecker}->include("all");
44	>
45	>	# Add a default TagContainer
46	>	use Utilities::TagContainer;
47	>	$self->{tagcontainer}=TagContainer->new();
48	>
49	>	}
50
51	<	foreach $key ( %$self->{labelhash} ) {
52	<	${$self->{ContextHash}}{$key} = 0;
53	<	}
54	<	$self->{InTag}="none";
55	<	$taglabel="";
71	<	$self->{tagblock}=[];
72	<	@{$self->{lastcon}}= qw(none);
51	>	sub usetags {
52	>	my $self=shift;
53	>	my $tagcontainer=shift;
54	>
55	>	$self->{tagcontainer}=$tagcontainer;
56		}
57
58	+	sub usegroupchecker {
59	+	my $self=shift;
60	+	my $ref=shift;
61	+
62	+	$self->{groupchecker}=$ref;
63	+	}
64
65		sub parse {
66		my $self=shift;
67	<	my $mykey="";
79	<	my $key;
80	<	my $word;
81	<	my $filein="";
67	>	my $char;
68		$self->{linecount}=0;
69	+	$self->_resetvars();
70	+
71	+	# Open the file
72		use FileHandle;
73		my $filehandle=FileHandle->new();
74		open( $filehandle , "$self->{filename}" )
75		or carp "Switcher: Cannot open $self->{filename} $! \n";
76	+
77	+	# Start file processing
78		while ( <$filehandle> ) {
88	–	if ( $self->{Strict_no_cr} eq 'yes' ) {
89	–	chomp;
90	–	}
91	–	@{$self->{words}}=split /\b/;
79		$self->{linecount}++;
80	<	WHILELOOP: while ( ($word=shift @{$self->{words}}) ne "" ) {
81	<	#       print $word." --- Word\n";
82	<	if  ( $word=~/(>)(<.*)/ ) {
83	<	unshift @{$self->{words}}, $2;
84	<	$word=$1;
85	<	}
99	<	#test against opencontext
100	<	foreach $mykey ( keys  ( %{$self->{opencontext}}) ) {
101	<	if ( $word=~/$mykey/i ) {
102	<	# Send current tagblock (if its not empty)
103	<	# to the Lastest Context Routine
104	<	$self->_closeprevious();
105	<	# Now carry on the parse
106	<	$self->{InTag}=${$self->{opencontext}}{$mykey};
107	<	$#{$self->{tagblock}}=-1;
108	<	next WHILELOOP;
109	<	}
110	<	}
111	<	#test against closed context
112	<	foreach $key ( keys %{$self->{closecontext}} ) {
113	<	if ( $word=~/$key/i ) {
114	<	if ( $self->{InTag}=~/${$self->{closecontext}}{$key}/ ) {
115	<	$temp=(shift @{$self->{tagblock}});
116	<	$temp=~tr[A-Z][a-z];
117	<	$rtname=($temp)."_".$self->{InTag};
118	<	$self->{InTag}="none";
119	<	# Do we call the tag init routine?
120	<	if ( ( defined ( ${$self->{labelhash}}{$rtname} )) &&
121	<	( ! ( ${$self->{labelhash}}{$rtname}=~/none/i )) ) {
122	<	&{${$self->{labelhash}}{$rtname}}( $temp,
123	<	@{$self->{tagblock}});
124	<	}
125	<	$self->_flipcontext($temp);
126	<	$#{$self->{tagblock}}= -1;
127	<	next WHILELOOP;
128	<	}
129	<	else {
130	<	die "Unmatched \"$key\" on line $self->{linecount}"
131	<	if $self->{InTag} eq "none";
132	<	die "Error: Wrong closure \"$key\" on line $self->{linecount}";
133	<	}
134	<	}
135	<	}
136	<	push @{$self->{tagblock}}, $word;
137	<	} #end word while
138	<	} #end fileglob while
139	<	$self->_closeprevious();
80	>	$self->{currentline}=$_;
81	>	$self->{stringpos}=0;
82	>	while ( ($char=$self->_nextchar()) ne "" ) {
83	>	$self->_checkchar($char);
84	>	} # end char while
85	>	} # End String while loop
86		close $filehandle;
87		}
88
89	<	sub context ($key) {
89	>	sub checkparam($name, $key) {
90	>	my $self=shift;
91	>	my $name=shift;
92	>	my $key=shift;
93	>
94	>	if ( ! defined $self->{tagvar}{$key} ) {
95	>	print "Switcher: Badly formed $name tag -".
96	>	" undefined $key parameter\n";
97	>	exit 1;
98	>	}
99	>	}
100	>
101	>	#
102	>	# return the current line number
103	>	#
104	>	sub line {
105		my $self=shift;
106	<	my $key=shift;
107	<	$key=~tr[A-Z][a-z];
108	<	return ( ${$self->{ContextHash}}{$key} );
109	<	}
110	<
111	<
112	<	# convert array of value=constants to a hash
113	<	# returns reference to the array
114	<	sub SetupValueHash(reftoarray) {
115	<	my $self=shift;
116	<	my $arrayref=shift;
117	<	my $side="r";
118	<	my $key='';
119	<	my $thiskey;
120	<	my $wordto="";
121	<	my $word;
122	<	my $quotes=0;
123	<	local $varhash;
124	<
125	<	$varhash = {};
126	<	foreach $word ( @$arrayref ) {
127	<	chomp;
128	<	if ( $word=~/=/) {
129	<	$side="l";
130	<	if ( $word=~s/^=// ) {
131	<	unshift @$arrayref, $word;
132	<	}
133	<	if ( $word=~s/^.*=// ) {
134	<	($thiskey=$word)=~tr[A-Z][a-z]; #keys all lower case
135	<	$key=$key.$thiskey;
136	<	}
137	<	next;
138	<	}
139	<	if ( $word=~/\"/ ) {
140	<	$quotes=  ( ! $quotes);
141	<	if ( $word=~s/^"// ) {
142	<	unshift @$arrayref, $word;
143	<	}
144	<	next;
145	<	}
146	<	if ( ( $word=~/\s/ ) && ( ! $quotes) ) {
147	<	$side="r";
148	<	if ( $key=~/./) {
149	<	$$varhash{$key}=$wordto;
150	<	}
151	<	$key='';
152	<	$wordto="";
153	<	next;
154	<	}
155	<	if ( $side=~/r/) {
156	<	($thiskey=$word)=~tr[A-Z][a-z]; #keys all lower case
157	<	$key=$key.$thiskey;
158	<	}
159	<	else {
160	<	$wordto=$wordto.$word;
161	<	}
162	<	}
163	<	if ( $side=~/l/ ) { $$varhash{$key}=$wordto; }
164	<	return $varhash;
165	<	}
166	<
167	<	sub _flipcontext(Hashkey) {
168	<	my $self=shift;
169	<	my $key = shift;
170	<	${$self->{ContextHash}}{$key}=(! ${$self->{ContextHash}}{$key});
171	<	# sort out the context stack
172	<	if ( ! ${$self->{ContextHash}}{$key} ) {
173	<	pop @{$self->{lastcon}};
174	<	#      print "** poping ".$key."\n";
106	>	return $self->{linecount};
107	>	}
108	>	# --------------- Utility routines ----------------------------
109	>
110	>	#
111	>	# Some initialisation of test suites
112	>	#
113	>	sub _resetvars {
114	>	my $self=shift;
115	>	$self->{quotes}=0;
116	>	$self->{lastlabel}="";
117	>	$self->{textcontext}='none';
118	>	$self->{tagcontext}="text";
119	>	$self->_resetstore();
120	>	}
121	>
122	>	#
123	>	# Check for control characters
124	>	#
125	>	sub _checkchar {
126	>	my $self=shift;
127	>	my $char=shift;
128	>	my $string;
129	>
130	>	# ---- In a tag
131	>	if ( $self->{tagcontext}=~/tag/ ) {
132	>	if ( ! $self->_quotetest($char) ) {
133	>	if ( ! $self->_labeltest($char) ) {
134	>	if ( $char eq ">") { $self->_closetag(); }
135	>	else { $self->_putstore($char); }
136	>	}
137	>	}
138	>	}
139	>	# ------ Outside a tag
140	>	else {
141	>	if ( $char eq "<") { $self->_opentag() }
142	>	else { $self->_putstore($char) }
143	>	}
144	>	}
145	>
146	>
147	>	#
148	>	# Return the next character from the current string buffer
149	>	#
150	>	sub _nextchar() {
151	>	my $self=shift;
152	>	my $char;
153	>	$char=substr($self->{currentline},$self->{stringpos}++,1);
154	>	#       print "Debug : Fetching character $char\n";
155	>	return $char;
156	>	}
157	>
158	>	sub _opentag {
159	>	my $self=shift;
160	>	my $char;
161	>
162	>	# Close the last text segment
163	>	$self->_calltag($self->{textcontext}, $self->{textcontext},
164	>	$self->_getstore());
165	>	$self->_resetstore();
166	>	$self->_resetlabels();
167	>
168	>	# Do we have an opening or closing tag?
169	>	if ( ($char=$self->_nextchar()) eq "/" ) { #we have a closing tag
170	>	$self->{tagcontext}="endtag";
171	>	}
172	>	else { # an opening tag
173	>	$self->{tagcontext}="starttag";
174	>	$self->_checkchar($char);
175	>	}
176	>	#print "\nDebug : Opening $self->{tagcontext}\n";
177	>	}
178	>
179	>	#
180	>	# Close a tag
181	>	#
182	>	sub _closetag {
183	>	my $self=shift;
184	>	my $tagroutine;
185	>
186	>	# -- Finish off any labels/get tagname
187	>	$self->_closelabel();
188	>
189	>	# -- Call the associated tag function if appropriate
190	>	$tagroutine=$self->{tagname}."_".$self->{tagcontext};
191	>	$self->_calltag($tagroutine, $self->{tagname},
192	>	$self->{tagvar});
193	>	#print "\nDebug : Closing Tag $tagroutine\n";
194	>
195	>	# -- Now make sure the text context is set for calling routines to
196	>	# -- deal with text portions outside of tags
197	>	if ( $self->{tagcontext} eq "starttag" ) {
198	>	push @{$self->{textstack}} , $self->{textcontext};
199	>	$self->{textcontext}=$self->{tagname};
200		}
201		else {
202	<	#       print "** pushing ".$key."\n";
203	<	push @{$self->{lastcon}}, $key;
202	>	if ( $#{$self->{textstack}} > -1 ) {
203	>	if ( $self->{textcontext} eq $self->{tagname} ) {
204	>	$self->{textcontext}=pop @{$self->{textstack}};
205	>	}
206	>	else { #The tag we are closing is not the last one so
207	>	# we keep our current context.
208	>	$self->_removefromstack($self->{tagname},$self->{textstack});
209	>	}
210	>
211	>	}
212	>	else { # more close tags than open ones
213	>	print "Warning : Unmatched </...> tag on line ".
214	>	$self->line()."\n";
215	>	}
216		}
217	+	# Reset context back to text
218	+	$self->{tagcontext}="text";
219		}
220	<	sub _closeprevious {
221	<	my $self=shift;
222	<	if ( $#{$self->{tagblock}} != -1  ) {
223	<	if (( defined
224	<	${$self->{labelhash}}{${$self->{lastcon}}[$#{$self->{lastcon}}]} ) &&
225	<	( ! ( ${$self->{labelhash}}{${$self->{lastcon}}[$#{$self->{lastcon}}]}
226	<	=~/none/i )) ) {
227	<	&{ ${$self->{labelhash}}{${$self->{lastcon}}[$#{$self->{lastcon}}]}}(
228	<	${$self->{lastcon}}[$#{$self->{lastcon}}], @{$self->{tagblock}});
229	<	}
230	<	}
220	>
221	>	sub _calltag {
222	>	my $self=shift;
223	>	my $tagroutine=shift;
224	>	my @args=@_;
225	>	my $rt;
226	>
227	>	if ( $self->{groupchecker}->status() ||
228	>	( $self->{tagcontainer}->inquiregroup($tagroutine)) ) {
229	>	$rt=$self->{tagcontainer}->getroutine($tagroutine);
230	>	if ( $rt ne "" ) {
231	>	&{$rt}( $self->{allw},@_);
232	>	}
233	>	}
234		}
235
236	<	sub checkparam($hash, $name, $key) {
236	>	sub _removefromstack {
237		my $self=shift;
238	<	my $hashref=shift;
239	<	my $name=shift;
240	<	my $key=shift;
238	>	my $name=shift;
239	>	my $stack=shift;
240	>	my $this;
241	>
242	>	undef @tempstack;
243	>	#print "In  ----".$#{$stack};
244	>	# Keep popping until we find our string
245	>	while ( ($this=(pop @{$stack})) ne "$name") {
246	>	push @tempstack, $this;
247	>	if ( $#{$stack} < 0 ) { last; }
248	>	}
249	>	# Now put them back
250	>	while ( $#tempstack>-1) {
251	>	$this=pop @tempstack;
252	>	push @{$stack}, $this;
253	>	}
254	>	#print " Out ----".$#{$stack};
255	>	}
256
257	<	if ( ! defined $$hashref{$key} ) {
258	<	print "BootParser: Badly formed $name tag -".
259	<	" undefined $key parameter\n";
260	<	exit 1;
257	>	#
258	>	# Quote handling
259	>	#
260	>
261	>	sub _quotetest {
262	>	my $self=shift;
263	>	my $char=shift;
264	>
265	>	# --- Are we already in a quote context?
266	>	if ( $self->{quotes} ) {
267	>	if ( $char eq $self->{openquote} ) {
268	>	$self->{quotes}=0;
269	>	}
270	>	else {
271	>	$self->_putstore($char);
272	>	}
273	>	}
274	>	# --- Unquoted Context
275	>	elsif ( (($char eq "\"") || ($char eq "\'") || ($char eq "\`")) ) {
276	>	$self->{quotes}=1;
277	>	$self->{openquote}=$char;
278	>	}
279	>	else { return 0; } # Return zero if not quoted
280	>	return 1;          # 1 otherwise
281	>	}
282	>
283	>	#
284	>	# Label handling
285	>	#
286	>	sub _labeltest {
287	>	my $self=shift;
288	>	my $char=shift;
289	>
290	>	# Spaces are markers between tags
291	>	if ( ($char eq " ") || ($char eq "\n") || ($char eq "\t")) {
292	>	$self->_closelabel();
293	>	}
294	>	# Check for a change in label status
295	>	elsif ( $char eq "=" ) {
296	>	$self->{lastlabel}=$self->_getstore();
297	>	$self->_resetstore();
298		}
299	<	$$hashref{$key}=~s/["']//;
299	>	else {
300	>	return 0;
301	>	}
302	>	return 1;
303	>	}
304	>
305	>	sub _resetlabels {
306	>	my $self=shift;
307	>	undef $self->{tagvar};
308	>	}
309	>
310	>	sub _closelabel {
311	>	my $self=shift;
312	>
313	>	# Do we have a label name?
314	>	if ( $self->{lastlabel} ne "" ) {
315	>	$self->{tagvar}{$self->{lastlabel}}=$self->_getstore();
316	>	$self->{lastlabel}="";
317	>	}
318	>	elsif ( $self->_getstore() ne "") {
319	>	#Then it must be the tag name
320	>	($self->{tagname}=$self->_getstore())=~tr/A-Z/a-z/;
321	>	}
322	>	$self->_resetstore();
323	>	}
324	>
325	>	#
326	>	# Character Store management interface
327	>	#
328	>	sub _putstore() {
329	>	my $self=shift;
330	>	my $char=shift;
331	>
332	>	$self->{stringbuff}=$self->{stringbuff}.$char;
333		}
334
335	+	sub _getstore() {
336	+	my $self=shift;
337	+
338	+	return $self->{stringbuff};
339	+	}
340	+
341	+	sub _resetstore {
342	+	my $self=shift;
343	+	$self->{stringbuff}="";
344	+	}

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines