Alien-Selenium

 view release on metacpan or  search on metacpan

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

    my $result = eval $code_snippet; die $@ if $@;

    like($result->what_happen(), qr/bomb/);

=for metatests "synopsis test script" end

The Perl code that we want to extract snippets from might look like
this:

=for metatests "synopsis POD" begin

    package Zero::Wing;

    =head1 NAME

    Zero::Wing - For great justice!

    =head1 SYNOPSIS

    =for test "synopsis" begin

       use Zero::Wing;

       my $capitain = Zero::Wing->capitain;

    =for test "synopsis" end

    =cut

    # ...

    1;

=for metatests "synopsis POD" end

=head1 DESCRIPTION

This class is a very simple extension of L<Pod::Parser> that extracts
POD snippets from Perl code, and pretty-prints it so as to make it
useable from other Perl code.  As demonstrated above, B<Pod::Snipets>
is immediately useful to test-driven-development nutcases who want to
put every single line of Perl code under test, including code that is
in the POD (typically a SYNOPSIS section).  There are other uses, such
as storing a piece of information that is both human- and
machine-readable (eg an XML schema) simultaneously as documentation
and code.

=head2 Using Pod::Snippets for unit testing

The L</SYNOPSIS> demonstrates how to use B<Pod::Snippets> to grab a
piece of POD and execute it with L<perlfunc/eval>.  This can readily
be done using your usual unit testing methodology, without too much
ajusting if any.  This approach has some advantages over other
code-in-POD devices such as L<Pod::Tested> and L<Test::Inline>:

=over

=item *

There is no preprocessing step involved, hence no temp files and no
loss of hair in the debugger due to line renumbering.

=item *

Speaking of which, L</as_code> prepends an appropriate C<#line> if
possible, so you can single-step through your POD (yow!).

=back

The Pod-Snippets CPAN distribution consists of a single Perl file, and
has no dependencies besides what comes with a standard Perl 5.8.x.  It
is therefore easy to embed into your own module so that your users
won't need to install B<Pod::Snippets> by themselves before running
your test suite.  All that remains to do is to select the right
options to pass to L</load> as part of an appropriately named wrapper
function in your test library.

=head2 Snippet Syntax

B<Pod::Snippets> only deals with verbatim portions of the POD (that
is, as per L<perlpod>, paragraphs that start with whitespace at the
right) and custom markup starting with C<=for test>, C<=begin test> or
C<=end test>; it discards the rest (block text, actual Perl code,
character markup such as BE<lt>E<gt>, =head's and so on).  The keyword
"test" in C<=for test> and C<=begin test> can be replaced with
whatever one wants, using the C<-markup> argument to L</load>.
Actually the default value is not even "test"; nonetheless let's
assume you are using "test" yourself for the remainder of this
discussion.  The following metadata markup is recognized:

=over

=item B<=for test ignore>

Starts ignoring all POD whatsoever.  Verbatim portions of the POD are
no longer stashed by B<Pod::Snippets> until remanded by a subsequent
C<=for test>.

=item B<=for test>

Cancels the effect of an ongoing C<=for test ignore> directive.

=item B<=for test "foo" begin>

=item B<=for test "foo" end>

These signal the start and end of a I<named> POD snippet, that can
later be fetched by name using L</named>.  Unless countermanded by
appropriate parser options (see L</load>), named POD snippets can
nest freely (even badly).

=item B<=begin test>

=item B<=end test>

The POD between these markers will be seen by B<Pod::Snippets>, but
not by other POD formatters.  Otherwise has no effect on the naming or
ignoring of snippets; in particular, if the contents of the section is
not in POD verbatim style, it still gets ignored.

=item B<=begin test "foo">

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

          $a->conquer_world();
        }

=for metatests "as_data multiple blocks input" end

would return (in list context)

=for metatests "as_data multiple blocks return" begin

  (<<'FIRST_SNIPPET', <<'SECOND_SNIPPET');
  my $a = new The::Brain;



    # Just kidding. We can't do that, it's too dangerous.
    $a = new Pinky;
  FIRST_SNIPPET
  if ($a->has_enough_cookies()) {
    $a->conquer_world();
  }
  SECOND_SNIPPET

=for metatests "as_data multiple blocks return" end

Notice how the indentation is respected snippet-by-snippet; also,
notice that the FIRST_SNIPPET has been padded with an appropriate
number of carriage returns to replace the B<Pod::Snippets> markup, so
that the return value is line-synchronized with the original POD.
However, leading and trailing whitespace is trimmed, leaving only
strings that starts with a nonblank line and end with a single
newline.

In scalar context, returns the blocks joined with a single newline
character ("\n"), thus resulting in a single piece of text where the
blocks are joined by exactly one empty line (and which as a whole is
no longer line-synchronized with the source code, of course).

=cut

sub as_data {
    my ($self) = @_;
    $self->_block_access_if_errors();

    my @retval = map {
        # This may be a pedestrian and sub-optimal way of doing the
        # ragging, but it sure is concise:
        until (m/^\S/m) { s/^ //gm or last; };
        "$_";
    } ($self->_merged_snippets);

    return wantarray ? @retval : join("\n", @retval);
}

=head2 as_code ()

Returns the snippets formatted as code, that is, like L</as_data>,
except that each block is prepended with an appropriate C<#line>
statement that Perl can interpret to renumber lines.  For instance,
these statements would cause Perl to Do The Right Thing if one
compiles the snippets as code with L<perlfunc/eval> and then runs it
under the Perl debugger.

=cut

sub as_code {
    my ($self) = @_;
    $self->_block_access_if_errors();
    my @retval = $self->as_data;

    foreach my $i (0..$#retval) {
        my $file = $self->filename;
        my $line = ($self->_merged_snippets)[$i]->line() +
            $self->{start_line} - 1;
        $retval[$i] = <<"LINE_MARKUP" . $retval[$i];
#line $line "$file"
LINE_MARKUP
    }
    return wantarray ? @retval : join("\n", @retval);
}

=head2 named ($name)

Returns a clone of this B<Pod::Snippet> object, except that it only
knows about the snippet (or snippets) that are named $name.  In the
most lax settings for the parser, this means: any and all snippets
where an C<=for test "$name" begin> (or C<=begin test "$name">) had
been open, but not yet closed with C<=for test "$name" end> (or C<=end
test "$name">).  Returns undef if no snippet named $name was seen at
all.

=cut

sub named {
    my ($self, $name) = @_;
    $self->_block_access_if_errors();
    my @snippets_with_this_name = grep {
             !defined($_) || $_->names_set->{$name}
         } (@{$self->{unmerged_snippets}});
    return if ! grep { defined } @snippets_with_this_name;
    return bless
        {
         unmerged_snippets => \@snippets_with_this_name,
         map { exists $self->{$_} ? ($_ => $self->{$_}) : () }
         (qw(warnings errors filename start_line) )
         # Purposefully do not transfer other fields such as
         # ->{merged_snippets}
        }, ref($self);
}

=begin internals

=head2 _block_access_if_errors ()

Throws an exception if L</errors> returns a nonzero value.  Called by
every read accessor except L</warnings> and I<errors()>.

=cut

sub _block_access_if_errors {
    die <<"MESSAGE" if shift->errors;
Cannot fetch parse results from Pod::Snippets with errors.

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

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} || {}}}
}