view release on metacpan or  search on metacpan

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

            $snippets[$i] = Pod::Snippets::_Snippet->new
                ($line, $text, $snippets[$i]->names_set);
        }

        \@snippets;
    };

    return @{$self->{merged_snippets}};
}

=head2 _number_of_newlines_in($string)

This function (B<not> a method) returns the number of times $/ is
found in $string.

=cut

sub _number_of_newlines_in {
    my @occurences = shift =~ m|($/)|gs;
    return scalar @occurences;
}

=head1 Pod::Snippets::_Parser

This class is a subclass to L<Pod::Parser>, that builds appropriate
state on behalf of a I<Pod::Snippets> object.

=cut

package Pod::Snippets::_Parser;

use base "Pod::Parser";

=head2 new_for_pod_snippets (-opt1 => $val1, ...)

An alternate constructor with a different syntax suited for calling
from I<Pod::Snippets>.  Available named options are:

=over

=item B<< -markup => $string >>

=item B<< -report_errors => $sub >>

=item B<< -filename => $filename >>

=item B<< -line => $line >>

Same as in L</load>, except that all these options are mandatory and
therefore caller should substitute appropriate default values if need
be.

=item B<< -impure => "ignore" >>

=item B<< -impure => "warn" >>

=item B<< -impure => "error" >>

=item B<< -overlap => "ignore" >> and so on

The parse flags to use for handling errors, properly decoded from the
B<-named_snippets> named argument to L</load>.

=back

=cut

sub new_for_pod_snippets {
    my ($class, %opts) = @_;

    my $self = $class->new;
    while(my ($k, $v) = each %opts) {
        $k =~ s/^(-?)(.*)$/$1pod_snippets_$2/;
        $self->{$k} = $v;
    }
    return $self;
}

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

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

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.