Alien-Selenium
view release on metacpan or search on metacpan
inc/Pod/Snippets.pm view on Meta::CPAN
=for metatests "named_snippets multiple error" end
=item B<< -named_snippets => "warn_overlap" >>
Raises a warning if named snippets overlap in any way.
=item B<< -named_snippets => "warn_bad_pairing" >>
Raises a warning if opening and closing markup for named snippets is
improperly paired (eg opening or closing twice, or forgetting to close
before the end of the file).
=item B<< -named_snippets => "error_impure" >>
=item B<< -named_snippets => "error_multiple" >>
=item B<< -named_snippets => "error_overlap" >>
=item B<< -named_snippets => "error_bad_pairing" >>
Same as the C<warn_> counterparts above, but cause errors instead of
warnings.
=item B<< -named_snippets => "ignore_impure" >>
=item B<< -named_snippets => "ignore_multiple" >>
=item B<< -named_snippets => "ignore_overlap" >>
=item B<< -named_snippets => "ignore_bad_pairing" >>
Ignores the corresponding dubious constructs described above. The
default behavior is C<< -named_snippets => "warn_bad_pairing" >> and
ignore the rest.
=item B<< -named_snippets => "strict" >>
Equivalent to C<< (-named_snippets => "error_overlap", -named_snippets
=> "error_impure", -named_snippets => "error_multiple",
-named_snippets => "error_bad_pairing") >>.
=back
Note that the correctness of the POD to be parsed is a prerequisite;
in other words, I<Pod::Snippets> won't touch the error management
knobs of the underlying L<Pod::Parser> object.
Also, note that the parser strictness options such as
B<-named_snippets> have no effect on the semantics; they merely alter
its response (ignore, warning or error) to the aforementioned dubious
constructs. In any case, the parser will soldier on until the end of
the file regardless of the number of errors seen; however, it will
disallow further processing of the snippets if there were any errors
(see L</errors>).
=cut
sub load {
my ($class, $source, @opts) = @_;
my $self = bless {}, $class;
$self->{start_line} = 1;
$self->{filename} = "$source" unless (ref($source) eq "GLOB" ||
eval { $source->can("getline") });
undef $@;
# Grind the syntactic sugar to dust:
my %opts = (-line => 1, -filename => $self->filename,
-report_errors => sub {
my ($severity, $text, $file, $line) = @_;
warn <<"MESSAGE";
$severity: $text
in $file line $line
MESSAGE
}, -markup => "Pod::Snippets",
-bad_pairing => "warning");
while(my ($k, $v) = splice @opts, 0, 2) {
if ($k eq "-named_snippets") {
if ($v eq "strict") {
$opts{"-$_"} = "error" foreach
(qw(overlap impure multiple bad_pairing));
} elsif ($v =~ m|^ignore_(.*)|) {
$opts{"-$1"} = "ignore";
} elsif ($v =~ m|^error_(.*)|) {
$opts{"-$1"} = "error";
} elsif ($v =~ m|^warn(ing)?_(.*)|) {
$opts{"-$2"} = "warning";
}
} elsif ($k eq "-line") {
$self->{start_line} = $v;
$opts{$k} = $v;
} else {
$opts{$k} = $v;
}
}
# Run the parser:
my $parser = "${class}::_Parser"->new_for_pod_snippets(%opts);
if ($self->{filename}) {
$parser->parse_from_file($self->{filename}, undef);
} else {
$parser->parse_from_filehandle($source, undef);
}
$parser->finalize_pod_snippets();
# Extract the relevant bits from it:
$self->{unmerged_snippets} = $parser->pod_snippets;
$self->{warnings} = $parser->pod_snippets_warnings;
$self->{errors} = $parser->pod_snippets_errors;
return $self;
}
=head2 parse ($string, -opt1 => $val1, ...)
Same as L</load>, but works from a Perl string instead of a file
descriptor. The named options are the same as in I<load()>, but
consider using C<< -filename >> as I<parse()> is in no position to
guess it.
=cut
sub parse {
my ($class, $string, @args) = @_;
return $class->load(Pod::Snippets::LineFeeder->new($string), @args);
package Pod::Snippets::LineFeeder;
sub new {
my ($class, $string) = @_;
my $nl = $/; # Foils smarter-than-thou regex parser
return bless { lines => [ $string =~ m{(.*(?:$nl|$))}g ] };
}
sub getline { shift @{shift->{lines}} }
}
=head1 ACCESSORS
=head2 filename ()
Returns the name of the file to use for C<#line> lines in L</as_code>.
The default behavior is to use the filename passed as the $source
argument, or if it was not a filename, use the string "pod snippet"
instead.
=cut
sub filename { shift->{filename} || "pod snippet" }
=head2 warnings ()
Returns the number of warnings that occured during the parsing of the
POD.
=head2 errors ()
Returns the number of errors that occured during the parsing of the
POD. If that number is non-zero, then all accessors described below
will throw an exception instead of performing.
=cut
sub warnings { shift->{warnings} }
sub errors { shift->{errors} }
=head2 as_data ()
Returns the snippets in "data" format: that is, the return value is
ragged to the left by suppressing a constant number of space
characters at the beginning of each snippet. (If tabs are present in
the POD, they are treated as being of infinite length; that is, the
ragging algorithm does not eat them or replace them with spaces.)
A snippet is defined as a series of subsequent verbatim POD paragraphs
with only B<Pod::Snippets> markup, if anything, intervening in
between. That is, I<as_data()>, given the following POD in input:
=for metatests "as_data multiple blocks input" begin
my $a = new The::Brain;
=begin test
# Just kidding. We can't do that, it's too dangerous.
$a = new Pinky;
=end test
=for test ignore
system("/sbin/reboot");
inc/Pod/Snippets.pm view on Meta::CPAN
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.
MESSAGE
}
=head2 _merged_snippets ()
Returns roughly the same thing as L</pod_snippets> in
L</Pod::Snippets::_Parser>, except that leading and trailing
whitespace is trimmed (updating the line counters appropriately),
names are discarded and snippets are merged together (with appropriate
padding using $/) according to the semantics set forth in L</as_data>.
This method has a cache.
=cut
sub _merged_snippets {
my ($self) = @_;
$self->{merged_snippets} ||= do {
my @snippets;
foreach my $snip (@{$self->{unmerged_snippets}}) {
if (! defined($snip)) {
push @snippets, undef if defined $snippets[-1];
} elsif (! @snippets) {
push @snippets, $snip;
} elsif (! defined($snippets[-1])) {
$snippets[-1] = $snip;
} else {
# The merger case.
my $prevstartline = $snippets[-1]->line();
my $newlines_to_add = $snip->line - $prevstartline
- _number_of_newlines_in($snippets[-1]);
if ($newlines_to_add < 0) {
my $filename = $self->filename();
warn <<"ASSERTION_FAILED" ;
Pod::Snippets: problem counting newlines at $filename
near line $prevstartline (trying to skip $newlines_to_add lines)
Output will be desynchronized.
ASSERTION_FAILED
$newlines_to_add = 0;
inc/Pod/Snippets.pm view on Meta::CPAN
=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)
Computes and returns a new snippet that has extra $text appended at
the end. This is also what happens when one uses the L<perlop/.>
operator on a snippet.
=cut
use overload '.' => "append_text";
sub append_text {
my ($self, $text) = @_;
return bless {
text => "$self->{text}" . "$text",
map { ($_ => $self->{$_}) } (qw(line names)),
}, ref($self);
}
=head3 names_set ()
Returns the $names_set parameter to L</new>.
=cut
sub names_set { shift->{names} }
=end internals
=head1 SEE ALSO
L<Test::Pod::Snippets>
=head1 AUTHOR
Dominique QUATRAVAUX, C<< <domq@cpan.org> >>
=head1 BUGS
Please report any bugs or feature requests to
C<bug-pod-snippet@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Pod-Snippet>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.
=head1 ACKNOWLEDGEMENTS
Yanick Champoux <yanick@CPAN.org> is the author of
L<Test::Pod::Snippets> which grandfathers this module.
=head1 COPYRIGHT & LICENSE
Copyright 2007 Dominique QUATRAVAUX, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of Pod::Snippets
( run in 1.217 second using v1.01-cache-2.11-cpan-6b5c3043376 )