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.3 by williamc, Fri Mar 19 14:08:25 1999 UTC vs.
Revision 1.8 by williamc, Fri Jun 18 10:55:44 1999 UTC

#	Line 4 | Line 4
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 5.001;
10	–	require Exporter;
21		use Carp;
12	–	@ISA    = qw(Exporter);
22
23		sub new {
24		my $class=shift;
16	–	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;
26	–	my $inlabelhash=shift;
27	–	my $newkey;
28	–	my $key;
38		$self->{filename}=shift;
30	–	$self->{labelhash}={};
31	–	$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'
43	<	);
44	<
45	<	# Fill in the blanks in the user supplied hash
46	<	if ( ! ( defined $$inlabelhash{'none'} )) { # check for none target
47	<	$$inlabelhash{'none'}='none';
48	<	}
49	<	block1: foreach $key ( keys %$inlabelhash ) {
50	<	($newkey=$key)=~tr[A-Z][a-z];
51	<	${$self->{labelhash}}{$newkey}=$$inlabelhash{$key};
52	<	foreach $context ( values %{$self->{opencontext}} ) {
53	<	next block1 if $newkey=~/$context/i;
54	<	}
55	<	foreach $context ( values %{$self->{opencontext}} ) {
56	<	if ( defined ${$self->{labelhash}}{$newkey."_".$context} ) {
57	<	next block1;
58	<	}
59	<	#               print "Setting ".$newkey."_".$context." = 'none'\n";
60	<	${$self->{labelhash}}{$newkey."_".$context}='none';
61	<	}
62	<	}
63	<
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="";
70	<	$self->{tagblock}=[];
71	<	@{$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}=$shift;
63	+	}
64
65		sub parse {
66		my $self=shift;
67	<	my $mykey="";
78	<	my $key;
79	<	my $word;
80	<	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> ) {
87	–	if ( $self->{Strict_no_cr} eq 'yes' ) {
88	–	chomp;
89	–	}
90	–	@{$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	<	}
98	<	#test against opencontext
99	<	foreach $mykey ( keys  ( %{$self->{opencontext}}) ) {
100	<	if ( $word=~/$mykey/i ) {
101	<	# Send current tagblock (if its not empty)
102	<	# to the Lastest Context Routine
103	<	$self->_closeprevious();
104	<	# Now carry on the parse
105	<	$self->{InTag}=${$self->{opencontext}}{$mykey};
106	<	$#{$self->{tagblock}}=-1;
107	<	next WHILELOOP;
108	<	}
109	<	}
110	<	#test against closed context
111	<	foreach $key ( keys %{$self->{closecontext}} ) {
112	<	if ( $word=~/$key/i ) {
113	<	if ( $self->{InTag}=~/${$self->{closecontext}}{$key}/ ) {
114	<	$temp=(shift @{$self->{tagblock}});
115	<	$temp=~tr[A-Z][a-z];
116	<	$rtname=($temp)."_".$self->{InTag};
117	<	$self->{InTag}="none";
118	<	# Do we call the tag init routine?
119	<	if ( ( defined ( ${$self->{labelhash}}{$rtname} )) &&
120	<	( ! ( ${$self->{labelhash}}{$rtname}=~/none/i )) ) {
121	<	&{${$self->{labelhash}}{$rtname}}( $temp,
122	<	@{$self->{tagblock}});
123	<	}
124	<	$self->_flipcontext($temp);
125	<	$#{$self->{tagblock}}= -1;
126	<	next WHILELOOP;
127	<	}
128	<	else {
129	<	die "Unmatched \"$key\" on line $self->{linecount}"
130	<	if $self->{InTag} eq "none";
131	<	die "Error: Wrong closure \"$key\" on line $self->{linecount}";
132	<	}
133	<	}
134	<	}
135	<	push @{$self->{tagblock}}, $word;
136	<	} #end word while
137	<	} #end fileglob while
138	<	$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	>	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 $key=shift;
185	<	$key=~tr[A-Z][a-z];
186	<	return ( ${$self->{ContextHash}}{$key} );
187	<	}
188	<
189	<
190	<	# convert array of value=constants to a hash
191	<	# returns reference to the array
192	<	sub SetupValueHash(reftoarray) {
193	<	my $self=shift;
194	<	my $arrayref=shift;
195	<	my $side="r";
196	<	my $key='';
197	<	my $thiskey;
198	<	my $wordto="";
199	<	my $word;
160	<	my $quotes=0;
161	<	local $varhash;
162	<
163	<	$varhash = {};
164	<	foreach $word ( @$arrayref ) {
165	<	chomp;
166	<	if ( $word=~/=/) {
167	<	$side="l";
168	<	if ( $word=~s/^=// ) {
169	<	unshift @$arrayref, $word;
170	<	}
171	<	if ( $word=~s/^.*=// ) {
172	<	($thiskey=$word)=~tr[A-Z][a-z]; #keys all lower case
173	<	$key=$key.$thiskey;
174	<	}
175	<	next;
176	<	}
177	<	if ( $word=~/\"/ ) {
178	<	$quotes=  ( ! $quotes);
179	<	if ( $word=~s/^"// ) {
180	<	unshift @$arrayref, $word;
181	<	}
182	<	next;
183	<	}
184	<	if ( ( $word=~/\s/ ) && ( ! $quotes) ) {
185	<	$side="r";
186	<	if ( $key=~/./) {
187	<	$$varhash{$key}=$wordto;
188	<	}
189	<	$key='';
190	<	$wordto="";
191	<	next;
192	<	}
193	<	if ( $side=~/r/) {
194	<	($thiskey=$word)=~tr[A-Z][a-z]; #keys all lower case
195	<	$key=$key.$thiskey;
196	<	}
197	<	else {
198	<	$wordto=$wordto.$word;
199	<	}
200	<	}
201	<	if ( $side=~/l/ ) { $$varhash{$key}=$wordto; }
202	<	return $varhash;
203	<	}
204	<
205	<	sub _flipcontext(Hashkey) {
206	<	my $self=shift;
207	<	my $key = shift;
208	<	${$self->{ContextHash}}{$key}=(! ${$self->{ContextHash}}{$key});
209	<	# sort out the context stack
210	<	if ( ! ${$self->{ContextHash}}{$key} ) {
211	<	pop @{$self->{lastcon}};
212	<	#      print "** poping ".$key."\n";
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	>	$rt=$self->{tagcontainer}->getroutine($tagroutine);
229	>	if ( $rt ne "" ) {
230	>	&{$rt}( $self->{allw},@_);
231	>	}
232	>	}
233		}
234
235	<	sub checkparam($hash, $name, $key) {
235	>	sub _removefromstack {
236		my $self=shift;
237	<	my $hashref=shift;
238	<	my $name=shift;
239	<	my $key=shift;
237	>	my $name=shift;
238	>	my $stack=shift;
239	>	my $this;
240	>
241	>	undef @tempstack;
242	>	#print "In  ----".$#{$stack};
243	>	# Keep popping until we find our string
244	>	while ( ($this=(pop @{$stack})) ne "$name") {
245	>	push @tempstack, $this;
246	>	if ( $#{$stack} < 0 ) { last; }
247	>	}
248	>	# Now put them back
249	>	while ( $#tempstack>-1) {
250	>	$this=pop @tempstack;
251	>	push @{$stack}, $this;
252	>	}
253	>	#print " Out ----".$#{$stack};
254	>	}
255
256	<	if ( ! defined $$hashref{$key} ) {
257	<	print "Switcher: Badly formed $name tag -".
258	<	" undefined $key parameter\n";
259	<	exit 1;
256	>	#
257	>	# Quote handling
258	>	#
259	>
260	>	sub _quotetest {
261	>	my $self=shift;
262	>	my $char=shift;
263	>
264	>	# --- Are we already in a quote context?
265	>	if ( $self->{quotes} ) {
266	>	if ( $char eq $self->{openquote} ) {
267	>	$self->{quotes}=0;
268	>	}
269	>	else {
270	>	$self->_putstore($char);
271	>	}
272		}
273	<	$$hashref{$key}=~s/["']//;
273	>	# --- Unquoted Context
274	>	elsif ( (($char eq "\"") || ($char eq "\'") || ($char eq "\`")) ) {
275	>	$self->{quotes}=1;
276	>	$self->{openquote}=$char;
277	>	}
278	>	else { return 0; } # Return zero if not quoted
279	>	return 1;          # 1 otherwise
280		}
281
282	+	#
283	+	# Label handling
284	+	#
285	+	sub _labeltest {
286	+	my $self=shift;
287	+	my $char=shift;
288	+
289	+	# Spaces are markers between tags
290	+	if ( ($char eq " ") || ($char eq "\n") || ($char eq "\t")) {
291	+	$self->_closelabel();
292	+	}
293	+	# Check for a change in label status
294	+	elsif ( $char eq "=" ) {
295	+	$self->{lastlabel}=$self->_getstore();
296	+	$self->_resetstore();
297	+	}
298	+	else {
299	+	return 0;
300	+	}
301	+	return 1;
302	+	}
303	+
304	+	sub _resetlabels {
305	+	my $self=shift;
306	+	undef $self->{tagvar};
307	+	}
308	+
309	+	sub _closelabel {
310	+	my $self=shift;
311	+
312	+	# Do we have a label name?
313	+	if ( $self->{lastlabel} ne "" ) {
314	+	$self->{tagvar}{$self->{lastlabel}}=$self->_getstore();
315	+	$self->{lastlabel}="";
316	+	}
317	+	elsif ( $self->_getstore() ne "") {
318	+	#Then it must be the tag name
319	+	$self->{tagname}=$self->_getstore();
320	+	}
321	+	$self->_resetstore();
322	+	}
323	+
324	+	#
325	+	# Character Store management interface
326	+	#
327	+	sub _putstore() {
328	+	my $self=shift;
329	+	my $char=shift;
330	+
331	+	$self->{stringbuff}=$self->{stringbuff}.$char;
332	+	}
333	+
334	+	sub _getstore() {
335	+	my $self=shift;
336	+
337	+	return $self->{stringbuff};
338	+	}
339	+
340	+	sub _resetstore {
341	+	my $self=shift;
342	+	$self->{stringbuff}="";
343	+	}

Diff Legend

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