view release on metacpan or  search on metacpan

inc/My/Module/Build.pm  view on Meta::CPAN

Called as part of this module's startup code, in order to debogosify
the @ARGV array (to be passed as a reference) when we are invoked from
Emacs' M-x perldb. L</ACTION_test> will afterwards be able to take
advantage of the Emacs debugger we run under, by bogosifying the
command line back before invoking the script to test.

=cut

_massage_ARGV(\@ARGV);
sub _massage_ARGV {
    my ($argvref) = @_;
    my @argv = @$argvref;

    return unless ($ENV{EMACS} && (grep {$_ eq "-emacs"} @argv));

    $running_under_emacs_debugger = 1;

    @argv = grep { $_ ne "-emacs" } @argv;
    shift @argv if $argv[0] eq "-d"; # Was gratuitously added by former Emacsen

    # XEmacs foolishly assumes that the second word in the perldb
    # line is a filename and turns it into e.g. "/my/path/test":
     (undef, undef, $argv[0]) = File::Spec->splitpath($argv[0]);

    @$argvref = @argv;
}

=back

=head2 My::Module::Build::PmFilter Ancillary Class

This ancillary class, serving both as an object-oriented interface and
as a default implementation thereof, is the workhorse behind
L</process_pm_files> and L</process_pm_file_if_modified>. It consists
of a very simple filter API to transform the text of .pm files as they
are copied over from lib/ to blib/ during the build process. The
base-class implementation simply replaces copyright placeholders of
the form "(C) DOMQ" with appropriate legalese, and removes the
L<My::Tests::Below> test suite if one is found.

Subclasses of I<My::Module::Build> need only overload
L</new_pm_filter> in order to provide a different implementation of
this .pm filter. The object returned by said overloaded
I<new_pm_filter> needs only obey the API documented below for methods
I<filter> and I<eof_reached>; it may or may not elicit to inherit from
I<My::Module::Build::PmFilter> in order to do so.

=over

=cut

package My::Module::Build::PmFilter;

=item I<new()>

Object constructor. Does nothing in the base class.

=cut

sub new { bless {}, shift }

=item I<filter($line)>

Given $line, a line read from a .pm file in lib, returns a piece of
text that L</process_pm_file_if_modified> should replace this line
with.  Note that it is perfectly appropriate for a filter
implementation to buffer stuff, and therefore not always return
something from I<filter>.

The base class does not buffer. Rather, it substitutes standard
copyright stanzas, and detects the end-of-file on behalf of
L</eof_reached>.

=cut

sub filter {
    my $self = shift;
    local $_ = shift;

    return "" if $self->eof_reached;

    my $copyrightstring =
        sprintf( "Copyright Dominique Quatravaux %d -".
                 " Licensed under the same terms as Perl itself",
                 (localtime(time))[5] + 1900 );

    s/^ (.*)                  # Leading cruft (e.g. comment markers)
      (?:\(C\)|\x{A9})      # "copyright" sign
      (?:[ -])    .*        # spacer
      (?i:DOMQ|Quatravaux)   # Yours truly (case insensitive)
      /$1$copyrightstring/x;
    if (m/^require My::Tests::Below unless caller/) {
        $self->eof_reached(1);
        return "1;\n";
    } else {
        return $_;
    }
}

=item I<eof_reached()>

Shall return true iff the end-of-file is reached and calling
L</process_pm_line> further would just be a waste of time. Called
exactly once by L</process_pm_file_if_modified> after each call to
I<process_pm_line>.

In the base class, I<eof_reached()> is just a passive accessor whose
value is set by L</filter>.

=cut

sub eof_reached {
    my $self = shift;
    if (@_) {
        $self->{eof} = shift;
    } else {
        return $self->{eof};
    }
}

=back

=end internals

=head1 BUGS

The zero-wing easter egg only works through the Makefile.PL
compatibility mode. On the other hand, "./Build your time" would not
sound quite right, would it?

Perhaps the L</Dependent Option Graph> features should be repackaged
as a standalone Module::Build plug-in.

=head1 SEE ALSO

L<My::Tests::Below>

t/maintainer/*.t

=cut

require My::Tests::Below unless caller;

1;

__END__

use Test::More "no_plan";

########### Dependent graph stuff ################

# We keep the tests in a separate package so that if we later decide
# to refactor the dependent graph stuff into a standalone
# Module::Build plug-in, a simple cut-n-paste operation will do the
# job.
do {
    # We re-route the process of creating a Module::Build object to
    # a fake package, so as not to make Module::Build itself part
    # of the tests over the dependent graph stuff:
    local @My::Module::Build::ISA=qw(Fake::Module::Build);

    package Fake::Module::Build;

    sub new { bless {}, shift }

    # Various stuff that is being called by My::Module::Build as part
    # of this test, and that we therefore need to stub out:
    no warnings "redefine";
    local *My::Module::Build::maintainer_mode_enabled = sub { 0 };
    local *My::Module::Build::subclass = sub {
        my ($self, %opts) = @_;
        eval <<'HEADER' . $opts{code}; die $@ if $@;

package Fake::Subclass;
BEGIN { our @ISA=qw(My::Module::Build); }

HEADER
        return "Fake::Subclass";
    };

    sub notes {
        my ($self, $k, @v) = @_;
        if (@v) { $self->{notes}->{$k} = $v[0]; }
        return $self->{notes}->{$k};
    }

    # "batch" version of ->prompt()
    our %answers = ("Install module foo?" => 1);
    sub prompt {
        my ($self, $question) = @_;
        die "Unexpected question $question" if
            (! exists $answers{$question});
        return delete $answers{$question}; # Will not answer twice
        # the same question
    }

    package main_screen; # Do not to pollute the namespace of "main" with
    # the "use" directives below - Still keeping refactoring in mind.

    BEGIN { *write_file = \&My::Module::Build::write_file;
            *read_file  = \&My::Module::Build::read_file; }

    use Test::More;
    use Fatal qw(mkdir chdir);

    local @ARGV = qw(--noinstall-everything);

    my $define_options =
        My::Tests::Below->pod_code_snippet("option-graph");
    $define_options =~ s/\.\.\.//g;
    my $builder = eval $define_options; die $@ if $@;

    isa_ok($builder, "Fake::Module::Build",
           "construction of builder successful");

    is(scalar keys %My::Module::Build::declared_options,
       2, "Number of declarations seen");

    is(scalar(keys %answers), 0, "All questions have been asked");
    ok(! $builder->notes("option:install_everything"),
          "note install_everything");
    ok($builder->notes("option:install_module_foo"),
          "note install_module_foo");
    ok(! $builder->option_value("install_everything"),