Move extract-inline-tests to author/

[gitmo/Moose.git] / author / extract-inline-tests

diff --git a/author/extract-inline-tests b/author/extract-inline-tests
new file mode 100755 (executable)
index 0000000..d91fa43
--- /dev/null
+++ b/author/extract-inline-tests
@@ -0,0 +1,103 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+{
+    package My::Extract;
+
+    use base 'Test::Inline::Extract';
+
+    # This extracts the SYNOPSIS in addition to code specifically
+    # marked for testing
+    my $search = qr/
+               (?:^|\n)                           # After the beginning of the string, or a newline
+               (                                  # ... start capturing
+                                                  # EITHER
+                       package\s+                            # A package
+                       [^\W\d]\w*(?:(?:\'|::)[^\W\d]\w*)*    # ... with a name
+                       \s*;                                  # And a statement terminator
+                |
+                        =head1[ \t]+SYNOPSIS\n
+                        .*?
+                        (?=\n=)
+               |                                  # OR
+                       =for[ \t]+example[ \t]+begin\n        # ... when we find a =for example begin
+                       .*?                                   # ... and keep capturing
+                       \n=for[ \t]+example[ \t]+end\s*?      # ... until the =for example end
+                       (?:\n|$)                              # ... at the end of file or a newline
+               |                                  # OR
+                       =begin[ \t]+(?:test|testing)\b        # ... when we find a =begin test or testing
+                       .*?                                   # ... and keep capturing
+                       \n=end[ \t]+(?:test|testing)\s*?      # ... until an =end tag
+                       (?:\n|$)                              # ... at the end of file or a newline
+               )                                  # ... and stop capturing
+               /isx;
+
+    sub _elements {
+       my $self     = shift;
+       my @elements = ();
+       while ( $self->{source} =~ m/$search/go ) {
+            my $elt = $1;
+
+            # A hack to turn the SYNOPSIS into something Test::Inline
+            # doesn't barf on
+            if ( $elt =~ s/=head1[ \t]+SYNOPSIS/=begin testing SETUP\n\n{/ ) {
+                $elt .= "}\n\n=end testing SETUP";
+            }
+
+            push @elements, $elt;
+       }
+
+        # If we have just one element it's a SYNOPSIS, so there's no
+        # tests.
+        return unless @elements > 1;
+
+        if ( @elements && $self->{source} =~ /=head1 NAME\n\n(Moose::Cookbook\S+)/ ) {
+            unshift @elements, 'package ' . $1 . ';';
+        }
+
+       (List::Util::first { /^=/ } @elements) ? \@elements : '';
+    }
+}
+
+{
+    package My::Content;
+
+    use base 'Test::Inline::Content::Default';
+
+    sub process {
+        my $self = shift;
+
+        my $base = $self->SUPER::process(@_);
+
+        $base =~ s/(\$\| = 1;)/use Test::Exception;\n$1/;
+
+        return $base;
+    }
+}
+
+use File::Find::Rule;
+use Test::Inline;
+
+
+my $target = 't/000_recipes';
+
+for my $t_file ( File::Find::Rule->file->name(qr/^moose_cookbook_\.t$/)->in($target) ) {
+    unlink $t_file or die "Cannot unlink $t_file: $!";
+}
+
+my $inline = Test::Inline->new(
+    verbose        => 1,
+    readonly       => 1,
+    output         => $target,
+    ExtractHandler => 'My::Extract',
+    ContentHandler => 'My::Content',
+);
+
+for my $pod (
+    File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) {
+    $inline->add($pod);
+}
+
+$inline->save;