view release on metacpan or  search on metacpan

inc/Pod/Snippets.pm  view on Meta::CPAN

}

=head2 finalize_pod_snippets ()

Called after parsing is done; must raise any and all errors that occur
at the end of the file (eg snippets without a closing tag).

=cut

sub finalize_pod_snippets {
    my ($self) = @_;
    foreach my $snipname ($self->in_named_pod_snippet) {
        $self->maybe_raise_pod_snippets_bad_pairing($snipname);
    }
}

=head2 command ()

Overloaded so as to catch the I<Pod::Snippets> markup and keep state
accordingly.

=cut

sub command {
    my ($self, $command, $paragraph, $line_num) = @_;

    $self->pod_snippets_source_line_number($line_num);

    $self->break_current_pod_snippet, return unless
        ($command =~ m/^(for|begin|end)/);

    $self->break_current_pod_snippet, return unless
            (my ($details) = $paragraph =~
             m/\A\s*$self->{-pod_snippets_markup}(.*)$/m);

    # Accept "=begin test" and "=end test" and do nothing...
    if (! $details) {
        $self->ignoring_pod_snippets(0) if ($command eq "for");
        return;
    }

    # ... But moan about "=begin test ignore".
    if ($command eq "for" && $details =~ m/\s+ignore\s*$/) {
        $self->ignoring_pod_snippets(1);
        return;
    }

    if (my ($snipname, $subcommand) =
        $details =~ m/^ \s+ (?: "(.*?)" )  \s* (begin|end)?/x) {
        $command = $subcommand if ($subcommand && $command eq "for");
        if ($command eq "begin") {
            $self->in_named_pod_snippet($snipname, 1);
            return;
        } elsif ($command eq "end") {
            $self->in_named_pod_snippet($snipname, 0);
            return;
        }
    }

    my $equals = "="; # Foils smarter-than-thou Pod::Checker.  Sigh.
    $self->raise_pod_snippets_incident("warning", <<"MESSAGE");
Cannot interpret command, ignoring.

$equals$command $paragraph

MESSAGE
}

=head2 verbatim ()

Overloaded so as to catch and store the verbatim sections.

=cut

sub verbatim {
    my ($self, $paragraph, $line_num) = @_;

    $self->pod_snippets_source_line_number($line_num);

    return if $self->ignoring_pod_snippets;
    push(@{$self->{pod_snippets}},
         Pod::Snippets::_Snippet->new($line_num, $paragraph,
                                      $self->pod_snippets_names()));
}

=head2 textblock ()

=head2 interior_sequence ()

These methods are overloaded so as discard the corresponding pieces of
POD and to call L</break_current_pod_snippet> instead.

=cut

sub textblock {
    my ($self, $paragraph, $line_num) = @_;
    $self->pod_snippets_source_line_number($line_num);
    $self->break_current_pod_snippet;
}

sub interior_sequence { shift->break_current_pod_snippet }

=head2 break_current_pod_snippet ()

Called by L</command>, L</textblock> and L</interior_sequence>
whenever a piece of POD that is ignored by B<Pod::Snippets> is seen in
the parse stream.  Causes the parser to record the break, pursuant to
the snippet aggregation feature set forth in L</as_data>.

=cut

sub break_current_pod_snippet {
    my ($self) = @_;
    $self->maybe_raise_pod_snippets_impure() if
        $self->in_named_pod_snippet;
    push(@{$self->{pod_snippets}}, undef)
         unless (! defined $self->{pod_snippets}->[-1]);
}

=head2 pod_snippets_source_line_number ()

=head2 pod_snippets_source_line_number ($value)

Gets or sets the line number that the parser reached, to be used in
error messages (after offsetting it by the appropriate amount
depending on the setting of the C<-line> named option to
L</new_for_pod_snippets>).  The setter form is to be called as soon as
possible by parser callbacks L</command>, L</verbatim>, L</textblock>
so as to keep in sync with the POD flow.

=cut

sub pod_snippets_source_line_number {
    my ($self, @value) = @_;
    $self->{pod_snippets_source_line_number} = $value[0] if @value;
    return $self->{pod_snippets_source_line_number};
}

=head3 maybe_raise_pod_snippets_multiple ($name)

=head3 maybe_raise_pod_snippets_overlap ($name)

=head3 maybe_raise_pod_snippets_impure ()

=head3 maybe_raise_pod_snippets_bad_pairing ($name)

Maybe passes an error of the respective class to the user-supplied C<<
-report_errors >> sub (see L</load>), if the warning and error
settings so dictate (as described in the documentation for the C<<
-named_snippets >> constructor argument).  The $name argument is the
name of the snippet that is in scope at the point of error.

All these methods are implemented in terms of exactly one call to
L</maybe_raise_named_pod_snippets_incident>.

=cut

sub maybe_raise_pod_snippets_multiple {
    my ($self, $name) = @_;
    $self->maybe_raise_named_pod_snippets_incident
        ("multiple", <<"MESSAGE");
Snippet "$name" is defined multiple times.
MESSAGE
}

sub maybe_raise_pod_snippets_overlap {
    my ($self, $name) = @_;
    $self->maybe_raise_named_pod_snippets_incident
        ("overlap", <<"MESSAGE");
Snippet "$name" is defined multiple times.
MESSAGE
}

sub maybe_raise_pod_snippets_impure {
    my ($self) = @_;
    my @names_in_scope = map { qq'"$_"' }
        ($self->in_named_pod_snippet);
    if (@names_in_scope > 1) {
        my $names_in_scope = join(", ", @names_in_scope);
        $self->maybe_raise_named_pod_snippets_incident
        ("impure", <<"MESSAGE");
Snippets $names_in_scope are impure (ie they
contain intervening non-verbatim POD)
MESSAGE
    } else {
        $self->maybe_raise_named_pod_snippets_incident
        ("impure", <<"MESSAGE");
Snippet $names_in_scope[0] is impure (ie it
contains intervening non-verbatim POD)
MESSAGE
    }
}

sub maybe_raise_pod_snippets_bad_pairing {
    my ($self, $name) = @_;
    $self->maybe_raise_named_pod_snippets_incident
        ("bad_pairing", <<"MESSAGE");
Snippet "$name" has mismatched or missing opening and closing markers.
MESSAGE
}

=head3 maybe_raise_named_pod_snippets_incident ($errclass, $message)

Calls L</raise_pod_snippets_incident> with $message if appropriate
given the parser warning and error level settings for C<$errclass>
(one of "impure", "overlap", "bad_pairing" or "multiple").  See the
C<-named_snippets> argument to L</load> for details.

=cut

sub maybe_raise_named_pod_snippets_incident {
    my ($self, $errclass, $message) = @_;

    my $severity = $self->{"-pod_snippets_$errclass"};
    if ((! defined $severity) || ($severity eq "ignore")) {
        return;
    } else {
        $self->raise_pod_snippets_incident($severity, $message);
    }
}

=head2 Fancy accessors

Yes, we want them even in a totally private class: they are so helpful
in making the code easier to understand, debug and refactor.

=head3 in_named_pod_snippet ($name, $boolean)

Tells the parser state machine that we are entering ($boolean true) or
leaving ($boolean false) a POD snippet named $name.  This operation
can cause L</maybe_raise_pod_snippets_overlap> and/or
L</maybe_raise_pod_snippets_bad_pairing> to be invoked as a side effect.

=head3 in_named_pod_snippet ($name)

Returns true iff the parser is currently in the middle of a POD snippet
named $name.

=head3 in_named_pod_snippet ()

Returns true iff the parser is currently in the middle of any named
POD snippet, regardless of the name.  (In array context, returns the
list of all snippet names the parser is in).

=cut

sub in_named_pod_snippet {
    my ($self, @args) = @_;
    $self->{pod_snippets_names_in_scope} ||= {};
    if (@args >= 2) {
        my ($snipname, $bool) = @args;
        if ($bool) { # Entering
            $self->maybe_raise_pod_snippets_multiple($snipname) if
                exists $self->{pod_snippets_names_in_scope}->{$snipname};
            $self->maybe_raise_pod_snippets_overlap($snipname) if
                $self->in_named_pod_snippet;
            $self->maybe_raise_pod_snippets_bad_pairing($snipname) if
                $self->in_named_pod_snippet($snipname);
            $self->{pod_snippets_names_in_scope}->{$snipname} = 1;
        } else { # Leaving
            $self->maybe_raise_pod_snippets_bad_pairing($snipname) if
                ! $self->in_named_pod_snippet($snipname);
            $self->{pod_snippets_names_in_scope}->{$snipname} = 0;
        }
    } elsif (@args == 1) {
        return !!$self->{pod_snippets_names_in_scope}->{$args[0]};
    } else {
        return grep { $self->{pod_snippets_names_in_scope}->{$_} }
            (keys %{$self->{pod_snippets_names_in_scope}});
    }
}

=head3 pod_snippets_names ()

Returns a reference to a newly-constructed (thus unshared) hash whose
keys are the POD snippet names that have been seen by the parser so
far, and the values are true iff we are currently inside a POD snippet
of the corresponding name.

=cut

sub pod_snippets_names {
    return {%{shift->{pod_snippets_names_in_scope} || {}}}
}

=head3 ignoring_pod_snippets ()

=head3 ignoring_pod_snippets ($value)

Gets or sets the "ignoring snippets" flag in the parser state.

=cut

sub ignoring_pod_snippets {
    my ($self, @value) = @_;
    $self->{ignoring_pod_snippets} = $value[0] if @value;
    return $self->{ignoring_pod_snippets};
}

=head3 pod_snippets ()

Returns the parsed snippets as a list that contains undef values and
references to instances of L<Pod::Snippets::_Snippet>.  The undef
values indicate that some non-snippet block or markup was seen at that
point, and that snippets should not be merged by L</as_data> over such
a boundary.

=cut

sub pod_snippets { shift->{pod_snippets} }

=head3 pod_snippets_warnings ()

=head3 pod_snippets_errors ()

Returns the number of times L</pod_snippets_warning>
(resp. L</pod_snippets_error>) was called during the parsing of this
Perl module.  These do B<not> account for warnings and/or errors due
to malformed POD that may be emitted by L<Pod::Parser>.

=head3 raise_pod_snippets_incident ($kind, $message)

Called whenever the parser issues a warning, resp. an error; calls the
user-supplied C<< -report_errors >> sub (see L</load>) or a default
surrogate thereof.  Also increments the relevant warning and error
counters.  $kind is either "warning" or "error" (in lowercase);
$message is the message to print (I18N be screwed).

=cut

# And now for some awesome metaprogramming goodness.
foreach my $property (qw(warnings errors)) {
    my $fieldname = "pod_snippets_$property";
    my $accessor = sub { shift->{$fieldname} || 0 };
    no strict "refs";
    *{$fieldname} = $accessor;
}

sub raise_pod_snippets_incident {
    my ($self, $incident, $message) = @_;
    $self->{-pod_snippets_report_errors}->
        (uc($incident), $message, $self->{-pod_snippets_filename},
         $self->pod_snippets_source_line_number +
         $self->{-pod_snippets_line} - 1);
    $self->{"pod_snippets_${incident}s"}++;
}

=head2 Pod::Snippets::_Snippet

An instance of this class represents one snippet in the POD.
Instances are immutable, and stringifiable for added goodness.

=cut

package Pod::Snippets::_Snippet;

=head3 new ($lineno, $rawtext, $names_set)

Creates and returns a B<Pod::Snippets::_Snippet> object.  $lineno is
the line number where the snippet starts in the original file.
$rawtext is the text of the snippet without any formatting applied:
there may be extraneous whitespace at the beginning and end, and the
ragging is not performed.  $names_set is a reference to a set (that
is, a hash where only the boolean status of the values matter) of all
snippet names that are in scope for this snippet.

=cut

sub new {
    my ($class, $lineno, $rawtext, $names_set) = @_;

    return bless {
                  line => $lineno,
                  text => $rawtext,
                  names => $names_set,
                 }, $class;
}

=head3 stringify ()

Returns the snippet text.  This is also what happens when one
evaluatess the snippet object as a string.

=cut

use overload '""' => "stringify";
sub stringify { shift->{text} }

=head3 is_named ($name)

Returns true iff $name is in scope at this snippet's text location.

=cut

sub is_named { !! shift->{names}->{shift()} }

=head3 line ()

Returns this snippet's line number.

=cut

sub line { shift->{line} }

=head3 append_text ($text)