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(file,objectref) : A new object -  filename of file to parse
#                                   objectref->of the methods
# usetags(tagobjref)               : Specify a tagcontainer set to direct to
#                                    to the desired routines
# usegroupchecker(groupchecker)    : Set a groupchecker
# 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 $file=shift;
        my $objectname=shift;
        my $groupchecker=shift;

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

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

        # add a default groupchecker
          use Utilities::GroupChecker;
          $self->{groupchecker}=GroupChecker->new();
          $self->{groupchecker}->include("all");

        # Add a default tagcontainer
          use Utilities::tagcontainer;
          $self->{tagcontainer}=tagcontainer->new();
         
}

sub usetags {
        my $self=shift;
        my $tagcontainer=shift;

        $self->{tagcontainer}=$tagcontainer;
}

sub usegroupchecker {
        my $self=shift;
        my $ref=shift;
        
        $self->{groupchecker}=$shift;
}

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

        # 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=@_;
        my $rt;

        if ( $self->{groupchecker}->status() ) {
          $rt=$self->{tagcontainer}->getroutine($tagroutine);
          if ( $rt ne "" ) {
               &{$rt}( $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.8
Committed:	Fri Jun 18 10:55:44 1999 UTC (25 years, 11 months ago) by williamc
Content type:	text/plain
Branch:	MAIN
Changes since 1.7:	+32 -57 lines
Log Message:	Change new interface completeley - groupchecker and taghash now need to be made seperateley
#	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	williamc	1.8	# 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	williamc	1.5	# 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	williamc	1.1
19			package Switcher;
20	williamc	1.2	require 5.001;
21	williamc	1.1	use Carp;
22
23			sub new {
24			my $class=shift;
25			my $file=shift;
26	williamc	1.4	my $objectname=shift;
27	williamc	1.5	my $groupchecker=shift;
28
29	williamc	1.1	my $self = {};
30	williamc	1.4	$self->{allw}=$objectname;
31	williamc	1.1	bless $self, $class;
32	williamc	1.8	$self->_initialise($file);
33	williamc	1.1	return $self;
34			}
35
36			sub _initialise (hash1) {
37			my $self=shift;
38	williamc	1.5	$self->{filename}=shift;
39
40	williamc	1.8	# add a default groupchecker
41	williamc	1.5	use Utilities::GroupChecker;
42			$self->{groupchecker}=GroupChecker->new();
43			$self->{groupchecker}->include("all");
44	williamc	1.8
45			# Add a default tagcontainer
46			use Utilities::tagcontainer;
47			$self->{tagcontainer}=tagcontainer->new();
48
49			}
50
51			sub usetags {
52			my $self=shift;
53			my $tagcontainer=shift;
54
55			$self->{tagcontainer}=$tagcontainer;
56	williamc	1.1	}
57
58	williamc	1.8	sub usegroupchecker {
59			my $self=shift;
60			my $ref=shift;
61
62			$self->{groupchecker}=$shift;
63			}
64	williamc	1.1
65			sub parse {
66			my $self=shift;
67	williamc	1.5	my $char;
68	williamc	1.1	$self->{linecount}=0;
69	williamc	1.8	$self->_resetvars();
70	williamc	1.5
71			# Open the file
72	williamc	1.1	use FileHandle;
73			my $filehandle=FileHandle->new();
74			open( $filehandle , "$self->{filename}" )
75			or carp "Switcher: Cannot open $self->{filename} $! \n";
76	williamc	1.5
77			# Start file processing
78	williamc	1.1	while ( <$filehandle> ) {
79			$self->{linecount}++;
80	williamc	1.5	$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 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 $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	williamc	1.1	}
210	williamc	1.5
211			}
212			else { # more close tags than open ones
213			print "Warning : Unmatched </...> tag on line ".
214			$self->line()."\n";
215	williamc	1.1	}
216	williamc	1.5	}
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	williamc	1.8	my $rt;
226	williamc	1.5
227			if ( $self->{groupchecker}->status() ) {
228	williamc	1.8	$rt=$self->{tagcontainer}->getroutine($tagroutine);
229			if ( $rt ne "" ) {
230			&{$rt}( $self->{allw},@_);
231			}
232	williamc	1.5	}
233			}
234
235			sub _removefromstack {
236			my $self=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	williamc	1.1	}
255
256	williamc	1.5	#
257			# Quote handling
258			#
259
260			sub _quotetest {
261	williamc	1.1	my $self=shift;
262	williamc	1.5	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	williamc	1.6	else {
270			$self->_putstore($char);
271			}
272	williamc	1.5	}
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	williamc	1.1	}
281
282	williamc	1.5	#
283			# Label handling
284			#
285			sub _labeltest {
286			my $self=shift;
287			my $char=shift;
288	williamc	1.1
289	williamc	1.5	# Spaces are markers between tags
290	williamc	1.6	if ( ($char eq " ") \|\| ($char eq "\n") \|\| ($char eq "\t")) {
291	williamc	1.5	$self->_closelabel();
292	williamc	1.1	}
293	williamc	1.5	# Check for a change in label status
294			elsif ( $char eq "=" ) {
295			$self->{lastlabel}=$self->_getstore();
296			$self->_resetstore();
297			}
298	williamc	1.1	else {
299	williamc	1.5	return 0;
300	williamc	1.1	}
301	williamc	1.5	return 1;
302	williamc	1.1	}
303	williamc	1.5
304			sub _resetlabels {
305			my $self=shift;
306			undef $self->{tagvar};
307	williamc	1.1	}
308
309	williamc	1.5	sub _closelabel {
310	williamc	1.1	my $self=shift;
311
312	williamc	1.5	# 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	williamc	1.1	}
323
324	williamc	1.4	#
325	williamc	1.5	# Character Store management interface
326	williamc	1.4	#
327	williamc	1.5	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			}