src/Utilities/Switcher.pm

# Switcher Module
#
# Look for elements given in input has in a string
# If found then call a routine name with the same name
# Implemented as an object to maintain state info between each line
# processed.
# Interface
# ---------
# new(hash,file,objectref,[groupchecker]) : A new object requires a hash of 
#                                           labels->routine references
#                                           filename of pfile to parse
#                                           objectref->of the methods associated#                                           with the labels
#                                           groupchecker for control of calling
#                                           tag groups (on/off)
# parse()                   : Parse the file                            
# checkparam($name,$par)    : Exit with an error message if parameter 
#                             is undefined in tag $name
# line()                    : return the current line number of the parse

package Switcher;
require 5.001;
use Carp;

sub new { 
        my $class=shift;
        my $hash=shift;
        my $file=shift;
        my $objectname=shift;
        my $groupchecker=shift;

        my $self = {};
        $self->{allw}=$objectname;
        bless $self, $class;
        $self->_initialise($hash,$file,$groupchecker);
        $self->_resetvars();
        return $self;
}

sub _initialise (hash1) {
        my $self=shift;
        my $inlabelhash=shift;
        $self->{filename}=shift;
        my $groupchecker=shift;

        my $newkey;
        my $key;        
        $self->{labelhash}={};
        $self->{Strict_no_cr}='yes'; # set to 'no' to retain \n's 

        # Fill in the blanks in the user supplied hash
        if ( ! ( defined $$inlabelhash{'none'} )) { # check for none target 
                $$inlabelhash{'none'}='none';
        }
        block1: foreach $key ( keys %$inlabelhash ) {
          ($newkey=$key)=~tr[A-Z][a-z];
          ${$self->{labelhash}}{$newkey}=$$inlabelhash{$key};
          foreach $context ( values %{$self->{opencontext}} ) {
                next block1 if $newkey=~/$context/i;
          }
          foreach $context ( values %{$self->{opencontext}} ) {
                if ( defined ${$self->{labelhash}}{$newkey."_".$context} ) {
                  next block1;
                }
#               print "Setting ".$newkey."_".$context." = 'none'\n";
                ${$self->{labelhash}}{$newkey."_".$context}='none';
          }
        }
        

        foreach $key ( %$self->{labelhash} ) {
                ${$self->{ContextHash}}{$key} = 0;
        }
        $self->{InTag}="none";
        $taglabel="";
        $self->{tagblock}=[];
        @{$self->{lastcon}}= qw(none);

        # Add a groupchecker
        if ( $groupchecker eq "" ) {
          use Utilities::GroupChecker;
          $self->{groupchecker}=GroupChecker->new();
          $self->{groupchecker}->include("all");
        }
        else {
          $self->{groupchecker}=$groupchecker;
        }
}


sub parse {
        my $self=shift;
        my $char;
        $self->{linecount}=0;

        # Open the file
        use FileHandle;
        my $filehandle=FileHandle->new();
        open( $filehandle , "$self->{filename}" ) 
                or carp "Switcher: Cannot open $self->{filename} $! \n";

        # Start file processing
        while ( <$filehandle> ) {
         $self->{linecount}++;
         $self->{currentline}=$_;
         $self->{stringpos}=0;
         while ( ($char=$self->_nextchar()) ne "" ) {
           $self->_checkchar($char);
         } # end char while
        } # End String while loop
        close $filehandle;
}

sub checkparam($name, $key) {
        my $self=shift;
        my $name=shift;
        my $key=shift;

        if ( ! defined $self->{tagvar}{$key} ) {
           print "Switcher: Badly formed $name tag -".
                        " undefined $key parameter\n";
           exit 1;
        }
}

#
# return the current line number
#
sub line {
        my $self=shift;
        return $self->{linecount};
}
# --------------- Utility routines ----------------------------
 
#
# Some initialisation of test suites
#
sub _resetvars {
        my $self=shift;
        $self->{quotes}=0;
        $self->{lastlabel}="";
        $self->{textcontext}='none';
        $self->{tagcontext}="text";
        $self->_resetstore();
}

#
# Check for control characters
#
sub _checkchar {
        my $self=shift;
        my $char=shift;
        my $string;

        # ---- In a tag
        if ( $self->{tagcontext}=~/tag/ ) {
           if ( ! $self->_quotetest($char) ) {
            if ( ! $self->_labeltest($char) ) {
             if ( $char eq ">") { $self->_closetag(); }
             else { $self->_putstore($char); }
            }
           }  
        }
        # ------ Outside a tag
        else { 
           if ( $char eq "<") { $self->_opentag() }
           else { $self->_putstore($char) } 
        }
}


#
# Return the next character from the current string buffer
#
sub _nextchar() {
        my $self=shift;
        my $char;
        $char=substr($self->{currentline},$self->{stringpos}++,1);
#       print "Debug : Fetching character $char\n";
        return $char;
}

sub _opentag {
        my $self=shift;
        my $char;

        # Close the last text segment
        $self->_calltag($self->{textcontext}, $self->{textcontext}, 
                                                        $self->_getstore());
        $self->_resetstore();
        $self->_resetlabels();

        # Do we have an opening or closing tag?
        if ( ($char=$self->_nextchar()) eq "/" ) { #we have a closing tag
          $self->{tagcontext}="endtag";
        }
        else { # an opening tag
          $self->{tagcontext}="starttag";
          $self->_checkchar($char);
        }
        #print "\nDebug : Opening $self->{tagcontext}\n";
}

#
# Close a tag
#
sub _closetag {
        my $self=shift;
        my $tagroutine;

        # -- Finish off any labels/get tagname
        $self->_closelabel();
        
        # -- Call the associated tag function if appropriate
        $tagroutine=$self->{tagname}."_".$self->{tagcontext};
        $self->_calltag($tagroutine, $self->{tagname}, 
                                                        $self->{tagvar});
        #print "\nDebug : Closing Tag $tagroutine\n";

        # -- Now make sure the text context is set for calling routines to
        # -- deal with text portions outside of tags
        if ( $self->{tagcontext} eq "starttag" ) {
          push @{$self->{textstack}} , $self->{textcontext};
          $self->{textcontext}=$self->{tagname};
        }
        else {
          if ( $#{$self->{textstack}} > -1 ) {
            if ( $self->{textcontext} eq $self->{tagname} ) {   
               $self->{textcontext}=pop @{$self->{textstack}};
            } 
            else { #The tag we are closing is not the last one so
                   # we keep our current context.
               $self->_removefromstack($self->{tagname},$self->{textstack});
            }

          }
          else { # more close tags than open ones
             print "Warning : Unmatched </...> tag on line ".
                                        $self->line()."\n";     
          }
        }
        # Reset context back to text
        $self->{tagcontext}="text";
}

sub _calltag {
        my $self=shift;
        my $tagroutine=shift;
        my @args=@_;

        if ( $self->{groupchecker}->status() ) {
             if ( ( exists $self->{labelhash}{$tagroutine})  &&
                ( $self->{labelhash}{$tagroutine}!~/none/i )
                ) {
                &{ ${$self->{labelhash}}{$tagroutine}} (
                        $self->{allw},@_);
               }
        }
}

sub _removefromstack {
        my $self=shift;
        my $name=shift;
        my $stack=shift;
        my $this;

        undef @tempstack;
        #print "In  ----".$#{$stack};
        # Keep popping until we find our string
        while ( ($this=(pop @{$stack})) ne "$name") {
          push @tempstack, $this; 
          if ( $#{$stack} < 0 ) { last; }
        }
        # Now put them back
        while ( $#tempstack>-1) {
          $this=pop @tempstack;
          push @{$stack}, $this;
        }
        #print " Out ----".$#{$stack};
}

#
# Quote handling
#

sub _quotetest {
        my $self=shift;
        my $char=shift;

        # --- Are we already in a quote context?
        if ( $self->{quotes} ) {
         if ( $char eq $self->{openquote} ) {
           $self->{quotes}=0;
         }
         else {
           $self->_putstore($char);
         }
        }
        # --- Unquoted Context
        elsif ( (($char eq "\"") || ($char eq "\'") || ($char eq "\`")) ) {
           $self->{quotes}=1;
           $self->{openquote}=$char;
        }
        else { return 0; } # Return zero if not quoted
        return 1;          # 1 otherwise
}

#
# Label handling
#
sub _labeltest {
        my $self=shift;
        my $char=shift;

        # Spaces are markers between tags
        if ( ($char eq " ") || ($char eq "\n") || ($char eq "\t")) {
          $self->_closelabel();
        }
        # Check for a change in label status
        elsif ( $char eq "=" ) {
                $self->{lastlabel}=$self->_getstore();
                $self->_resetstore();
        }
        else {
             return 0;
        }
        return 1;
}

sub _resetlabels {
        my $self=shift;
        undef $self->{tagvar};
}

sub _closelabel {
        my $self=shift;

        # Do we have a label name?
        if ( $self->{lastlabel} ne "" ) {
         $self->{tagvar}{$self->{lastlabel}}=$self->_getstore();
         $self->{lastlabel}="";
        }
        elsif ( $self->_getstore() ne "") { 
         #Then it must be the tag name
         $self->{tagname}=$self->_getstore();
        }
        $self->_resetstore();
}

#
# Character Store management interface
#
sub _putstore() {
        my $self=shift;
        my $char=shift;

        $self->{stringbuff}=$self->{stringbuff}.$char;
}

sub _getstore() {
        my $self=shift;

        return $self->{stringbuff};
}

sub _resetstore {
        my $self=shift;
        $self->{stringbuff}="";
}
Revision:	1.7
Committed:	Thu Jun 17 15:10:01 1999 UTC (25 years, 11 months ago) by williamc
Content type:	text/plain
Branch:	MAIN
Changes since 1.6:	+0 -10 lines
Log Message:	remove old fashined context routine - groupchecker now performs this function
#	User	Rev	Content
1	williamc	1.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	williamc	1.5	# 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	williamc	1.1
20			package Switcher;
21	williamc	1.2	require 5.001;
22	williamc	1.1	use Carp;
23
24			sub new {
25			my $class=shift;
26			my $hash=shift;
27			my $file=shift;
28	williamc	1.4	my $objectname=shift;
29	williamc	1.5	my $groupchecker=shift;
30
31	williamc	1.1	my $self = {};
32	williamc	1.4	$self->{allw}=$objectname;
33	williamc	1.1	bless $self, $class;
34	williamc	1.5	$self->_initialise($hash,$file,$groupchecker);
35			$self->_resetvars();
36	williamc	1.1	return $self;
37			}
38
39			sub _initialise (hash1) {
40			my $self=shift;
41			my $inlabelhash=shift;
42	williamc	1.5	$self->{filename}=shift;
43			my $groupchecker=shift;
44
45	williamc	1.1	my $newkey;
46			my $key;
47			$self->{labelhash}={};
48			$self->{Strict_no_cr}='yes'; # set to 'no' to retain \n's
49
50			# Fill in the blanks in the user supplied hash
51			if ( ! ( defined $$inlabelhash{'none'} )) { # check for none target
52			$$inlabelhash{'none'}='none';
53			}
54			block1: foreach $key ( keys %$inlabelhash ) {
55			($newkey=$key)=~tr[A-Z][a-z];
56			${$self->{labelhash}}{$newkey}=$$inlabelhash{$key};
57			foreach $context ( values %{$self->{opencontext}} ) {
58			next block1 if $newkey=~/$context/i;
59			}
60			foreach $context ( values %{$self->{opencontext}} ) {
61			if ( defined ${$self->{labelhash}}{$newkey."_".$context} ) {
62			next block1;
63			}
64			# print "Setting ".$newkey."_".$context." = 'none'\n";
65			${$self->{labelhash}}{$newkey."_".$context}='none';
66			}
67			}
68
69
70			foreach $key ( %$self->{labelhash} ) {
71			${$self->{ContextHash}}{$key} = 0;
72			}
73			$self->{InTag}="none";
74			$taglabel="";
75			$self->{tagblock}=[];
76			@{$self->{lastcon}}= qw(none);
77	williamc	1.5
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	williamc	1.1	}
88
89
90			sub parse {
91			my $self=shift;
92	williamc	1.5	my $char;
93	williamc	1.1	$self->{linecount}=0;
94	williamc	1.5
95			# Open the file
96	williamc	1.1	use FileHandle;
97			my $filehandle=FileHandle->new();
98			open( $filehandle , "$self->{filename}" )
99			or carp "Switcher: Cannot open $self->{filename} $! \n";
100	williamc	1.5
101			# Start file processing
102	williamc	1.1	while ( <$filehandle> ) {
103			$self->{linecount}++;
104	williamc	1.5	$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 checkparam($name, $key) {
114			my $self=shift;
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			#
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			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	williamc	1.1	}
234	williamc	1.5
235			}
236			else { # more close tags than open ones
237			print "Warning : Unmatched </...> tag on line ".
238			$self->line()."\n";
239	williamc	1.1	}
240	williamc	1.5	}
241			# Reset context back to text
242			$self->{tagcontext}="text";
243			}
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 _removefromstack {
261			my $self=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	williamc	1.1	}
280
281	williamc	1.5	#
282			# Quote handling
283			#
284
285			sub _quotetest {
286	williamc	1.1	my $self=shift;
287	williamc	1.5	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	williamc	1.6	else {
295			$self->_putstore($char);
296			}
297	williamc	1.5	}
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	williamc	1.1	}
306
307	williamc	1.5	#
308			# Label handling
309			#
310			sub _labeltest {
311			my $self=shift;
312			my $char=shift;
313	williamc	1.1
314	williamc	1.5	# Spaces are markers between tags
315	williamc	1.6	if ( ($char eq " ") \|\| ($char eq "\n") \|\| ($char eq "\t")) {
316	williamc	1.5	$self->_closelabel();
317	williamc	1.1	}
318	williamc	1.5	# Check for a change in label status
319			elsif ( $char eq "=" ) {
320			$self->{lastlabel}=$self->_getstore();
321			$self->_resetstore();
322			}
323	williamc	1.1	else {
324	williamc	1.5	return 0;
325	williamc	1.1	}
326	williamc	1.5	return 1;
327	williamc	1.1	}
328	williamc	1.5
329			sub _resetlabels {
330			my $self=shift;
331			undef $self->{tagvar};
332	williamc	1.1	}
333
334	williamc	1.5	sub _closelabel {
335	williamc	1.1	my $self=shift;
336
337	williamc	1.5	# 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	williamc	1.1	}
348
349	williamc	1.4	#
350	williamc	1.5	# Character Store management interface
351	williamc	1.4	#
352	williamc	1.5	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			}