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.4 by williamc, Mon Jun 7 15:02:57 1999 UTC vs.
Revision 1.9 by williamc, Thu Jul 1 12:28:09 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;
28	–	my $inlabelhash=shift;
29	–	my $newkey;
30	–	my $key;
38		$self->{filename}=shift;
32	–	$self->{labelhash}={};
33	–	$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'
45	<	);
46	<
47	<	# Fill in the blanks in the user supplied hash
48	<	if ( ! ( defined $$inlabelhash{'none'} )) { # check for none target
49	<	$$inlabelhash{'none'}='none';
50	<	}
51	<	block1: foreach $key ( keys %$inlabelhash ) {
52	<	($newkey=$key)=~tr[A-Z][a-z];
53	<	${$self->{labelhash}}{$newkey}=$$inlabelhash{$key};
54	<	foreach $context ( values %{$self->{opencontext}} ) {
55	<	next block1 if $newkey=~/$context/i;
56	<	}
57	<	foreach $context ( values %{$self->{opencontext}} ) {
58	<	if ( defined ${$self->{labelhash}}{$newkey."_".$context} ) {
59	<	next block1;
60	<	}
61	<	#               print "Setting ".$newkey."_".$context." = 'none'\n";
62	<	${$self->{labelhash}}{$newkey."_".$context}='none';
63	<	}
64	<	}
65	<
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="";
72	<	$self->{tagblock}=[];
73	<	@{$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="";
80	<	my $key;
81	<	my $word;
82	<	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> ) {
89	–	if ( $self->{Strict_no_cr} eq 'yes' ) {
90	–	chomp;
91	–	}
92	–	@{$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	<	}
100	<	#test against opencontext
101	<	foreach $mykey ( keys  ( %{$self->{opencontext}}) ) {
102	<	if ( $word=~/$mykey/i ) {
103	<	# Send current tagblock (if its not empty)
104	<	# to the Lastest Context Routine
105	<	$self->_closeprevious();
106	<	# Now carry on the parse
107	<	$self->{InTag}=${$self->{opencontext}}{$mykey};
108	<	$#{$self->{tagblock}}=-1;
109	<	next WHILELOOP;
110	<	}
111	<	}
112	<	#test against closed context
113	<	foreach $key ( keys %{$self->{closecontext}} ) {
114	<	if ( $word=~/$key/i ) {
115	<	if ( $self->{InTag}=~/${$self->{closecontext}}{$key}/ ) {
116	<	$temp=(shift @{$self->{tagblock}});
117	<	$temp=~tr[A-Z][a-z];
118	<	$rtname=($temp)."_".$self->{InTag};
119	<	$self->{InTag}="none";
120	<	# Do we call the tag init routine?
121	<	if ( ( defined ( ${$self->{labelhash}}{$rtname} )) &&
122	<	( ! ( ${$self->{labelhash}}{$rtname}=~/none/i )) ) {
123	<	&{${$self->{labelhash}}{$rtname}}( $self->{allw},
124	<	$temp, @{$self->{tagblock}});
125	<	}
126	<	$self->_flipcontext($temp);
127	<	$#{$self->{tagblock}}= -1;
128	<	next WHILELOOP;
129	<	}
130	<	else {
131	<	die "Unmatched \"$key\" on line $self->{linecount}"
132	<	if $self->{InTag} eq "none";
133	<	die "Error: Wrong closure \"$key\" on line $self->{linecount}";
134	<	}
135	<	}
136	<	}
137	<	push @{$self->{tagblock}}, $word;
138	<	} #end word while
139	<	} #end fileglob while
140	<	$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) {
145	<	my $self=shift;
146	<	my $key=shift;
147	<	$key=~tr[A-Z][a-z];
148	<	return ( ${$self->{ContextHash}}{$key} );
149	<	}
150	<
151	<
152	<	# convert array of value=constants to a hash
153	<	# returns reference to the array
154	<	sub SetupValueHash(reftoarray) {
155	<	my $self=shift;
156	<	my $arrayref=shift;
157	<	my $side="r";
158	<	my $key='';
159	<	my $thiskey;
160	<	my $wordto="";
161	<	my $word;
162	<	my $quotes=0;
163	<	local $varhash;
164	<
165	<	$varhash = {};
166	<	foreach $word ( @$arrayref ) {
167	<	chomp;
168	<	if ( $word=~/=/) {
169	<	$side="l";
170	<	if ( $word=~s/^=// ) {
171	<	unshift @$arrayref, $word;
172	<	}
173	<	if ( $word=~s/^.*=// ) {
174	<	($thiskey=$word)=~tr[A-Z][a-z]; #keys all lower case
175	<	$key=$key.$thiskey;
176	<	}
177	<	next;
178	<	}
179	<	if ( $word=~/\"/ ) {
180	<	$quotes=  ( ! $quotes);
181	<	if ( $word=~s/^"// ) {
182	<	unshift @$arrayref, $word;
183	<	}
184	<	next;
185	<	}
186	<	if ( ( $word=~/\s/ ) && ( ! $quotes) ) {
187	<	$side="r";
188	<	if ( $key=~/./) {
189	<	$$varhash{$key}=$wordto;
190	<	}
191	<	$key='';
192	<	$wordto="";
193	<	next;
194	<	}
195	<	if ( $side=~/r/) {
196	<	($thiskey=$word)=~tr[A-Z][a-z]; #keys all lower case
197	<	$key=$key.$thiskey;
198	<	}
199	<	else {
200	<	$wordto=$wordto.$word;
201	<	}
202	<	}
203	<	if ( $side=~/l/ ) { $$varhash{$key}=$wordto; }
204	<	return $varhash;
205	<	}
206	<
207	<	sub _flipcontext(Hashkey) {
208	<	my $self=shift;
209	<	my $key = shift;
210	<	${$self->{ContextHash}}{$key}=(! ${$self->{ContextHash}}{$key});
211	<	# sort out the context stack
212	<	if ( ! ${$self->{ContextHash}}{$key} ) {
213	<	pop @{$self->{lastcon}};
214	<	#      print "** poping ".$key."\n";
215	<	}
216	<	else {
217	<	#       print "** pushing ".$key."\n";
218	<	push @{$self->{lastcon}}, $key;
219	<	}
220	<	}
221	<	sub _closeprevious {
222	<	my $self=shift;
223	<	if ( $#{$self->{tagblock}} != -1  ) {
224	<	if (( defined
225	<	${$self->{labelhash}}{${$self->{lastcon}}[$#{$self->{lastcon}}]} ) &&
226	<	( ! ( ${$self->{labelhash}}{${$self->{lastcon}}[$#{$self->{lastcon}}]}
227	<	=~/none/i )) ) {
228	<	&{ ${$self->{labelhash}}{${$self->{lastcon}}[$#{$self->{lastcon}}]}}(
229	<	$self->{allw}, ${$self->{lastcon}}[$#{$self->{lastcon}}], @{$self->{tagblock}});
230	<	}
231	<	}
232	<	}
233	<
234	<	sub checkparam($hash, $name, $key) {
89	>	sub checkparam($name, $key) {
90		my $self=shift;
236	–	my $hashref=shift;
91		my $name=shift;
92		my $key=shift;
93
94	<	if ( ! defined $$hashref{$key} ) {
94	>	if ( ! defined $self->{tagvar}{$key} ) {
95		print "Switcher: Badly formed $name tag -".
96		" undefined $key parameter\n";
97		exit 1;
98		}
245	–	$$hashref{$key}=~s/["']//;
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 $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	+	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	+
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 _removefromstack {
237	+	my $self=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	+	#
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	+	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