src/ActiveDoc/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                             
# line()                    : return the current line number of the parse
# stream(filehandle)        : stream output to the filehandle if not handled
#                               in any other way
package ActiveDoc::Switcher;
require 5.001;
use Carp;

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

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

sub stream {
        my $self=shift;

        $self->{stream}=shift;
}

sub streamexclude {
        my $self=shift;
        my $tag=shift;

        $tag=~tr/A-Z/a-z/;
        $self->{streamexclude}{$tag}=1;
}

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

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

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

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

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

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

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

        # Open the file
        use FileHandle;
        local $filehandle;
        $filehandle=FileHandle->new();
        $filehandle->open("<".$self->{filename})
           or return 1;
        # The buffering seems all messed up - best not to use it
        $filehandle->setvbuf($buf, _IONBF, 3000);

        # 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
        undef $filehandle;
        $self->_printstream();
}

#
# 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";

        # Keep a record for any stream processes
        $self->{streamstore}=$self->{streamstore}.$char;

        return $char;
}

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

        # Close the last text segment
        $self->{streamtmp}=$self->_popstream();
        $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;
        my $found=0;

        if ( $self->{groupchecker}->status() ||
                ( $self->{tagcontainer}->inquiregroup($tagroutine)) ) {
          ($rt,$obj)=$self->{tagcontainer}->getroutine($tagroutine);
          if ( $rt ne "" ) {
             if ( ! defined $obj ) {
               &{$rt}( $self->{allw},@_);
             }
             else {
               &{$rt}( $obj,@_);
             }
             $found=1;
          }
        }
        
        # stream function
        if ( ! exists $self->{streamexclude}{$tagroutine} ) {
            $self->_printstream();
        }
        $self->_clearstream();
}

sub _clearstream {
        my $self=shift;
        $self->{streamstore}=(($self->{streamtmp} ne "")?$self->{streamtmp}:"");
        $self->{streamtmp}="";
}

sub _popstream {
        my $self=shift;
        $self->{streamstore}=~s/(.*)(.)$/$1/;
        return $2;
}

sub _printstream {

        my $self=shift;

        # Stream output functionality
        if ( defined $self->{stream} ) {
            print {$self->{stream}} "$self->{streamstore}";
        }
}

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};
        undef $self->{tagname};
}

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
         if ( ! defined $self->{tagname} ) {
            ($self->{tagname}=$self->_getstore())=~tr/A-Z/a-z/;
         }
         else {
            die ">Tag syntax error in $self->{tagname} on line ".
                $self->line()." of file \n$self->{filename}";
         }
        }
        $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.11
Committed:	Thu Nov 18 17:32:53 1999 UTC (25 years, 5 months ago) by williamc
Content type:	text/plain
Branch:	MAIN
Changes since 1.10:	+1 -1 lines
Log Message:	Catch undefined parameters as a sysntax error
#	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			# 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			# line() : return the current line number of the parse
16	williamc	1.6	# stream(filehandle) : stream output to the filehandle if not handled
17			# in any other way
18	williamc	1.3	package ActiveDoc::Switcher;
19	williamc	1.1	require 5.001;
20			use Carp;
21
22			sub new {
23			my $class=shift;
24			my $file=shift;
25			my $objectname=shift;
26			my $groupchecker=shift;
27
28	williamc	1.4	$self = {};
29	williamc	1.1	$self->{allw}=$objectname;
30			bless $self, $class;
31			$self->_initialise($file);
32			return $self;
33			}
34
35	williamc	1.6	sub stream {
36			my $self=shift;
37
38			$self->{stream}=shift;
39			}
40
41	williamc	1.8	sub streamexclude {
42			my $self=shift;
43			my $tag=shift;
44
45			$tag=~tr/A-Z/a-z/;
46			$self->{streamexclude}{$tag}=1;
47			}
48
49	williamc	1.1	sub _initialise (hash1) {
50			my $self=shift;
51			$self->{filename}=shift;
52
53			# add a default groupchecker
54			use ActiveDoc::GroupChecker;
55			$self->{groupchecker}=GroupChecker->new();
56			$self->{groupchecker}->include("all");
57
58			# Add a default TagContainer
59			use ActiveDoc::TagContainer;
60	williamc	1.3	$self->{tagcontainer}=ActiveDoc::TagContainer->new();
61	williamc	1.1
62			}
63
64			sub usetags {
65			my $self=shift;
66			my $tagcontainer=shift;
67
68			$self->{tagcontainer}=$tagcontainer;
69			}
70
71			sub usegroupchecker {
72			my $self=shift;
73			my $ref=shift;
74
75			$self->{groupchecker}=$ref;
76			}
77
78			sub parse {
79			my $self=shift;
80			my $char;
81	williamc	1.4	my $buf;
82	williamc	1.1	$self->{linecount}=0;
83			$self->_resetvars();
84	williamc	1.6	$self->{streamstore}="";
85	williamc	1.8	$self->{streamtmp}="";
86	williamc	1.1
87			# Open the file
88			use FileHandle;
89	williamc	1.6	local $filehandle;
90	williamc	1.4	$filehandle=FileHandle->new();
91	williamc	1.6	$filehandle->open("<".$self->{filename})
92	williamc	1.2	or return 1;
93	williamc	1.4	# The buffering seems all messed up - best not to use it
94	williamc	1.5	$filehandle->setvbuf($buf, _IONBF, 3000);
95	williamc	1.1
96			# Start file processing
97	williamc	1.4	while ( ($_=<$filehandle>) ) {
98	williamc	1.1	$self->{linecount}++;
99			$self->{currentline}=$_;
100			$self->{stringpos}=0;
101			while ( ($char=$self->_nextchar()) ne "" ) {
102			$self->_checkchar($char);
103			} # end char while
104			} # End String while loop
105	williamc	1.5	undef $filehandle;
106	williamc	1.6	$self->_printstream();
107	williamc	1.1	}
108
109			#
110			# return the current line number
111			#
112			sub line {
113			my $self=shift;
114			return $self->{linecount};
115			}
116			# --------------- Utility routines ----------------------------
117
118			#
119			# Some initialisation of test suites
120			#
121			sub _resetvars {
122			my $self=shift;
123			$self->{quotes}=0;
124			$self->{lastlabel}="";
125			$self->{textcontext}='none';
126			$self->{tagcontext}="text";
127			$self->_resetstore();
128			}
129
130			#
131			# Check for control characters
132			#
133			sub _checkchar {
134			my $self=shift;
135			my $char=shift;
136			my $string;
137
138	williamc	1.6
139	williamc	1.1	# ---- In a tag
140			if ( $self->{tagcontext}=~/tag/ ) {
141			if ( ! $self->_quotetest($char) ) {
142			if ( ! $self->_labeltest($char) ) {
143			if ( $char eq ">") { $self->_closetag(); }
144			else { $self->_putstore($char); }
145			}
146			}
147			}
148			# ------ Outside a tag
149			else {
150			if ( $char eq "<") { $self->_opentag() }
151			else { $self->_putstore($char) }
152			}
153			}
154
155
156			#
157			# Return the next character from the current string buffer
158			#
159			sub _nextchar() {
160			my $self=shift;
161			my $char;
162			$char=substr($self->{currentline},$self->{stringpos}++,1);
163			# print "Debug : Fetching character $char\n";
164	williamc	1.6
165			# Keep a record for any stream processes
166			$self->{streamstore}=$self->{streamstore}.$char;
167
168	williamc	1.1	return $char;
169			}
170
171			sub _opentag {
172			my $self=shift;
173			my $char;
174
175			# Close the last text segment
176	williamc	1.8	$self->{streamtmp}=$self->_popstream();
177	williamc	1.1	$self->_calltag($self->{textcontext}, $self->{textcontext},
178			$self->_getstore());
179			$self->_resetstore();
180			$self->_resetlabels();
181
182			# Do we have an opening or closing tag?
183			if ( ($char=$self->_nextchar()) eq "/" ) { #we have a closing tag
184			$self->{tagcontext}="endtag";
185			}
186			else { # an opening tag
187			$self->{tagcontext}="starttag";
188			$self->_checkchar($char);
189			}
190			#print "\nDebug : Opening $self->{tagcontext}\n";
191			}
192
193			#
194			# Close a tag
195			#
196			sub _closetag {
197			my $self=shift;
198			my $tagroutine;
199
200			# -- Finish off any labels/get tagname
201			$self->_closelabel();
202
203			# -- Call the associated tag function if appropriate
204			$tagroutine=$self->{tagname}."_".$self->{tagcontext};
205			$self->_calltag($tagroutine, $self->{tagname},
206			$self->{tagvar});
207			#print "\nDebug : Closing Tag $tagroutine\n";
208
209			# -- Now make sure the text context is set for calling routines to
210			# -- deal with text portions outside of tags
211			if ( $self->{tagcontext} eq "starttag" ) {
212			push @{$self->{textstack}} , $self->{textcontext};
213			$self->{textcontext}=$self->{tagname};
214			}
215			else {
216			if ( $#{$self->{textstack}} > -1 ) {
217			if ( $self->{textcontext} eq $self->{tagname} ) {
218			$self->{textcontext}=pop @{$self->{textstack}};
219			}
220			else { #The tag we are closing is not the last one so
221			# we keep our current context.
222			$self->_removefromstack($self->{tagname},$self->{textstack});
223			}
224
225			}
226			else { # more close tags than open ones
227			print "Warning : Unmatched </...> tag on line ".
228			$self->line()."\n";
229			}
230			}
231			# Reset context back to text
232			$self->{tagcontext}="text";
233			}
234
235			sub _calltag {
236			my $self=shift;
237			my $tagroutine=shift;
238			my @args=@_;
239			my $rt;
240	williamc	1.6	my $found=0;
241	williamc	1.1
242			if ( $self->{groupchecker}->status() \|\|
243			( $self->{tagcontainer}->inquiregroup($tagroutine)) ) {
244	williamc	1.7	($rt,$obj)=$self->{tagcontainer}->getroutine($tagroutine);
245	williamc	1.1	if ( $rt ne "" ) {
246	williamc	1.7	if ( ! defined $obj ) {
247	williamc	1.1	&{$rt}( $self->{allw},@_);
248	williamc	1.7	}
249			else {
250			&{$rt}( $obj,@_);
251			}
252			$found=1;
253	williamc	1.1	}
254			}
255	williamc	1.6
256	williamc	1.8	# stream function
257			if ( ! exists $self->{streamexclude}{$tagroutine} ) {
258	williamc	1.6	$self->_printstream();
259			}
260			$self->_clearstream();
261			}
262
263			sub _clearstream {
264			my $self=shift;
265			$self->{streamstore}=(($self->{streamtmp} ne "")?$self->{streamtmp}:"");
266			$self->{streamtmp}="";
267			}
268
269			sub _popstream {
270			my $self=shift;
271			$self->{streamstore}=~s/(.*)(.)$/$1/;
272			return $2;
273			}
274
275			sub _printstream {
276
277			my $self=shift;
278
279			# Stream output functionality
280			if ( defined $self->{stream} ) {
281			print {$self->{stream}} "$self->{streamstore}";
282			}
283	williamc	1.1	}
284
285			sub _removefromstack {
286			my $self=shift;
287			my $name=shift;
288			my $stack=shift;
289			my $this;
290
291			undef @tempstack;
292			#print "In ----".$#{$stack};
293			# Keep popping until we find our string
294			while ( ($this=(pop @{$stack})) ne "$name") {
295			push @tempstack, $this;
296			if ( $#{$stack} < 0 ) { last; }
297			}
298			# Now put them back
299			while ( $#tempstack>-1) {
300			$this=pop @tempstack;
301			push @{$stack}, $this;
302			}
303			#print " Out ----".$#{$stack};
304			}
305
306			#
307			# Quote handling
308			#
309
310			sub _quotetest {
311			my $self=shift;
312			my $char=shift;
313
314			# --- Are we already in a quote context?
315			if ( $self->{quotes} ) {
316			if ( $char eq $self->{openquote} ) {
317			$self->{quotes}=0;
318			}
319			else {
320			$self->_putstore($char);
321			}
322			}
323			# --- Unquoted Context
324			elsif ( (($char eq "\"") \|\| ($char eq "\'") \|\| ($char eq "\`")) ) {
325			$self->{quotes}=1;
326			$self->{openquote}=$char;
327			}
328			else { return 0; } # Return zero if not quoted
329			return 1; # 1 otherwise
330			}
331
332			#
333			# Label handling
334			#
335			sub _labeltest {
336			my $self=shift;
337			my $char=shift;
338
339			# Spaces are markers between tags
340			if ( ($char eq " ") \|\| ($char eq "\n") \|\| ($char eq "\t")) {
341			$self->_closelabel();
342			}
343			# Check for a change in label status
344			elsif ( $char eq "=" ) {
345			$self->{lastlabel}=$self->_getstore();
346			$self->_resetstore();
347			}
348			else {
349			return 0;
350			}
351			return 1;
352			}
353
354			sub _resetlabels {
355			my $self=shift;
356			undef $self->{tagvar};
357	williamc	1.9	undef $self->{tagname};
358	williamc	1.1	}
359
360			sub _closelabel {
361			my $self=shift;
362
363			# Do we have a label name?
364			if ( $self->{lastlabel} ne "" ) {
365			$self->{tagvar}{$self->{lastlabel}}=$self->_getstore();
366			$self->{lastlabel}="";
367			}
368			elsif ( $self->_getstore() ne "") {
369	williamc	1.9	# Then it must be the tag name
370			if ( ! defined $self->{tagname} ) {
371			($self->{tagname}=$self->_getstore())=~tr/A-Z/a-z/;
372			}
373			else {
374	williamc	1.10	die ">Tag syntax error in $self->{tagname} on line ".
375	williamc	1.11	$self->line()." of file \n$self->{filename}";
376	williamc	1.9	}
377	williamc	1.1	}
378			$self->_resetstore();
379			}
380
381			#
382			# Character Store management interface
383			#
384			sub _putstore() {
385			my $self=shift;
386			my $char=shift;
387
388			$self->{stringbuff}=$self->{stringbuff}.$char;
389			}
390
391			sub _getstore() {
392			my $self=shift;
393
394			return $self->{stringbuff};
395			}
396
397			sub _resetstore {
398			my $self=shift;
399			$self->{stringbuff}="";
400			}