Use class_of for roles
[gitmo/Moose.git] / author / extract-inline-tests
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 {
7     package My::Extract;
8
9     use base 'Test::Inline::Extract';
10
11     # This extracts the SYNOPSIS in addition to code specifically
12     # marked for testing
13     my $search = qr/
14                 (?:^|\n)                           # After the beginning of the string, or a newline
15                 (                                  # ... start capturing
16                                                    # EITHER
17                         package\s+                            # A package
18                         [^\W\d]\w*(?:(?:\'|::)[^\W\d]\w*)*    # ... with a name
19                         \s*;                                  # And a statement terminator
20                 |
21                         =head1[ \t]+SYNOPSIS\n
22                         .*?
23                         (?=\n=)
24                 |                                  # OR
25                         =for[ \t]+example[ \t]+begin\n        # ... when we find a =for example begin
26                         .*?                                   # ... and keep capturing
27                         \n=for[ \t]+example[ \t]+end\s*?      # ... until the =for example end
28                         (?:\n|$)                              # ... at the end of file or a newline
29                 |                                  # OR
30                         =begin[ \t]+(?:test|testing)(?:-SETUP)? # ... when we find a =begin test or testing
31                         .*?                                     # ... and keep capturing
32                         \n=end[ \t]+(?:test|testing)(?:-SETUP)? # ... until an =end tag
33                         .*?
34                         (?:\n|$)                              # ... at the end of file or a newline
35                 )                                  # ... and stop capturing
36                 /isx;
37
38     sub _elements {
39         my $self     = shift;
40         my @elements = ();
41         while ( $self->{source} =~ m/$search/go ) {
42             my $elt = $1;
43
44             # A hack to turn the SYNOPSIS into something Test::Inline
45             # doesn't barf on
46             if ( $elt =~ s/=head1[ \t]+SYNOPSIS/=begin testing-SETUP\n\n{/ ) {
47                 $elt .= "}\n\n=end testing-SETUP";
48             }
49
50             # It seems like search.cpan doesn't like a name with
51             # spaces after =begin. bleah, what a mess.
52             $elt =~ s/testing-SETUP/testing SETUP/g;
53
54             push @elements, $elt;
55         }
56
57         # If we have just one element it's a SYNOPSIS, so there's no
58         # tests.
59         return unless @elements > 1;
60
61         if ( @elements && $self->{source} =~ /=head1 NAME\n\n(Moose::Cookbook\S+)/ ) {
62             unshift @elements, 'package ' . $1 . ';';
63         }
64
65         (List::Util::first { /^=/ } @elements) ? \@elements : '';
66     }
67 }
68
69 {
70     package My::Content;
71
72     use base 'Test::Inline::Content::Default';
73
74     sub process {
75         my $self = shift;
76
77         my $base = $self->SUPER::process(@_);
78
79         $base =~ s/(\$\| = 1;)/use Test::Exception;\n$1/;
80
81         return $base;
82     }
83 }
84
85 use File::Find::Rule;
86 use Test::Inline;
87
88
89 my $target = 't/000_recipes';
90
91 for my $t_file ( File::Find::Rule->file->name(qr/^moose_cookbook_\.t$/)->in($target) ) {
92     unlink $t_file or die "Cannot unlink $t_file: $!";
93 }
94
95 my $inline = Test::Inline->new(
96     verbose        => 1,
97     readonly       => 1,
98     output         => $target,
99     ExtractHandler => 'My::Extract',
100     ContentHandler => 'My::Content',
101 );
102
103 for my $pod (
104     File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) {
105     $inline->add($pod);
106 }
107
108 $inline->save;