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

Diff Legend

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