package YAPE::Regex::Explain;

use YAPE::Regex 'YAPE::Regex::Explain';
use strict;
use vars '$VERSION';


$VERSION = '1.05';


my $exp_format = << 'END';
^<<<<<<<<<<<<<<<<<<<<<   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
END

my $REx_format = << 'END';
^<<<<<<<<<<<<<<<<<<<<< # ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
END

my ($using_rex,$format,$br);

my $ok_cc_REx = qr{(
  \\[0-3][0-7]{2} |
  \\x[a-fA-F0-9]{2} |
  \\c. |
  \\[nrftbae] |
  \\?.
)}xs;

my %modes = ( on => '', off => '' );

my %exp = (

  # anchors
  '\A' => 'the beginning of the string',
  '^' => 'the beginning of the string',
  '^m' => 'the beginning of a "line"',
  '\z' => 'the end of the string',
  '\Z' => 'before an optional \n, and the end of the string',
  '$' => 'before an optional \n, and the end of the string',
  '$m' => 'before an optional \n, and the end of a "line"',
  '\G' => 'where the last m//g left off',
  '\b' => 'the boundary between a word char (\w) and something ' .
          'that is not a word char',
  '\B' => 'the boundary between two word chars (\w) or two ' .
          'non-word chars (\W)',
  
  # quantifiers
  '*' => '0 or more times',
  '+' => '1 or more times',
  '?' => 'optional',
  
  # macros
  '\w' => 'word characters (a-z, A-Z, 0-9, _)',
  '\W' => 'non-word characters (all but a-z, A-Z, 0-9, _)',
  '\d' => 'digits (0-9)',
  '\D' => 'non-digits (all but 0-9)',
  '\s' => 'whitespace (\n, \r, \t, \f, and " ")',
  '\S' => 'non-whitespace (all but \n, \r, \t, \f, and " ")',

  # dot
  '.' => 'any character except \n',
  '.s' => 'any character',

  # alt
  '|' => "OR",

  # flags
  'i' => 'case-insensitive',
  '-i' => 'case-sensitive',
  'm' => 'with ^ and $ matching start and end of line',
  '-m' => 'with ^ and $ matching normally',
  's' => 'with . matching \n',
  '-s' => 'with . not matching \n',
  'x' => 'disregarding whitespace and comments',
  '-x' => 'matching whitespace and # normally',

);

my %trans = (
  '\a' => q('\a' (alarm)),
  '\b' => q('\b' (backspace)),
  '\e' => q('\e' (escape)),
  '\f' => q('\f' (form feed)),
  '\n' => q('\n' (newline)),
  '\r' => q('\r' (carriage return)),
  '\t' => q('\t' (tab)),
);


sub explain {
  my $self = shift;
  $using_rex = @_;
  local $^A = "";
  $^A = << "END" if not $using_rex;
The regular expression:

@{[ $self->display ]}

matches as follows:
  
NODE                     EXPLANATION
---------------------------------------------------------------------
END
  
  my @nodes = @{ $self->{TREE} };
  $format = $using_rex ? $REx_format : $exp_format;
  while (my $node = shift @nodes) {
    $node->explanation;
  }
  
  ($using_rex,$br) = (0,0);
  %modes = ( on => '', off => '' );

  return $^A;
}


sub YAPE::Regex::Explain::Element::extra_info {
  my $self = shift;    
  my ($q,$ng) = ($self->quant, $self->ngreed);
  my $ex = '';
  
  $q =~ s/(?<=.)\?$//;
  $q =~ /(\d+)(,(\d*))?/;

  if ($2 and $3) { $q = "between $1 and $3 times" }
  elsif ($2) { $q = "at least $1 times" }
  elsif (defined $1) { $q = "$1 times" }

  $ex .= ' (' . ($exp{$q} || $q) if $q;
  $ex .= ' (matching the least amount possible)' if $ng;
  $ex .= ')' if $q;
  
  return $ex;
}


sub YAPE::Regex::Explain::Element::handle_flags {
  my $self = shift;
  my ($prev_on, $prev_off) = @modes{qw( on off )};
  
  for (split //, $self->{ON}) {
    $modes{on} .= $_ if index($modes{on},$_) == -1;
  }
  my $on = $modes{on} = join "", sort split //, $modes{on};

  $modes{off} =~ s/[$on]+//g if length $on;

  for (split //, $self->{OFF}) {
    $modes{off} .= $_ if index($modes{off},$_) == -1;
  }
  my $off = $modes{off} = join "", sort split //, $modes{off};

  $modes{on} =~ s/[$off]+//g if length $off;

  my $exp = '';

  if ($modes{on} ne $prev_on) {
    for (split //, $modes{on}) { $exp .= ' (' . $exp{$_} . ')' }
  }
  
  if ($modes{off} ne $prev_off) {
    for (split //, $modes{off}) { $exp .= ' (' . $exp{-$_} . ')' }
  }

  return $exp;
}


sub YAPE::Regex::Explain::anchor::explanation {
  my $self = shift;
  my $type = $self->{TEXT};
  $type .= 'm' if
    ($type eq '^' or $type eq '$') and
    $modes{on} =~ /m/;

  my $explanation = $exp{$type} . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::macro::explanation {
  my $self = shift;
  my $type = $self->text;

  my $explanation = $exp{$type} . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::oct::explanation {
  my $self = shift;
  my $n = oct($self->{TEXT});

  my $explanation = "character $n" . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::hex::explanation {
  my $self = shift;
  my $n = hex($self->{TEXT});

  my $explanation = "character $n" . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::ctrl::explanation {
  my $self = shift;
  my $c = $self->{TEXT};

  my $explanation = "^$c" . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::slash::explanation {
  my $self = shift;

  my $explanation =
    ($trans{$self->text} || "'$self->{TEXT}'") .
    $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::any::explanation {
  my $self = shift;
  my $type = '.';
  $type .= 's' if $modes{on} =~ /s/;

  my $explanation = $exp{$type} . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::text::explanation {
  my $self = shift;
  my $text = $self->text;
  
  $text =~ s/\n/\\n/g;
  $text =~ s/\r/\\r/g;
  $text =~ s/\t/\\t/g;
  $text =~ s/\f/\\f/g;
  $text =~ s/'/\\'/g;
  
  my $explanation = "'$text'" . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::alt::explanation {
  my $self = shift;

  my $explanation = $exp{'|'};
  my $string = $self->string;
  
  my $oldfmt = $format;
  $format =~ s/ (\^<+)/$1 /g;
  $format =~ s/  >/# >/ if $using_rex;
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
  $format = $oldfmt;

}


sub YAPE::Regex::Explain::backref::explanation {
  my $self = shift;

  my $explanation =
    "what was matched by capture \\$self->{TEXT}" . $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::class::explanation {
  my $self = shift;
  my $class = $self->{TEXT};

  my $explanation = "any character";
  $explanation .= $self->{NEG} ? " except: " : " of: ";

  while ($class =~ s/^$ok_cc_REx//) {
    my $c1 = $1;
    $explanation .= (
      $trans{$c1} ||
      ($c1 =~ /\\[wWdDsS]/ and $exp{$c1}) ||
      "'$c1'"
    );
    if ($class =~ s/^-$ok_cc_REx//) {
      my $c2 = $1;
      $explanation .= ' to ' . (
        $trans{$c2} ||
        ($c2 =~ /\\[wWdDsS]/ and $exp{$c2}) ||
        "'$c2'"
      );
    }
    $explanation .= ', ';
  }

  substr($explanation,-2) = $self->extra_info;
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::comment::explanation { }


sub YAPE::Regex::Explain::whitespace::explanation { }


sub YAPE::Regex::Explain::flags::explanation {
  my $self = shift;
  my $string = $self->string;
  my $explanation =
    'set flags for this block' .
    $self->handle_flags;

  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::group::explanation {
  my $self = shift;
  my $explanation =
    'group, but do not capture' .
    $self->handle_flags .
    $self->extra_info .
    ":";
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";

  my %old = %modes;

  my $oldfmt = $format;
  $format =~ s/\^<<(<+)/  ^$1/g;
  $format =~ s/#  /  #/ if $using_rex;
  $_->explanation for @{ $self->{CONTENT} };
  $format = $oldfmt;
  
  $string = ')' . $self->quant;
  $explanation = 'end of grouping';

  %modes = %old;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::capture::explanation {
  my $self = shift;
  my $explanation =
    'group and capture to \\' .
    ++$br .
    $self->extra_info .
    ":";
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";

  my %old = %modes;
  my $old_br = $br;

  my $oldfmt = $format;
  $format =~ s/\^<<(<+)/  ^$1/g;
  $format =~ s/#  /  #/ if $using_rex;
  $_->explanation for @{ $self->{CONTENT} };
  $format = $oldfmt;  
  $string = ')' . $self->quant;
  $explanation = "end of \\$old_br";

  $explanation .= << "END" if $self->quant;
 (NOTE: because you're using a quantifier on this capture, only the LAST
repetition of the captured pattern will be stored in \\$old_br)
END

  %modes = %old;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::lookahead::explanation {
  my $self = shift;
  my $explanation =
    'look ahead to see if there is' .
    ($self->{POS} ? '' : ' not') .
    ":";
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";

  my %old = %modes;

  my $oldfmt = $format;
  $format =~ s/\^<<(<+)/  ^$1/g;
  $format =~ s/#  /  #/ if $using_rex;
  $_->explanation for @{ $self->{CONTENT} };
  $format = $oldfmt;  
  $string = ')' . $self->quant;
  $explanation = 'end of look-ahead' . $self->extra_info;

  %modes = %old;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::lookbehind::explanation {
  my $self = shift;
  my $explanation =
    'look behind to see if there is' .
    ($self->{POS} ? '' : ' not') .
    ":";
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";

  my %old = %modes;

  my $oldfmt = $format;
  $format =~ s/\^<<(<+)/  ^$1/g;
  $format =~ s/#  /  #/ if $using_rex;
  $_->explanation for @{ $self->{CONTENT} };
  $format = $oldfmt;  
  $string = ')' . $self->quant;
  $explanation = 'end of look-behind' . $self->extra_info;

  %modes = %old;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


sub YAPE::Regex::Explain::conditional::explanation {
  my $self = shift;
  my $explanation = "if back-reference \\$self->{BACKREF} matched, then:";
  my $string = $self->string;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";

  my %old = %modes;

  my $oldfmt = $format;
  $format =~ s/\^<<(<+)/  ^$1/g;
  $format =~ s/#  /  #/ if $using_rex;

  $_->explanation for @{ $self->{TRUE} };

  unless (@{ $self->{TRUE} }) {
    my $string = "";
    my $explanation = "match nothing";
    formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
  }
  
  if (@{ $self->{FALSE} }) {
    my $string = "|";
    my $explanation = "OTHERWISE";
    my $oldfmt = $format;
    $format =~ s/ (\^<+)/$1 /g;
    $format =~ s/#  /  #/ if $using_rex;
    formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
    $format = $oldfmt;  }
  
  $_->explanation for @{ $self->{FALSE} };

  $format = $oldfmt;  
  $string = ')' . $self->quant;
  $explanation =
    "end of conditional on \\$self->{BACKREF}" .
    $self->extra_info;

  %modes = %old;
  
  formline($format, $string, $explanation) while length($string . $explanation); $^A .= ($using_rex ? '' : '-' x 70) . "\n";
}


1;

__END__

=head1 NAME

YAPE::Regex::Explain - explanation of a regular expression

=head1 SYNOPSIS

  use YAPE::Regex::Explain;
  my $exp = YAPE::Regex::Explain->new($REx)->explain;

=head1 C<YAPE> MODULES

The C<YAPE> hierarchy of modules is an attempt at a unified means of parsing
and extracting content.  It attempts to maintain a generic interface, to
promote simplicity and reusability.  The API is powerful, yet simple.  The
modules do tokenization (which can be intercepted) and build trees, so that
extraction of specific nodes is doable.

=head1 DESCRIPTION

This module merely sub-classes C<YAPE::Regex>, and produces a rather verbose
explanation of a regex, suitable for demonstration and tutorial purposes.

=head2 Methods for C<YAPE::Regex::Explain>

=over 4

=item * C<my $p = YAPE::Regex::Explain-E<gt>new($regex);>

Calls C<YAPE::Regex>'s C<new> method (see its docs).

=item * C<my $p = YAPE::Regex::Explain-E<gt>explain($as_regex);>

Returns a string explaining the regex.  If you pass an argument (any argument at
all) to this method, a valid regex (under C</x>) will be returned.

=back

=head1 SUPPORT

Visit C<YAPE>'s web site at F<http://www.pobox.com/~japhy/YAPE/>.

=head1 SEE ALSO

The C<YAPE::Regex> documentation.

=head1 AUTHOR

  Jeff "japhy" Pinyan
  CPAN ID: PINYAN
  japhy@pobox.com
  http://www.pobox.com/~japhy/

=cut


