/[cvs]/nfo/perl/libs/Regexp/Group.pm

Diff of /nfo/perl/libs/Regexp/Group.pm

Parent Directory | Revision Log | View Patch Patch

-revision 1.4 by joko,
Thu Mar 27 15:45:00 2003 UTC
+revision 1.5 by joko,
Tue May 13 09:10:15 2003 UTC
 Line 2
  ##  $Id$
  ## ------------------------------------------------------------------------
  ##  $Log$
+ ##  Revision 1.5  2003/05/13 09:10:15  joko
+ ##  added documentation (pod) and comments
+ ##  now using Class::Smart as base class
+ ##  new: reporting and statistics
+ ##
  ##  Revision 1.4  2003/03/27 15:45:00  joko
  ##  fixes to modules regarding new namespace(s) below Data::Mungle::*
  ##
-Line 17
+Line 22
  ## ------------------------------------------------------------------------
+ =pod
+ =head1 Name
+   Regexp::Group
+ =head1 Description
+   Perform a group of forward declared steps on a string
+   using regular expressions and callback event handlers.
+   A "step" is a triple of a pattern, an event handler and associated metadata.
+   The regular expression pattern is used to scan the payload and a corresponding
+   event handler is used to mungle the raw result of the pattern match into a more
+   self-descriptive form. The metadata information passed along gets used to do
+   right that.
+   The declaration happens - package/block/topic - based.
+   The elements are linked to each other across blocks by giving them the same name.
+   The block / declaration data structure are simple hashes.
+   The declaration of these has to happen outside of this module, the intention of this
+   module can be pictured as the "(state) engine" which processes this "receipt".
+   I don't actually remember, but *returning groups* of results (grouped records)
+   also might have been an initial aspect/intention of this module. However - there
+   has been no investigation if it actually worked out as expected.
+   It works like it is. Never touch a running system.  ;-)
+ =head1 Todo
+   o Kind of runtime introspection to give encapsulated access some innards:
+. payload
+         $self->{data}
+. receipt
+         $self->{metadata}
+         $self->{patterns}
+         $self->{coderefs}
+ =head1 Bugs
+   Yes.
+ =cut
  package Regexp::Group;
  use strict;
  use warnings;
- use base qw( DesignPattern::Logger );
+ use base qw( Class::Smart DesignPattern::Logger );
+ $Class::Smart::constructor = '_init';
  use Data::Dumper;
  use Data::Mungle::Compare::Struct qw( isEmpty );
- my @patterns;
+ # TODO/REVIEW: compile patterns? (see below...)
+ #my @patterns;
- # ------------    common perl object constructor    ------------
- sub new {
-   my $invocant = shift;
-   my $class = ref($invocant) || $invocant;
-   my @args = ();
-   @_ && (@args = @_);
-   #$logger->debug( __PACKAGE__ . "->new( @args )" );      # this is not "common"!
-   my $self = { @_ };
-   bless $self, $class;
-   $self->{caller} = caller;
-   #print Dumper(caller(2));
-   #exit;
-   $self->_init();
-   return $self;
- }
+ # Initializer / Pseudo constructor - Does some work instead of an otherwise required constructor.
  sub _init {
    my $self = shift;
+   # Just initialize once, prevent multiple redundant (false|zombie) calls to this method.
+   return if $self->{__INITIALIZED};
+   $self->{__INITIALIZED}++;
+   $self->{caller} = caller;
    # TODO/REVIEW: compile patterns?
    #@patterns = map{ qr/$_/ } @patterns;
-Line 59 
 sub _init {
+Line 110 
 sub _init {
    $self->{data} = ${$self->{data}};
  }
+ # Kicks off processing and reports statistics from subsequential steps.
  sub scan {
    my $self = shift;
    my $stepkeys = shift;
    my $coderef = shift;
+   $self->clear_report();
    #my $nodecount_default = shift;
    my $nodecount_default = 19;
- #print "SCAN", "\n";
+   #print "SCAN", "\n";
- #print $self->{pattern}, "\n";
+   #print $self->{pattern}, "\n";
    $self->{result} = [];
    $self->{result_raw} = [];
-Line 78 
 sub scan {
+Line 133 
 sub scan {
      # disables _any_ tracing - even if sub-conditions evaluate to true values
      $self->{TRACE_DISABLED} = 0;
-   $self->log('starting to scan');
+   $self->log('--------- start ---');
    #for (1..20) {
-Line 96 
 sub scan {
+Line 151 
 sub scan {
  #print "cb-2: $coderef", "\n";
    foreach my $stepkey_current (@{$steps}) {
-     $self->_scan_step($stepkey_current, $coderef);
+     $self->{report}->{$stepkey_current} = $self->_scan_step($stepkey_current, $coderef);
      $patterncount++;
    }
-Line 109 
 sub scan {
+Line 164 
 sub scan {
    #$self->{code}->($self->{caller}, $self);
+   # new of 2003-05-09: return reference to report as response
+   #return $self->{report};
  }
  sub _scan_step {
-Line 117 
 sub _scan_step {
+Line 175 
 sub _scan_step {
    my $stepkey = shift;
    my $callback = shift;
- #print "cb-3: $callback", "\n";
+   $self->log("Running step '$stepkey'.");
-     #$self->log("running step '$stepkey'", 'debug');
+   # All data we need from the current instance to drive the pattern match via "gex".
-     $self->log("running step '$stepkey'");
+   my $dataref = $self->{data};
+   my $metadata = $self->{metadata}->{$stepkey};
-     my $dataref = $self->{data};
+   my $pattern = $self->{patterns}->{$stepkey};
-     my $metadata = $self->{metadata}->{$stepkey};
+   my $coderef = $self->{coderefs}->{$stepkey};
-     my $pattern = $self->{patterns}->{$stepkey};
-     my $coderef = $self->{coderefs}->{$stepkey};
-     #print Dumper($coderef);
+   # Doing some assertions which lead to structure tracing on DEBUG-OUT ...
-     #print Dumper($self->{data});
-     #exit;
-     $self->trace("data used", $dataref, 0, undef, { tag => '', exit => 0 });
+     # debug
+     #print "pattern: $pattern", "\n";
+     #exit;
+     # Having all these assertions set/evaluate to true, it will dump an overview of what happens in the innards on STDOUT.
+     my $assertion = ($stepkey eq 'bet');
+     $assertion = 0;
+     $self->trace("data used", $dataref, $assertion, undef, { tag => '', exit => 0 });
+     $self->trace("pattern used", $pattern, $assertion, undef, { tag => '', exit => 0 });
      $self->trace("metadata used", $metadata, 0, undef, { tag => '', exit => 0 });
-     $self->trace("pattern used", $pattern, 0, undef, { tag => '', exit => 0 });
      $self->trace("coderef used", $coderef, 0, undef, { tag => '', exit => 0 });
- #print "pattern: $pattern", "\n";
+   # If metadata variable "noscan" is supplied, don't kick off the regex-engine, just call the coderef.
- #exit;
+   # TODO: What was the intention of this? How are its mechanics working? Describe this here!
+   # FIXME: Log this event.
+   if ($metadata->{noscan} && $metadata->{noscan} == 1) {
+     $coderef->($self, undef, undef, $callback);
+     return;
+   }
+   # dereference data if it's still referenced
+   my $data = ${$self->{data}};
-     # if metadata variable "noscan" is supplied, don't kick off the regex-engine, just call the coderef
+   if (!$data) {
-     # TODO: log this event
+     $self->log("data is empty: stepkey=$stepkey", 'warning');
-     if ($metadata->{noscan} && $metadata->{noscan} == 1) {
+     return;
-       $coderef->($self, undef, undef, $callback);
+   }
-       return;
-     }
-     # dereference data if its still referenced
-     my $data = ${$self->{data}};
-     if (!$data) {
-       $self->log("data is empty: stepkey=$stepkey", 'warning');
+   # To detect if anything happened inside the regex after it: Could the pattern be applied?.
-       return;
+   my $matchcount = 0;
-     }
-     #$self->{data} =~ s{
+   # Apply the regular expression using "gex"-options for the "Perl regular expressions"
-     $data =~ s{
+   # parser that's embedded in Perl-5.6.1, see "perldoc perlre".
+   # This is preliminary:
+   # This code initially was written in Dec-2002 with Perl-5.6.1 on Windows using
+   # [perl, v5.6.1 built for MSWin32-x86-multi-thread], has been tested with
+   # Perl-5.8.x on Linux and seems to work fine in production on a FreeBSD machine
+   # running Perl-5.?.? since mid 2003.
+   #$self->{data} =~ s{
+   $data =~ s{
        $pattern       # the pattern itself - as contained in a string - actually gets interpolated here
-     }{
+   }{
+       # Indicate for the followup code that the pattern matched.
+       $matchcount++;
        print "." if $self->{verbose};
-       $self->log("match in step '$stepkey'");
+       #$self->log("Match in step '$stepkey'!");
        # have a clean item to fill in slots
        my $result_item = [];
-Line 189 
 sub _scan_step {
+Line 264 
 sub _scan_step {
        # 2. remember built result (raw) in object - grouping functionality for items
-         $self->log("pushing raw result");
+         #$self->log("pushing raw result");
          push @{$self->{result_raw}}, $result_item;
-Line 225 
 sub _scan_step {
+Line 300 
 sub _scan_step {
        # 3. call coderef to get _processed_ result if given (callback)
-         $self->log("calling coderef '$coderef'");
+         $self->log("Match!!! Calling event handler '$coderef'.");
          if ($coderef) {
            my $result_processed = {};
            if ($coderef->($self, $result_item, $result_processed, $callback)) {
-Line 239 
 sub _scan_step {
+Line 314 
 sub _scan_step {
            # TODO: croak 'no coderef';
          }
-       # pass back matched content if we are not the ones to delete something (pass-back-if-not-remover)
+       # Pass back matched content if we are not the ones to delete something (pass-back-if-not-remover)
-       # with this mechanism, we can iterate over the same content again and again and don't loose data while doing this
+       # With this mechanism, we can iterate over the same content again and again and don't loose data while doing this.
-       # without this, multiple scan stepping would not be possible since each step would either remove its
+       # Without this, multiple scan stepping would not be possible since each step would either remove its
        # matched content - or not: no flexibility.
-       # as it seems we need flexibility at any point ;-( in order not to break our necks with code-maintenance ;-)
+       # As it seems we need flexibility at any point ;-( in order not to break our necks with code-maintenance ;-)
-       # this also can get configured here (this flag is contained in the metadata-part of your filter-declaration)
+       # this also can get configured here (this flag is contained in the metadata-part of your filter-declaration).
        $& if !$metadata->{remover};
-     }xge;
+   }gex;
-     #$self->{data_rest} = \$data;
+   # What to do with the payload?
-     $self->{data} = \$data;
+   #$self->{data_rest} = \$data;
+   $self->{data} = \$data;
-     #$self->trace('matches', $self->getMatches(), 1);
+   #$self->trace('matches', $self->getMatches(), 1);
-     #$self->trace('matches-positions', $self->getMatchPositions(), 1);
+   #$self->trace('matches-positions', $self->getMatchPositions(), 1);
-     #print "\r" if $self->{verbose};
+   # Try to fake some kinda progress bar on STDOUT.
-     print " " x 50 if $self->{verbose};
+   #print "\r" if $self->{verbose};
-     print "\r" if $self->{verbose};
+   print STDOUT " " x 50 if $self->{verbose};
+   print STDOUT "\r" if $self->{verbose};
+   # new of 2003-05-08: Now we have a return value we can also send to debug output handler.
+   $self->log("No Match for step '$stepkey'!", 'debug') if not defined $matchcount or $matchcount == 0;
+   # Indicate if regex for current step could be applied.
+   return $matchcount;
  }
  sub continue {
-Line 309 
 sub getMatchPosition {
+Line 390 
 sub getMatchPosition {
    return $self->{matches}->{position};
  }
+ sub get_report {
+   my $self = shift;
+   return $self->{report};
+ }
+ sub clear_report {
+   my $self = shift;
+   delete $self->{report};
+ }
 ;
+ __END__

 Legend:



Removed from v.1.4
 


changed lines


 
Added in v.1.5
 Legend:



Removed from v.1.4
 


changed lines


 
Added in v.1.5
-Removed from v.1.4
+Added in v.1.5

MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26