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                             
# checkparam($name,$par)    : Exit with an error message if parameter 
#                             is undefined in tag $name
# 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 _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}="";

        # 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();
}

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

        # 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->_calltag($self->{textcontext}, $self->{textcontext}, 
                                                        $self->_getstore());
        $self->_resetstore();
        $self->_resetlabels();

        $self->{scramtmp}=$self->_popstream();
        # 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=$self->{tagcontainer}->getroutine($tagroutine);
          if ( $rt ne "" ) {
               &{$rt}( $self->{allw},@_);
               $found=1;
          }
        }
        
        if ( ! $found ) {
            $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};
}

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