SF.net SVN: gar:[23696] csw/mgar/gar/v2/bin/filemerger
claudio_sf at users.sourceforge.net
claudio_sf at users.sourceforge.net
Fri May 23 15:17:30 CEST 2014
Revision: 23696
http://sourceforge.net/p/gar/code/23696
Author: claudio_sf
Date: 2014-05-23 13:17:28 +0000 (Fri, 23 May 2014)
Log Message:
-----------
First filemerger implementation
Added Paths:
-----------
csw/mgar/gar/v2/bin/filemerger
Added: csw/mgar/gar/v2/bin/filemerger
===================================================================
--- csw/mgar/gar/v2/bin/filemerger (rev 0)
+++ csw/mgar/gar/v2/bin/filemerger 2014-05-23 13:17:28 UTC (rev 23696)
@@ -0,0 +1,9724 @@
+#!/opt/csw/bin/perl
+###!/usr/bin/env perl # We need a perl > 5.10
+
+# This chunk of stuff was generated by App::FatPacker. To find the original
+# file's code, look for the end of this BEGIN block or the string 'FATPACK'
+BEGIN {
+my %fatpacked;
+
+$fatpacked{"Devel/GlobalDestruction.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DEVEL_GLOBALDESTRUCTION';
+ package Devel::GlobalDestruction;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '0.12';
+
+ use Sub::Exporter::Progressive -setup => {
+ exports => [ qw(in_global_destruction) ],
+ groups => { default => [ -all ] },
+ };
+
+ # we run 5.14+ - everything is in core
+ #
+ if (defined ${^GLOBAL_PHASE}) {
+ eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1'
+ or die $@;
+ }
+ # try to load the xs version if it was compiled
+ #
+ elsif (eval {
+ require Devel::GlobalDestruction::XS;
+ no warnings 'once';
+ *in_global_destruction = \&Devel::GlobalDestruction::XS::in_global_destruction;
+ 1;
+ }) {
+ # the eval already installed everything, nothing to do
+ }
+ else {
+ # internally, PL_main_cv is set to Nullcv immediately before entering
+ # global destruction and we can use B to detect that. B::main_cv will
+ # only ever be a B::CV or a B::SPECIAL that is a reference to 0
+ require B;
+ eval 'sub in_global_destruction () { ${B::main_cv()} == 0 }; 1'
+ or die $@;
+ }
+
+ 1; # keep require happy
+
+
+ __END__
+
+ =head1 NAME
+
+ Devel::GlobalDestruction - Provides function returning the equivalent of
+ C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls.
+
+ =head1 SYNOPSIS
+
+ package Foo;
+ use Devel::GlobalDestruction;
+
+ use namespace::clean; # to avoid having an "in_global_destruction" method
+
+ sub DESTROY {
+ return if in_global_destruction;
+
+ do_something_a_little_tricky();
+ }
+
+ =head1 DESCRIPTION
+
+ Perl's global destruction is a little tricky to deal with WRT finalizers
+ because it's not ordered and objects can sometimes disappear.
+
+ Writing defensive destructors is hard and annoying, and usually if global
+ destruction is happening you only need the destructors that free up non
+ process local resources to actually execute.
+
+ For these constructors you can avoid the mess by simply bailing out if global
+ destruction is in effect.
+
+ =head1 EXPORTS
+
+ This module uses L<Sub::Exporter::Progressive> so the exports may be renamed,
+ aliased, etc. if L<Sub::Exporter> is present.
+
+ =over 4
+
+ =item in_global_destruction
+
+ Returns true if the interpreter is in global destruction. In perl 5.14+, this
+ returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, detects it using
+ the value of C<PL_main_cv> or C<PL_dirty>.
+
+ =back
+
+ =head1 AUTHORS
+
+ Yuval Kogman E<lt>nothingmuch at woobling.orgE<gt>
+
+ Florian Ragwitz E<lt>rafl at debian.orgE<gt>
+
+ Jesse Luehrs E<lt>doy at tozt.netE<gt>
+
+ Peter Rabbitson E<lt>ribasushi at cpan.orgE<gt>
+
+ Arthur Axel 'fREW' Schmidt E<lt>frioux at gmail.comE<gt>
+
+ Elizabeth Mattijsen E<lt>liz at dijkmat.nlE<gt>
+
+ Greham Knop E<lt>haarg at haarg.orgE<gt>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 2008 Yuval Kogman. All rights reserved
+ This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
+ =cut
+DEVEL_GLOBALDESTRUCTION
+
+$fatpacked{"FileMerger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILEMERGER';
+ package FileMerger;
+
+ use Moo;
+ use FileMerger::FS::FileOperator;
+ use FileMerger::FS::HardLinks;
+
+ # Instance variables
+
+ has 'src_dirs' => ( # arrayref
+ is => 'ro',
+ required => 1,
+ );
+
+ has 'target_dir' => ( # string
+ is => 'ro',
+ required => 1,
+ );
+
+ has 'excl_lit' => ( # arrayref
+ is => 'rw',
+ lazy => 1,
+ );
+
+ has 'excl_rx' => ( # arrayref
+ is => 'rw',
+ lazy => 1,
+ );
+
+ has 'ren_rx' => ( # hashref
+ is => 'rw',
+ lazy => 1,
+ );
+
+ has 'conflicts' => ( # arrayref
+ is => 'rwp',
+ default => sub { [] }
+ , # so we don't need to test for undef, only to elements
+ init => undef,
+ );
+
+ has 'skipped' => ( # arrayref
+ is => 'rwp',
+ default => sub { [] }
+ , # so we don't need to test for undef, only to elements
+ init => undef,
+ );
+
+ has '_hardlinks_obj' => (
+ is => 'ro',
+ builder => '_build__hardlinks_obj',
+ lazy => 1, # we need the rest of $self first
+ );
+
+
+ # Instance related
+ sub _build__hardlinks_obj {
+ my $self = shift;
+ my $hl = FileMerger::FS::HardLinks->new( src_dirs => $self->src_dirs );
+ return $hl;
+ }
+
+ # Methods
+
+ sub merge_dirs {
+ my $self = shift;
+ my $fs = FileMerger::FS::FileOperator->new(
+ src_dirs => $self->src_dirs,
+ target_dir => $self->target_dir,
+ hardlinks_obj => $self->_hardlinks_obj,
+ );
+ $fs->excl_lit( $self->excl_lit ) if (defined $self->excl_lit);
+ $fs->excl_rx( $self->excl_rx ) if (defined $self->excl_rx);
+ $fs->ren_rx( $self->ren_rx ) if (defined $self->ren_rx);
+ eval { $fs->walk_tree() };
+ return $@ if $@; # Return inmedialtely when fs problems encountered
+
+ # give unique errors
+ my %unique_conflicts = map { $_, 1 } @{ $fs->conflicts };
+ my %unique_skipped = map { $_, 1 } @{ $fs->skipped };
+ my @unique_conflicts = keys %unique_conflicts;
+ my @unique_skipped = keys %unique_skipped;
+
+ $self->_set_conflicts( \@unique_conflicts );
+ $self->_set_skipped( \@unique_skipped );
+ return undef;
+ }
+
+ sub merge_headers {
+
+ # TODO: to be implemented
+ return;
+ }
+
+
+ 1;
+FILEMERGER
+
+$fatpacked{"FileMerger/FS/FileOperator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILEMERGER_FS_FILEOPERATOR';
+ package FileMerger::FS::FileOperator;
+
+ #use Data::Printer; ## DEBUG
+
+ use Moo;
+ with 'FileMerger::FS::Transversable';
+
+ use File::Basename;
+ use File::Copy qw/cp/;
+ use File::Path qw(make_path);
+ use File::Compare;
+ use File::Spec;
+ use File::stat;
+ use POSIX qw(mkfifo);
+
+ # Instance variables
+ has 'hardlinks_obj' => ( # is an FileMerger::FS::HardLinks obj
+ is => 'rw',
+ required => 1,
+ );
+
+ has 'target_dir' => ( # dir must exist, calling class must make sure
+ is => 'ro',
+ required => 1,
+ trigger => 1, # Create dir if not present
+ );
+
+ has 'conflicts' => (
+ is => 'rwp',
+ default => sub { [] },
+ lazy => 1,
+ );
+
+ has '_src_rx' => ( # is a quoted regex }
+ is => 'ro',
+ builder => '_build__src_rx',
+ lazy => 1,
+ );
+
+ has 'ren_rx' => ( # hashref: rx -> replacement
+ is => 'rw',
+
+ # default => sub { {} },
+ );
+
+ ### Methods
+
+ # Instance related
+
+ sub _build__src_rx {
+ my $self = shift;
+ my $src_str = "";
+ my $id_count = scalar @{ $self->src_dirs } - 1;
+ for my $id ( 0 .. $id_count ) {
+ $src_str .= $self->src_dirs->[$id];
+ $src_str .= '|' if ( $id < $id_count );
+ }
+ return qr{$src_str};
+ }
+
+ sub _trigger_target_dir {
+ my ( $self, $target_dir ) = @_;
+ if ( !-d $target_dir ) {
+ print 'INFO: creating the supplied target directory '
+ . $target_dir . ".\n";
+ make_path($target_dir) or die($!);
+ }
+ }
+
+ # Overrides
+
+ sub _wanted() {
+ my $self = shift;
+ return if ( $_ eq '.' ); # skip top directory
+ return if $self->_to_skip($File::Find::name);
+ my $newpath = $self->_get_newpath($File::Find::name);
+
+ # Let handle the different expected filetypes
+ if ( -d $File::Find::name ) { # directory
+ $self->_create_dir( $File::Find::name, $newpath );
+ }
+ elsif ( -p $File::Find::name ) { # FIFO
+ $self->_create_fifo( $File::Find::name, $newpath );
+ }
+ elsif ( -l $File::Find::name ) { # syslink
+ $self->_create_softlink( $File::Find::name, $newpath );
+ }
+ else {
+ # We treat everything else as a file
+ # We need to check if it's a hardlink, we create the related hardlinks
+ if ( $self->_is_hardlink($File::Find::name) ) {
+ $self->_create_hardlink( $File::Find::name, $newpath );
+ }
+ else { $self->_copy_file( $File::Find::name, $newpath ); }
+ }
+ }
+
+ # Internal
+
+ # plink.pl forces 0755 / 0644 modes
+ # Method left here in case this changes
+ # sub _check_perms {
+ # my ( $self, $lpath, $rpath ) = @_;
+ # my $st_l = stat($lpath) or die($!);
+ # my $st_r = stat($rpath) or die($!);
+ # my $perms_ok = 1;
+ # for my $method ( 'mode', 'uid', 'gid' ) {
+ # if ( $st_l->$method != $st_r->$method ) { # different permissions
+ # $perms_ok = 0;
+ # }
+ # }
+ # return $perms_ok;
+ # }
+
+ sub _copy_file {
+ my ( $self, $lfile, $rfile ) = @_;
+ print "Copying " . $lfile . " to " . $rfile . ".\n";
+ $self->_create_dir( dirname($rfile) );
+ if ( !-e $rfile ) {
+ cp( $lfile, $rfile ) or die($!);
+ }
+ else {
+ if ( compare( $lfile, $rfile ) != 0 ) {
+ push @{ $self->conflicts }, "$lfile (conflicting content)";
+ print STDERR "WARNING: $lfile conflicts with file at target.\n";
+ }
+ else {
+ print "INFO: $lfile is already at target directory. Skipping.\n";
+ }
+ }
+ }
+
+ sub _create_dir {
+ my ( $self, $dir ) = @_;
+
+ if ( -d $dir ) {
+
+ # my $perms_ok = $self->_check_perms( $lpath, $rpath );
+ # if ( !$perms_ok ) {
+ # push @{ $self->conflicts }, $lpath . ' (directory permissions)';
+ # print STDERR
+ # "WARNING: directory $lpath has conflicting permissions.\n";
+ # }
+ chmod( 0755, $dir ) or die($!);
+ return;
+ }
+
+ my $error;
+ print "Creating directory $dir.\n";
+ make_path(
+ $dir,
+ {
+ verbose => 0,
+ mode => 0755,
+
+ #uid => $st_l->uid,
+ #group => $st_l->gid,
+ error => \$error
+ }
+ );
+ if (@$error) {
+ die("Directory $dir can not be created: @$error");
+ }
+ }
+
+ sub _create_fifo {
+ my ( $self, $lfifo, $rfifo ) = @_;
+ $self->_create_dir( dirname($rfifo) );
+ mkfifo( $rfifo, ( stat($lfifo) )[2] ) or die($!);
+ }
+
+ sub _create_softlink {
+ my ( $self, $llink, $rlink ) = @_;
+ $self->_create_dir( dirname($rlink) );
+
+ # Find out where we should point to in new target directory
+ my $llink_source = readlink($llink); # get the link target
+
+ # Sadly, syslinks are also relative:
+ #claudio at adelaide:~/Code/FileMerger/lib$ ls -la /var/tmp/src/f3softlink /var/tmp/src/d1lalasoft
+ #lrwxrwxrwx 1 claudio claudio 22 mei 20 13:35 /var/tmp/src/d1lalasoft -> /var/tmp/src/d1/dilala
+ #lrwxrwxrwx 1 claudio claudio 2 mei 20 13:28 /var/tmp/src/f3softlink -> f3
+
+ if ( !File::Spec->file_name_is_absolute($llink_source) ) {
+ $llink_source = File::Spec->rel2abs($llink_source);
+ }
+ my $rlink_source =
+ $self->_get_newpath($llink_source); # redirect to new path
+
+ # Create the link
+ if ( !-e -f $rlink ) {
+ print "Creating symlink $rlink -> $rlink_source.\n";
+ symlink( $rlink_source, $rlink )
+ or die("Could create link $rlink -> $rlink_source ($!)");
+ }
+ elsif ( -e $rlink && readlink($rlink) eq $rlink_source ) {
+ print "INFO: symlink $rlink -> $rlink_source already present.\n";
+ }
+ else {
+ die("Could not link $rlink to $rlink_source: a file is already there");
+ }
+ }
+
+ sub _create_hardlink {
+
+ # Inspiration from pcopy.pl, kudos to dam at opencsw.org
+ my ( $self, $llink, $rlink ) = @_;
+ $self->_create_dir( dirname($rlink) );
+
+ my @all_hardlinks = @{ $self->hardlinks_obj->related_hardlinks($llink) };
+ if ( !-f $rlink ) {
+
+ # Copy the first file
+ $self->_copy_file( $llink, $rlink );
+ $self->hardlinks_obj->add_newlink($rlink);
+
+ # Create related hardlinks
+ for my $hardlink (@all_hardlinks) {
+ next if ( $hardlink eq $llink ); # We created it above
+
+ # Create the link
+ my $rlink_related = $self->_get_newpath($hardlink);
+ if ( !-e $rlink_related ) {
+ print "Creating hardlink $rlink <-> $rlink_related.\n";
+ $self->_create_dir( dirname($rlink_related) );
+ link( $rlink, $rlink_related )
+ or
+ die("Could not create link $rlink <-> $rlink_related ($!)");
+ $self->hardlinks_obj->add_newlink($rlink_related);
+ }
+ else {
+ my $st_l = stat($rlink);
+ my $st_r = stat($rlink_related);
+ if ( $st_l->ino == $st_r->ino ) {
+ print
+ "INFO: hardlink $rlink <-> $rlink_related already in place. Skipping.\n";
+ }
+ else {
+ die(
+ "Could not link $rlink to $rlink_related: a file is already there"
+ );
+ }
+ }
+ }
+ }
+ else { # newlink is already in place
+ if ( $self->hardlinks_obj->is_created($rlink) ) {
+ print "INFO: hardlink $rlink already in place. Skipping.\n";
+ }
+ else {
+ die("Could not create hardlink $rlink: a file is already there");
+ }
+ }
+ }
+
+ sub _is_hardlink {
+ my ( $self, $file ) = @_;
+ my $related_hardlinks = $self->hardlinks_obj->related_hardlinks($file);
+ return scalar @{$related_hardlinks};
+ }
+
+ sub _get_newpath {
+ my ( $self, $path ) = @_;
+ my $newpath;
+
+ # We check for renaming rx
+ if ( defined $self->ren_rx ) {
+ $newpath = $self->_get_newpath_rename($path);
+ }
+
+ # If no rx or it doesn't match, we construct the new path src -> target
+ if ( !defined $newpath ) {
+ $newpath = $self->_get_newpath_copy($path);
+ }
+ return $newpath;
+ }
+
+ sub _get_newpath_copy {
+ my ( $self, $path ) = @_;
+ my $target = $self->target_dir;
+ my $src_rx = $self->_src_rx;
+ my $newpath = $path;
+ if ( $newpath =~ s@^$src_rx(/.+)@$target$1@ ) {
+ return $newpath;
+ }
+ else {
+ die(
+ "Can not construct the name for the new target path (info:$path,$newpath)"
+ );
+ }
+ }
+
+ sub _get_newpath_rename {
+ my ( $self, $path ) = @_;
+ my $path_renamed;
+ for my $rx ( sort keys %{ $self->ren_rx } ) {
+ my $newpath = $path;
+ if ( $newpath =~ m@$rx@ ) {
+ my $repl = $self->ren_rx->{$rx}; ## TODO split $\d
+ $newpath =~ s@$rx@$repl@;
+ my %memories = ( #we only support 9 memory parentheses
+ '$1' => $1,
+ '$2' => $2,
+ '$3' => $3,
+ '$4' => $4,
+ '$5' => $5,
+ '$6' => $6,
+ '$7' => $7,
+ '$8' => $8,
+ '$9' => $9,
+ );
+ for my $key (sort keys %memories) {
+ $newpath =~ s@\Q$key\E@$memories{$key}@
+ if (defined $memories{$key});
+ }
+ $newpath = File::Spec->canonpath($newpath);
+ my $target = $self->target_dir;
+ if ( $newpath !~ m@^$target/@ ) {
+ die(
+ "Renaming regex \'$rx,$repl\' will result in files outside $target: $newpath."
+ );
+ }
+
+ print "INFO: renaming $path to $newpath.\n";
+ $path_renamed = $newpath;
+ last;
+
+ }
+ }
+ return $path_renamed; # return undef if no rx matches
+ }
+ 1;
+FILEMERGER_FS_FILEOPERATOR
+
+$fatpacked{"FileMerger/FS/HardLinks.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILEMERGER_FS_HARDLINKS';
+ package FileMerger::FS::HardLinks;
+
+ use Moo;
+ with('FileMerger::FS::Transversable');
+
+ use File::stat;
+
+ # Instance variables
+ has '_hardlinks_by_file' => (
+ is => 'ro',
+ default => sub { {} },
+ );
+
+ has '_hardlinks_by_inode' => (
+ is => 'ro',
+ default => sub { {} },
+ );
+
+ has '_newlinks' => (
+ is => 'ro',
+ default => sub { [] },
+ );
+
+ has 'is_run' => (
+ is => 'ro',
+ builder => '_init',
+ lazy => 1,
+ );
+
+ # Methods
+
+ # Instance related
+ sub _init {
+ my $self = shift;
+ $self->walk_tree;
+ return 1;
+ }
+
+ # Overrides
+
+ sub _wanted() {
+ my $self = shift;
+ return if ( $_ eq '.' ); # skip top directory
+ return if $self->_to_skip($File::Find::name);
+
+ # Let handle the different expected filetypes
+ if ( -f $File::Find::name && !-l ) {
+ my $st = stat($File::Find::name) or die($!);
+
+ #print "$File::Find::name " . $st->ino . " \n";
+ if ( $st->nlink > 1 ) { # only hardlinked files
+ push @{ $self->_hardlinks_by_inode->{ $st->ino } },
+ $File::Find::name;
+ push @{ $self->_hardlinks_by_file->{$File::Find::name} }, $st->ino;
+ }
+ }
+ else {
+ return; # we only care about files
+ }
+ }
+
+ # Methods
+
+ sub add_newlink {
+ my ( $self, $newlink ) = @_;
+ push @{ $self->_newlinks }, $newlink;
+ }
+
+ sub is_created {
+ my ( $self, $link ) = @_;
+ $self->is_run; # make sure we run walk_tree once
+ local $_; # File::Find conflict
+ return grep { $_ eq $link } @{ $self->_newlinks };
+ }
+
+ sub related_hardlinks {
+ my ( $self, $file ) = @_;
+ $self->is_run; # make sure we run walk_tree once
+ my @hardlinks;
+ my $st_l = stat($file) or die($!);
+ my $ino = $st_l->ino;
+ my $hardlinks_ref = $self->_hardlinks_by_inode->{$ino};
+ my $inodes_ref = $self->_hardlinks_by_file->{$file};
+ for my $inode ( @{ $self->_hardlinks_by_file->{$file} } ) {
+ push @hardlinks, @{ $self->_hardlinks_by_inode->{$inode} };
+ }
+ return \@hardlinks;
+ }
+
+ 1;
+FILEMERGER_FS_HARDLINKS
+
+$fatpacked{"FileMerger/FS/HeadersUnifier.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILEMERGER_FS_HEADERSUNIFIER';
+ package FileMerger::FS::HeadersUnifier;
+
+ use Moo;
+
+
+ 1;
+
+FILEMERGER_FS_HEADERSUNIFIER
+
+$fatpacked{"FileMerger/FS/Transversable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILEMERGER_FS_TRANSVERSABLE';
+ package FileMerger::FS::Transversable;
+ # An OO wrapper for File::Find
+
+ use Moo::Role;
+
+ use File::Find;
+ no warnings 'File::Find';
+
+ #use Data::Printer; ## DEBUG
+
+ # Instance variables
+ has 'src_dirs' => ( # dirs must exist, calling class must make sure
+ is => 'ro', # is arrayref
+ required => 1,
+ );
+
+ has 'excl_lit' => (
+ is => 'rw',
+ # default => sub { [] },
+ lazy => 1,
+ );
+
+ has 'excl_rx' => (
+ is => 'rw',
+ # default => sub { [] },
+ lazy => 1,
+ );
+
+ has 'skipped' => (
+ is => 'rwp',
+ default => sub { [] },
+ lazy => 1,
+ );
+
+ ### Methods
+
+ sub walk_tree() {
+ my $self = shift;
+
+ # Walk the src tree
+ # find( \&_wanted, $self->src_dir );
+ find( sub { $self->_wanted(); }, @{ $self->src_dirs } ); # Let's play nice with OO
+ }
+
+ sub _to_skip {
+ my ( $self, $path ) = @_;
+ my $skip = 0;
+
+ # we need to localize File::Find's $_ to allow grep's use of it
+ local ($_);
+ if ( defined $self->excl_lit ) { # Calling class must clean trailing slashes
+ if ( grep { $path =~ m@^$_($|/)@ } @{ $self->excl_lit } ) {
+ $skip = 1;
+ }
+ }
+
+ if ( defined $self->excl_rx ) { # Calling class must supply valid regex)
+ $skip = 1 if ( grep { $path =~ /$_/ } @{ $self->excl_rx } );
+ }
+ push @{ $self->skipped }, $path if ($skip);
+ print "INFO: skipping $path as requested...\n" if ($skip);
+ return $skip;
+ }
+
+
+ sub _wanted() {
+ # A basic _wanted to be overwritten
+ my $self = shift;
+ return if ( $_ eq '.' ); # skip top directory
+ return if $self->_to_skip($File::Find::name);
+ print "You forgot to override _wanted()?\n";
+ print $_ . "\n";
+ }
+
+ 1;
+FILEMERGER_FS_TRANSVERSABLE
+
+$fatpacked{"FileMerger/Params.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILEMERGER_PARAMS';
+ package FileMerger::Params;
+ our $VERSION = "0.1";
+ use Moo;
+
+ use Getopt::Long;
+ use File::Basename;
+ use File::Spec;
+ use Text::CSV;
+
+ has 'args' => (
+
+ # source: arrayref
+ # target: string
+ # exclude-literal: arrayref
+ # exclude-regex: arrayref
+ # rename-regex: hashref
+ is => 'ro',
+ default => sub { {} },
+ init_arg => undef,
+ );
+
+ has 'messages' => (
+ is => 'ro',
+ default => sub { [] },
+ lazy => 1,
+ init_arg => undef,
+ );
+
+ sub read_params {
+ my $self = shift;
+ GetOptions( $self->args, 'help|h|?', 'version|v', 'exclude-literal|l=s@',
+ 'exclude-rx|e=s@', 'rename-rx|r=s@', 'source|s=s@', 'target|t=s' )
+ or die "\nInvalid switch. Please read the help page: "
+ . basename $0
+ . " -?\n\n";
+
+ # Help and version status
+ if ( defined $self->args->{help}
+ or ( !@ARGV and !( grep { defined $_ } values %{ $self->args } ) ) )
+ {
+ $self->_show_help(0);
+ exit 0;
+ }
+ if ( defined $self->args->{version} ) {
+ $self->args->_show_help(1);
+ exit 0;
+ }
+
+ # Check parameters
+
+ if ( !$self->_check_params() ) {
+ for my $msg ( @{ $self->messages } ) {
+ print STDERR $msg . "\n";
+ }
+ print "Bailing out...\n";
+ exit 1;
+ }
+
+ return %{ $self->args };
+ }
+
+ sub _check_params {
+ my $self = shift;
+ my $status = 1;
+
+ # Verify required parameters
+ $status = 0 unless ( $self->_check_req(qw/source target/) );
+
+ # Verify that the source exists and no doubles are present
+ $status = 0 unless ( $self->_check_src() );
+
+ # Verify that the target is a directory or does not exist
+ $status = 0 unless ( $self->_check_target() );
+
+ # Split the renaming regexes
+ my @regexes; # used to exclude after renaming
+ if ( defined $self->args->{'rename-rx'} ) {
+ # Use newstyle regexps
+ s,\\(\d),\$$1,g foreach(@{ $self->args->{'rename-rx'} });
+ # Split the regex
+ my $ren_rx_ref = $self->_split_rx( $self->args->{'rename-rx'} );
+ if ( defined $ren_rx_ref ) {
+ $self->args->{'rename-rx'} = $ren_rx_ref; # We want a % in args
+ @regexes = keys %{$ren_rx_ref};
+
+ }
+ else { $status = 0 }
+ }
+
+ # Check for valid regexes
+ if ( defined $self->args->{'exclude-rx'} ) {
+ push @regexes, @{ $self->args->{'exclude-rx'} };
+ }
+
+ if (@regexes) {
+ my $rx_status = _validate_rx( \@regexes );
+ if ( !$rx_status ) {
+ $status = 0;
+ }
+ }
+
+ # Canonize the literal paths of exclude-literal
+ ## TODO and make sure they are absolute
+ if ( $self->args->{'exclude-literal'} ) {
+ for my $path ( @{ $self->args->{'exclude-literal'} } ) {
+ $path = $self->_canonize($path);
+ }
+ }
+
+ return $status;
+ }
+
+ sub _canonize {
+ my ( $self, $path ) = @_;
+ my $cpath =
+ File::Spec->canonpath($path); # Remove trailing slashes, portable
+ return $cpath;
+ }
+
+ sub _check_req {
+ my ( $self, @required ) = @_;
+ my $ok = 1;
+ for my $param (@required) {
+ if ( !defined $self->args->{$param} ) {
+ push @{ $self->messages }, "Parameter $param is required.";
+ $ok = 0;
+ }
+ }
+ return $ok;
+ }
+
+ sub _check_src {
+ my $self = shift;
+ my $ok = 1;
+ for my $src ( @{ $self->args->{source} } ) {
+
+ if ( !-d $src ) {
+ push @{ $self->messages },
+ "Source " . $src . " is not a valid directory.";
+ $ok = 0;
+ }
+ else {
+ $src = $self->_canonize($src);
+
+ }
+ }
+ if ($ok) {
+
+ # remove double entries
+ my %uniq_hash = map { $_, 1 } @{ $self->args->{'source'} };
+ $self->args->{'source'} = [ sort keys %uniq_hash ]
+ ; # Sort to have reproducible search path order later
+ }
+ return $ok;
+ }
+
+ sub _check_target {
+ my $self = shift;
+ my $ok = 1;
+ if ( -e $self->args->{target} && !-d $self->args->{target} ) {
+ push @{ $self->messages },
+ "Target " . $self->args->{target} . " exists but is not a directory.";
+ $ok = 0;
+ }
+ elsif ( -d $self->args->{target} ) {
+ $self->args->{target} = $self->_canonize( $self->args->{target} );
+ }
+ return $ok;
+ }
+
+ sub _split_rx {
+ my ( $self, $rx_param_ref ) = @_;
+ my %rx = ();
+ my $split_ok = 1;
+
+ for my $rx_param ( @{$rx_param_ref} ) {
+ my $csv = Text::CSV->new();
+ if ( $csv->parse($rx_param) ) {
+ my @fields = $csv->fields();
+ if ( scalar @fields == 2 ) {
+ if ( !exists $rx{ $fields[0] } ) {
+ $rx{ $fields[0] } = $fields[1];
+ }
+ else {
+ push @{ $self->messages },
+ "'$fields[0]' must be unique for a rename-regex.";
+ $split_ok = 0;
+ }
+ }
+ else {
+ push @{ $self->messages },
+ "'$rx_param' can not be decomposed into a valid Perl regex and replacement.";
+ $split_ok = 0;
+ }
+ }
+ else {
+ push @{ $self->messages },
+ "'$rx_param' can not be decomposed into a valid Perl regex and replacement.";
+ $split_ok = 0;
+ }
+ }
+ return ($split_ok) ? \%rx : undef;
+ }
+
+ sub _validate_rx {
+ my ( $self, $rx_ref ) = @_;
+ my $status = 1;
+ for my $rx ( @{$rx_ref} ) {
+ my $eval_rx = eval { qr{$rx} };
+ if ($@) {
+ $status = 0;
+ push @{ $self->messages }, "'$rx' is an invalid Perl regex.";
+ }
+ }
+ return $status;
+ }
+
+ sub _show_help {
+ my ( $self, $version_bool ) = @_;
+ require File::Basename;
+ my $program = File::Basename::basename($0);
+ print "\nOpenCSW FileMerger, version $VERSION. Bugs to claudio\@opencsw.org.\n";
+ return if $version_bool;
+ print <<"EOL";
+
+ usage:\t$program [-s <source directory>] [-t <target directory>]
+ \t\t [-l <full pathname>] [-e <regex>] [-r <regex>]
+
+ Available parameters:
+
+ -h,--help\t\t\t\tdisplay a help message
+ -v,--version\t\t\t\tdisplay the version of the
+ \t\t\t\t\tprogram
+ -s,--source <source directory> \tsource directory*
+ -t,--target <target directory> \ttarget directory
+
+ -l,--exclude-literal <file pathname>\texclude files by literal
+ \t\t\t\t\tfilename*
+ -e,--exclude-rx <regex>\t\tPerl regular expression to
+ \t\t\t\t\texclude files by name*
+ -r,--rename-rx <regex,text>\t\tRegex and replacement for
+ \t\t\t\t\trenaming files*
+
+ *: multiple usage allowed.
+ All the excludeliterals and regexes work on the full path.
+ Slashes (/) don't need to be escaped.
+
+ EOL
+
+ }
+
+
+ 1;
+FILEMERGER_PARAMS
+
+$fatpacked{"FileMerger/Reporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILEMERGER_REPORTER';
+ package FileMerger::Reporter;
+
+ use Moo;
+
+ sub run {
+ my ( $self, $conflicts_ref, $skipped_ref ) = @_;
+ my $ok = 1;
+ print "\n\n". '_' x 34 . 'STATUS REPORT' . '_' x 33 . "\n";
+ if ( @{$conflicts_ref} ) {
+ print "\nThe following conflicts were encountered:\n";
+ print "$_\n" for ( sort @{$conflicts_ref} );
+ $ok = 0;
+ }
+ if ( @{$skipped_ref} ) {
+ print "\nThe following files and directories were skipped:\n";
+ print "$_\n" for ( sort @{$skipped_ref} );
+ }
+ print "\nDirectories merged without warnings.\n\n" if $ok;
+ print "\nDone.\n\n";
+ }
+
+ 1;
+FILEMERGER_REPORTER
+
+$fatpacked{"Import/Into.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IMPORT_INTO';
+ package Import::Into;
+
+ use strict;
+ use warnings FATAL => 'all';
+
+ our $VERSION = '1.002002'; # 1.2.2
+
+ sub _prelude {
+ my $target = shift;
+ my ($package, $file, $line, $level)
+ = ref $target ? @{$target}{qw(package filename line)}
+ : $target =~ /[^0-9]/ ? ($target)
+ : (undef, undef, undef, $target);
+ if (defined $level) {
+ my ($p, $fn, $ln) = caller($level + 2);
+ $package ||= $p;
+ $file ||= $fn;
+ $line ||= $ln;
+ }
+ qq{package $package;\n}
+ . ($file ? "#line $line \"$file\"\n" : '')
+ }
+
+ sub _make_action {
+ my ($action, $target) = @_;
+ my $version = ref $target && $target->{version};
+ my $ver_check = $version ? '$_[0]->VERSION($version);' : '';
+ eval _prelude($target).qq{sub { $ver_check shift->$action(\@_) }}
+ or die "Failed to build action sub to ${action} for ${target}: $@";
+ }
+
+ sub import::into {
+ my ($class, $target, @args) = @_;
+ _make_action(import => $target)->($class, @args);
+ }
+
+ sub unimport::out_of {
+ my ($class, $target, @args) = @_;
+ _make_action(unimport => $target)->($class, @args);
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Import::Into - import packages into other packages
+
+ =head1 SYNOPSIS
+
+ package My::MultiExporter;
+
+ use Import::Into;
+
+ use Thing1 ();
+ use Thing2 ();
+
+ # simple
+ sub import {
+ Thing1->import::into(scalar caller);
+ }
+
+ # multiple
+ sub import {
+ my $target = caller;
+ Thing1->import::into($target);
+ Thing2->import::into($target, qw(import arguments));
+ }
+
+ # by level
+ sub import {
+ Thing1->import::into(1);
+ }
+
+ # with exporter
+ use base qw(Exporter);
+ sub import {
+ shift->export_to_level(1);
+ Thing1->import::into(1);
+ }
+
+ # no My::MultiExporter == no Thing1
+ sub unimport {
+ Thing1->unimport::out_of(scalar caller);
+ }
+
+ People wanting to re-export your module should also be using L<Import::Into>.
+ Any exporter or pragma will work seamlessly.
+
+ Note: You do B<not> need to make any changes to Thing1 to be able to call
+ C<import::into> on it. This is a global method, and is callable on any
+ package (and in fact on any object as well, although it's rarer that you'd
+ want to do that).
+
+ =head1 DESCRIPTION
+
+ Writing exporters is a pain. Some use L<Exporter>, some use L<Sub::Exporter>,
+ some use L<Moose::Exporter>, some use L<Exporter::Declare> ... and some things
+ are pragmas.
+
+ Exporting on someone else's behalf is harder. The exporters don't provide a
+ consistent API for this, and pragmas need to have their import method called
+ directly, since they effect the current unit of compilation.
+
+ C<Import::Into> provides global methods to make this painless.
+
+ =head1 METHODS
+
+ =head2 $package->import::into( $target, @arguments );
+
+ A global method, callable on any package. Imports the given package into
+ C<$target>. C<@arguments> are passed along to the package's import method.
+
+ C<$target> can be an package name to export to, an integer for the
+ caller level to export to, or a hashref with the following options:
+
+ =over 4
+
+ =item package
+
+ The target package to export to.
+
+ =item filename
+
+ The apparent filename to export to. Some exporting modules, such as
+ L<autodie> or L<strictures>, care about the filename they are being imported
+ to.
+
+ =item line
+
+ The apparent line number to export to. To be combined with the C<filename>
+ option.
+
+ =item level
+
+ The caller level to export to. This will automatically populate the
+ C<package>, C<filename>, and C<line> options, making it the easiest most
+ constent option.
+
+ =item version
+
+ A version number to check for the module. The equivalent of specifying the
+ version number on a C<use> line.
+
+ =back
+
+ =head2 $package->unimport::out_of( $target, @arguments );
+
+ Equivalent to C<import::into>, but dispatches to C<$package>'s C<unimport>
+ method instead of C<import>.
+
+ =head1 WHY USE THIS MODULE
+
+ The APIs for exporting modules aren't consistent. L<Exporter> subclasses
+ provide export_to_level, but if they overrode their import method all bets
+ are off. L<Sub::Exporter> provides an into parameter but figuring out
+ something used it isn't trivial. Pragmas need to have their C<import> method
+ called directly since they affect the current unit of compilation.
+
+ It's ... annoying.
+
+ However, there is an approach that actually works for all of these types.
+
+ eval "package $target; use $thing;"
+
+ will work for anything checking caller, which is everything except pragmas.
+ But it doesn't work for pragmas - pragmas need:
+
+ $thing->import;
+
+ because they're designed to affect the code currently being compiled - so
+ within an eval, that's the scope of the eval itself, not the module that
+ just C<use>d you - so
+
+ sub import {
+ eval "use strict;"
+ }
+
+ doesn't do what you wanted, but
+
+ sub import {
+ strict->import;
+ }
+
+ will apply L<strict> to the calling file correctly.
+
+ Of course, now you have two new problems - first, that you still need to
+ know if something's a pragma, and second that you can't use either of
+ these approaches alone on something like L<Moose> or L<Moo> that's both
+ an exporter and a pragma.
+
+ So, a solution for that is:
+
+ my $sub = eval "package $target; sub { shift->import(\@_) }";
+ $sub->($thing, @import_args);
+
+ which means that import is called from the right place for pragmas to take
+ effect, and from the right package for caller checking to work - and so
+ behaves correctly for all types of exporter, for pragmas, and for hybrids.
+
+ Additionally, some import routines check the filename they are being imported
+ to. This can be dealt with by generating a L<#line directive|perlsyn/Plain
+ Old Comments (Not!)> in the eval, which will change what C<caller> reports for
+ the filename when called in the importer. The filename and line number to use
+ in the directive then need to be fetched using C<caller>:
+
+ my ($target, $file, $line) = caller(1);
+ my $sub = eval qq{
+ package $target;
+ #line $line "$file"
+ sub { shift->import(\@_) }
+ };
+ $sub->($thing, @import_args);
+
+ And you need to switch between these implementations depending on if you are
+ targeting a specific package, or something in your call stack.
+
+ Remembering all this, however, is excessively irritating. So I wrote a module
+ so I didn't have to anymore. Loading L<Import::Into> creates a global method
+ C<import::into> which you can call on any package to import it into another
+ package. So now you can simply write:
+
+ use Import::Into;
+
+ $thing->import::into($target, @import_args);
+
+ This works because of how perl resolves method calls - a call to a simple
+ method name is resolved against the package of the class or object, so
+
+ $thing->method_name(@args);
+
+ is roughly equivalent to:
+
+ my $code_ref = $thing->can('method_name');
+ $code_ref->($thing, @args);
+
+ while if a C<::> is found, the lookup is made relative to the package name
+ (i.e. everything before the last C<::>) so
+
+ $thing->Package::Name::method_name(@args);
+
+ is roughly equivalent to:
+
+ my $code_ref = Package::Name->can('method_name');
+ $code_ref->($thing, @args);
+
+ So since L<Import::Into> defines a method C<into> in package C<import>
+ the syntax reliably calls that.
+
+ For more craziness of this order, have a look at the article I wrote at
+ L<http://shadow.cat/blog/matt-s-trout/madness-with-methods> which covers
+ coderef abuse and the C<${\...}> syntax.
+
+ Final note: You do still need to ensure that you already loaded C<$thing> - if
+ you're receiving this from a parameter, I recommend using L<Module::Runtime>:
+
+ use Import::Into;
+ use Module::Runtime qw(use_module);
+
+ use_module($thing)->import::into($target, @import_args);
+
+ And that's it.
+
+ =head1 SEE ALSO
+
+ I gave a lightning talk on this module (and L<curry> and L<Safe::Isa>) at
+ L<YAPC::NA 2013|https://www.youtube.com/watch?v=wFXWV2yY7gE&t=46m05s>.
+
+ =head1 ACKNOWLEDGEMENTS
+
+ Thanks to Getty for asking "how can I get C<< use strict; use warnings; >>
+ turned on for all consumers of my code?" and then "why is this not a
+ module?!".
+
+ =head1 AUTHOR
+
+ mst - Matt S. Trout (cpan:MSTROUT) <mst at shadowcat.co.uk>
+
+ =head1 CONTRIBUTORS
+
+ haarg - Graham Knop (cpan:HAARG) <haarg at haarg.org>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 2012 the Import::Into L</AUTHOR> and L</CONTRIBUTORS>
+ as listed above.
+
+ =head1 LICENSE
+
+ This library is free software and may be distributed under the same terms
+ as perl itself.
+
+ =cut
+IMPORT_INTO
+
+$fatpacked{"Method/Generate/Accessor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_ACCESSOR';
+ package Method::Generate::Accessor;
+
+ use strictures 1;
+ use Moo::_Utils;
+ use base qw(Moo::Object);
+ use Sub::Quote;
+ use B 'perlstring';
+ use Scalar::Util 'blessed';
+ use overload ();
+ use Module::Runtime qw(use_module);
+ BEGIN {
+ our $CAN_HAZ_XS =
+ !$ENV{MOO_XS_DISABLE}
+ &&
+ _maybe_load_module('Class::XSAccessor')
+ &&
+ (eval { Class::XSAccessor->VERSION('1.07') })
+ ;
+ our $CAN_HAZ_XS_PRED =
+ $CAN_HAZ_XS &&
+ (eval { Class::XSAccessor->VERSION('1.17') })
+ ;
+ }
+
+ sub _SIGDIE
+ {
+ our ($CurrentAttribute, $OrigSigDie);
+ my $sigdie = $OrigSigDie && $OrigSigDie != \&_SIGDIE
+ ? $OrigSigDie
+ : sub { die $_[0] };
+
+ return $sigdie->(@_) if ref($_[0]);
+
+ my $attr_desc = _attr_desc(@$CurrentAttribute{qw(name init_arg)});
+ $sigdie->("$CurrentAttribute->{step} for $attr_desc failed: $_[0]");
+ }
+
+ sub _die_overwrite
+ {
+ my ($pkg, $method, $type) = @_;
+ die "You cannot overwrite a locally defined method ($method) with @{[ $type || 'an accessor' ]}";
+ }
+
+ sub generate_method {
+ my ($self, $into, $name, $spec, $quote_opts) = @_;
+ $spec->{allow_overwrite}++ if $name =~ s/^\+//;
+ die "Must have an is" unless my $is = $spec->{is};
+ if ($is eq 'ro') {
+ $spec->{reader} = $name unless exists $spec->{reader};
+ } elsif ($is eq 'rw') {
+ $spec->{accessor} = $name unless exists $spec->{accessor}
+ or ( $spec->{reader} and $spec->{writer} );
+ } elsif ($is eq 'lazy') {
+ $spec->{reader} = $name unless exists $spec->{reader};
+ $spec->{lazy} = 1;
+ $spec->{builder} ||= '_build_'.$name unless $spec->{default};
+ } elsif ($is eq 'rwp') {
+ $spec->{reader} = $name unless exists $spec->{reader};
+ $spec->{writer} = "_set_${name}" unless exists $spec->{writer};
+ } elsif ($is ne 'bare') {
+ die "Unknown is ${is}";
+ }
+ if (exists $spec->{builder}) {
+ if(ref $spec->{builder}) {
+ $self->_validate_codulatable('builder', $spec->{builder},
+ "$into->$name", 'or a method name');
+ $spec->{builder_sub} = $spec->{builder};
+ $spec->{builder} = 1;
+ }
+ $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
+ die "Invalid builder for $into->$name - not a valid method name"
+ if $spec->{builder} !~ /\A[A-Za-z_][A-Za-z0-9_]*(?:::[A-Za-z_][A-Za-z0-9_]*)*\z/;
+ }
+ if (($spec->{predicate}||0) eq 1) {
+ $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
+ }
+ if (($spec->{clearer}||0) eq 1) {
+ $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}";
+ }
+ if (($spec->{trigger}||0) eq 1) {
+ $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
+ }
+
+ for my $setting (qw( isa coerce )) {
+ next if !exists $spec->{$setting};
+ $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name");
+ }
+
+ if (exists $spec->{default}) {
+ if (!defined $spec->{default} || ref $spec->{default}) {
+ $self->_validate_codulatable('default', $spec->{default}, "$into->$name", 'or a non-ref');
+ }
+ }
+
+ if (exists $spec->{moosify}) {
+ if (ref $spec->{moosify} ne 'ARRAY') {
+ $spec->{moosify} = [$spec->{moosify}];
+ }
+
+ for my $spec (@{$spec->{moosify}}) {
+ $self->_validate_codulatable('moosify', $spec, "$into->$name");
+ }
+ }
+
+ my %methods;
+ if (my $reader = $spec->{reader}) {
+ _die_overwrite($into, $reader, 'a reader')
+ if !$spec->{allow_overwrite} && *{_getglob("${into}::${reader}")}{CODE};
+ if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
+ $methods{$reader} = $self->_generate_xs(
+ getters => $into, $reader, $name, $spec
+ );
+ } else {
+ $self->{captures} = {};
+ $methods{$reader} =
+ quote_sub "${into}::${reader}"
+ => ' die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
+ .$self->_generate_get($name, $spec)
+ => delete $self->{captures}
+ ;
+ }
+ }
+ if (my $accessor = $spec->{accessor}) {
+ _die_overwrite($into, $accessor, 'an accessor')
+ if !$spec->{allow_overwrite} && *{_getglob("${into}::${accessor}")}{CODE};
+ if (
+ our $CAN_HAZ_XS
+ && $self->is_simple_get($name, $spec)
+ && $self->is_simple_set($name, $spec)
+ ) {
+ $methods{$accessor} = $self->_generate_xs(
+ accessors => $into, $accessor, $name, $spec
+ );
+ } else {
+ $self->{captures} = {};
+ $methods{$accessor} =
+ quote_sub "${into}::${accessor}"
+ => $self->_generate_getset($name, $spec)
+ => delete $self->{captures}
+ ;
+ }
+ }
+ if (my $writer = $spec->{writer}) {
+ _die_overwrite($into, $writer, 'a writer')
+ if !$spec->{allow_overwrite} && *{_getglob("${into}::${writer}")}{CODE};
+ if (
+ our $CAN_HAZ_XS
+ && $self->is_simple_set($name, $spec)
+ ) {
+ $methods{$writer} = $self->_generate_xs(
+ setters => $into, $writer, $name, $spec
+ );
+ } else {
+ $self->{captures} = {};
+ $methods{$writer} =
+ quote_sub "${into}::${writer}"
+ => $self->_generate_set($name, $spec)
+ => delete $self->{captures}
+ ;
+ }
+ }
+ if (my $pred = $spec->{predicate}) {
+ _die_overwrite($into, $pred, 'a predicate')
+ if !$spec->{allow_overwrite} && *{_getglob("${into}::${pred}")}{CODE};
+ if (our $CAN_HAZ_XS && our $CAN_HAZ_XS_PRED) {
+ $methods{$pred} = $self->_generate_xs(
+ exists_predicates => $into, $pred, $name, $spec
+ );
+ } else {
+ $methods{$pred} =
+ quote_sub "${into}::${pred}" =>
+ ' '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
+ ;
+ }
+ }
+ if (my $pred = $spec->{builder_sub}) {
+ _install_coderef( "${into}::$spec->{builder}" => $spec->{builder_sub} );
+ }
+ if (my $cl = $spec->{clearer}) {
+ _die_overwrite($into, $cl, 'a clearer')
+ if !$spec->{allow_overwrite} && *{_getglob("${into}::${cl}")}{CODE};
+ $methods{$cl} =
+ quote_sub "${into}::${cl}" =>
+ $self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
+ ;
+ }
+ if (my $hspec = $spec->{handles}) {
+ my $asserter = $spec->{asserter} ||= '_assert_'.$name;
+ my @specs = do {
+ if (ref($hspec) eq 'ARRAY') {
+ map [ $_ => $_ ], @$hspec;
+ } elsif (ref($hspec) eq 'HASH') {
+ map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
+ keys %$hspec;
+ } elsif (!ref($hspec)) {
+ map [ $_ => $_ ], use_module('Moo::Role')->methods_provided_by(use_module($hspec))
+ } else {
+ die "You gave me a handles of ${hspec} and I have no idea why";
+ }
+ };
+ foreach my $delegation_spec (@specs) {
+ my ($proxy, $target, @args) = @$delegation_spec;
+ _die_overwrite($into, $proxy, 'a delegation')
+ if !$spec->{allow_overwrite} && *{_getglob("${into}::${proxy}")}{CODE};
+ $self->{captures} = {};
+ $methods{$proxy} =
+ quote_sub "${into}::${proxy}" =>
+ $self->_generate_delegation($asserter, $target, \@args),
+ delete $self->{captures}
+ ;
+ }
+ }
+ if (my $asserter = $spec->{asserter}) {
+ $self->{captures} = {};
+
+
+ $methods{$asserter} =
+ quote_sub "${into}::${asserter}" => $self->_generate_asserter($name, $spec),
+ delete $self->{captures}
+ ;
+ }
+ \%methods;
+ }
+
+ sub is_simple_attribute {
+ my ($self, $name, $spec) = @_;
+ # clearer doesn't have to be listed because it doesn't
+ # affect whether defined/exists makes a difference
+ !grep $spec->{$_},
+ qw(lazy default builder coerce isa trigger predicate weak_ref);
+ }
+
+ sub is_simple_get {
+ my ($self, $name, $spec) = @_;
+ !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
+ }
+
+ sub is_simple_set {
+ my ($self, $name, $spec) = @_;
+ !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
+ }
+
+ sub has_eager_default {
+ my ($self, $name, $spec) = @_;
+ (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
+ }
+
+ sub _generate_get {
+ my ($self, $name, $spec) = @_;
+ my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
+ if ($self->is_simple_get($name, $spec)) {
+ $simple;
+ } else {
+ $self->_generate_use_default(
+ '$_[0]', $name, $spec,
+ $self->_generate_simple_has('$_[0]', $name, $spec),
+ );
+ }
+ }
+
+ sub generate_simple_has {
+ my $self = shift;
+ $self->{captures} = {};
+ my $code = $self->_generate_simple_has(@_);
+ ($code, delete $self->{captures});
+ }
+
+ sub _generate_simple_has {
+ my ($self, $me, $name) = @_;
+ "exists ${me}->{${\perlstring $name}}";
+ }
+
+ sub _generate_simple_clear {
+ my ($self, $me, $name) = @_;
+ " delete ${me}->{${\perlstring $name}}\n"
+ }
+
+ sub generate_get_default {
+ my $self = shift;
+ $self->{captures} = {};
+ my $code = $self->_generate_get_default(@_);
+ ($code, delete $self->{captures});
+ }
+
+ sub generate_use_default {
+ my $self = shift;
+ $self->{captures} = {};
+ my $code = $self->_generate_use_default(@_);
+ ($code, delete $self->{captures});
+ }
+
+ sub _generate_use_default {
+ my ($self, $me, $name, $spec, $test) = @_;
+ my $get_value = $self->_generate_get_default($me, $name, $spec);
+ if ($spec->{coerce}) {
+ $get_value = $self->_generate_coerce(
+ $name, $get_value,
+ $spec->{coerce}
+ )
+ }
+ $test." ? \n"
+ .$self->_generate_simple_get($me, $name, $spec)."\n:"
+ .($spec->{isa}
+ ? " do {\n my \$value = ".$get_value.";\n"
+ ." ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n"
+ ." ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n"
+ ." }\n"
+ : ' ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n");
+ }
+
+ sub _generate_get_default {
+ my ($self, $me, $name, $spec) = @_;
+ if (exists $spec->{default}) {
+ ref $spec->{default}
+ ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
+ : perlstring $spec->{default};
+ }
+ else {
+ "${me}->${\$spec->{builder}}"
+ }
+ }
+
+ sub generate_simple_get {
+ my ($self, @args) = @_;
+ $self->_generate_simple_get(@args);
+ }
+
+ sub _generate_simple_get {
+ my ($self, $me, $name) = @_;
+ my $name_str = perlstring $name;
+ "${me}->{${name_str}}";
+ }
+
+ sub _generate_set {
+ my ($self, $name, $spec) = @_;
+ if ($self->is_simple_set($name, $spec)) {
+ $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
+ } else {
+ my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
+ my $value_store = '$_[0]';
+ my $code;
+ if ($coerce) {
+ $value_store = '$value';
+ $code = "do { my (\$self, \$value) = \@_;\n"
+ ." \$value = "
+ .$self->_generate_coerce($name, $value_store, $coerce).";\n";
+ }
+ else {
+ $code = "do { my \$self = shift;\n";
+ }
+ if ($isa_check) {
+ $code .=
+ " ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n";
+ }
+ my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store);
+ if ($trigger) {
+ my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger);
+ $code .=
+ " ".$simple.";\n ".$fire.";\n"
+ ." $value_store;\n";
+ } else {
+ $code .= " ".$simple.";\n";
+ }
+ $code .= " }";
+ $code;
+ }
+ }
+
+ sub generate_coerce {
+ my $self = shift;
+ $self->{captures} = {};
+ my $code = $self->_generate_coerce(@_);
+ ($code, delete $self->{captures});
+ }
+
+ sub _attr_desc {
+ my ($name, $init_arg) = @_;
+ return perlstring($name) if !defined($init_arg) or $init_arg eq $name;
+ return perlstring($name).' (constructor argument: '.perlstring($init_arg).')';
+ }
+
+ sub _generate_coerce {
+ my ($self, $name, $value, $coerce, $init_arg) = @_;
+ $self->_generate_die_prefix(
+ $name,
+ "coercion",
+ $init_arg,
+ $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
+ );
+ }
+
+ sub generate_trigger {
+ my $self = shift;
+ $self->{captures} = {};
+ my $code = $self->_generate_trigger(@_);
+ ($code, delete $self->{captures});
+ }
+
+ sub _generate_trigger {
+ my ($self, $name, $obj, $value, $trigger) = @_;
+ $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
+ }
+
+ sub generate_isa_check {
+ my ($self, @args) = @_;
+ $self->{captures} = {};
+ my $code = $self->_generate_isa_check(@args);
+ ($code, delete $self->{captures});
+ }
+
+ sub _generate_die_prefix {
+ my ($self, $name, $prefix, $arg, $inside) = @_;
+ "do {\n"
+ .' local $Method::Generate::Accessor::CurrentAttribute = {'
+ .' init_arg => '.(defined $arg ? B::perlstring($arg) : 'undef') . ",\n"
+ .' name => '.B::perlstring($name).",\n"
+ .' step => '.B::perlstring($prefix).",\n"
+ ." };\n"
+ .' local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n"
+ .' local $SIG{__DIE__} = \&Method::Generate::Accessor::_SIGDIE;'."\n"
+ .$inside
+ ."}\n"
+ }
+
+ sub _generate_isa_check {
+ my ($self, $name, $value, $check, $init_arg) = @_;
+ $self->_generate_die_prefix(
+ $name,
+ "isa check",
+ $init_arg,
+ $self->_generate_call_code($name, 'isa_check', $value, $check)
+ );
+ }
+
+ sub _generate_call_code {
+ my ($self, $name, $type, $values, $sub) = @_;
+ $sub = \&{$sub} if blessed($sub); # coderef if blessed
+ if (my $quoted = quoted_from_sub($sub)) {
+ my $local = 1;
+ if ($values eq '@_' || $values eq '$_[0]') {
+ $local = 0;
+ $values = '@_';
+ }
+ my $code = $quoted->[1];
+ if (my $captures = $quoted->[2]) {
+ my $cap_name = qq{\$${type}_captures_for_}.$self->_sanitize_name($name);
+ $self->{captures}->{$cap_name} = \$captures;
+ Sub::Quote::inlinify(
+ $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), $local
+ );
+ } else {
+ Sub::Quote::inlinify($code, $values, undef, $local);
+ }
+ } else {
+ my $cap_name = qq{\$${type}_for_}.$self->_sanitize_name($name);
+ $self->{captures}->{$cap_name} = \$sub;
+ "${cap_name}->(${values})";
+ }
+ }
+
+ sub _sanitize_name {
+ my ($self, $name) = @_;
+ $name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
+ $name;
+ }
+
+ sub generate_populate_set {
+ my $self = shift;
+ $self->{captures} = {};
+ my $code = $self->_generate_populate_set(@_);
+ ($code, delete $self->{captures});
+ }
+
+ sub _generate_populate_set {
+ my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_;
+ if ($self->has_eager_default($name, $spec)) {
+ my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
+ my $get_default = $self->_generate_get_default(
+ '$new', $name, $spec
+ );
+ my $get_value =
+ defined($spec->{init_arg})
+ ? "(\n${get_indent} ${test}\n${get_indent} ? ${source}\n${get_indent} : "
+ .$get_default
+ ."\n${get_indent})"
+ : $get_default;
+ if ($spec->{coerce}) {
+ $get_value = $self->_generate_coerce(
+ $name, $get_value,
+ $spec->{coerce}, $init_arg
+ )
+ }
+ ($spec->{isa}
+ ? " {\n my \$value = ".$get_value.";\n "
+ .$self->_generate_isa_check(
+ $name, '$value', $spec->{isa}, $init_arg
+ ).";\n"
+ .' '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
+ ." }\n"
+ : ' '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
+ )
+ .($spec->{trigger}
+ ? ' '
+ .$self->_generate_trigger(
+ $name, $me, $self->_generate_simple_get($me, $name, $spec),
+ $spec->{trigger}
+ )." if ${test};\n"
+ : ''
+ );
+ } else {
+ " if (${test}) {\n"
+ .($spec->{coerce}
+ ? " $source = "
+ .$self->_generate_coerce(
+ $name, $source,
+ $spec->{coerce}, $init_arg
+ ).";\n"
+ : ""
+ )
+ .($spec->{isa}
+ ? " "
+ .$self->_generate_isa_check(
+ $name, $source, $spec->{isa}, $init_arg
+ ).";\n"
+ : ""
+ )
+ ." ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
+ .($spec->{trigger}
+ ? " "
+ .$self->_generate_trigger(
+ $name, $me, $self->_generate_simple_get($me, $name, $spec),
+ $spec->{trigger}
+ ).";\n"
+ : ""
+ )
+ ." }\n";
+ }
+ }
+
+ sub _generate_core_set {
+ my ($self, $me, $name, $spec, $value) = @_;
+ my $name_str = perlstring $name;
+ "${me}->{${name_str}} = ${value}";
+ }
+
+ sub _generate_simple_set {
+ my ($self, $me, $name, $spec, $value) = @_;
+ my $name_str = perlstring $name;
+ my $simple = $self->_generate_core_set($me, $name, $spec, $value);
+
+ if ($spec->{weak_ref}) {
+ require Scalar::Util;
+ my $get = $self->_generate_simple_get($me, $name, $spec);
+
+ # Perl < 5.8.3 can't weaken refs to readonly vars
+ # (e.g. string constants). This *can* be solved by:
+ #
+ #Internals::SetReadWrite($foo);
+ #Scalar::Util::weaken ($foo);
+ #Internals::SetReadOnly($foo);
+ #
+ # but requires XS and is just too damn crazy
+ # so simply throw a better exception
+ my $weak_simple = "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }";
+ Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
+ eval { Scalar::Util::weaken($simple); 1 }
+ ? do { no warnings 'void'; $get }
+ : do {
+ if( \$@ =~ /Modification of a read-only value attempted/) {
+ require Carp;
+ Carp::croak( sprintf (
+ 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
+ $name_str,
+ ) );
+ } else {
+ die \$@;
+ }
+ }
+ EOC
+ } else {
+ $simple;
+ }
+ }
+
+ sub _generate_getset {
+ my ($self, $name, $spec) = @_;
+ q{(@_ > 1}."\n ? ".$self->_generate_set($name, $spec)
+ ."\n : ".$self->_generate_get($name, $spec)."\n )";
+ }
+
+ sub _generate_asserter {
+ my ($self, $name, $spec) = @_;
+
+ "do {\n"
+ ." my \$val = ".$self->_generate_get($name, $spec).";\n"
+ ." unless (".$self->_generate_simple_has('$_[0]', $name, $spec).") {\n"
+ .qq! die "Attempted to access '${name}' but it is not set";\n!
+ ." }\n"
+ ." \$val;\n"
+ ."}\n";
+ }
+ sub _generate_delegation {
+ my ($self, $asserter, $target, $args) = @_;
+ my $arg_string = do {
+ if (@$args) {
+ # I could, I reckon, linearise out non-refs here using perlstring
+ # plus something to check for numbers but I'm unsure if it's worth it
+ $self->{captures}{'@curries'} = $args;
+ '@curries, @_';
+ } else {
+ '@_';
+ }
+ };
+ "shift->${asserter}->${target}(${arg_string});";
+ }
+
+ sub _generate_xs {
+ my ($self, $type, $into, $name, $slot) = @_;
+ Class::XSAccessor->import(
+ class => $into,
+ $type => { $name => $slot },
+ replace => 1,
+ );
+ $into->can($name);
+ }
+
+ sub default_construction_string { '{}' }
+
+ sub _validate_codulatable {
+ my ($self, $setting, $value, $into, $appended) = @_;
+ my $invalid = "Invalid $setting '" . overload::StrVal($value)
+ . "' for $into not a coderef";
+ $invalid .= " $appended" if $appended;
+
+ unless (ref $value and (ref $value eq 'CODE' or blessed($value))) {
+ die "$invalid or code-convertible object";
+ }
+
+ unless (eval { \&$value }) {
+ die "$invalid and could not be converted to a coderef: $@";
+ }
+
+ 1;
+ }
+
+ 1;
+METHOD_GENERATE_ACCESSOR
+
+$fatpacked{"Method/Generate/BuildAll.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_BUILDALL';
+ package Method::Generate::BuildAll;
+
+ use strictures 1;
+ use base qw(Moo::Object);
+ use Sub::Quote;
+ use Moo::_Utils;
+ use B 'perlstring';
+
+ sub generate_method {
+ my ($self, $into) = @_;
+ quote_sub "${into}::BUILDALL", join '',
+ $self->_handle_subbuild($into),
+ qq{ my \$self = shift;\n},
+ $self->buildall_body_for($into, '$self', '@_'),
+ qq{ return \$self\n};
+ }
+
+ sub _handle_subbuild {
+ my ($self, $into) = @_;
+ ' if (ref($_[0]) ne '.perlstring($into).') {'."\n".
+ ' return shift->Moo::Object::BUILDALL(@_)'.";\n".
+ ' }'."\n";
+ }
+
+ sub buildall_body_for {
+ my ($self, $into, $me, $args) = @_;
+ my @builds =
+ grep *{_getglob($_)}{CODE},
+ map "${_}::BUILD",
+ reverse @{Moo::_Utils::_get_linear_isa($into)};
+ join '', map qq{ ${me}->${_}(${args});\n}, @builds;
+ }
+
+ 1;
+METHOD_GENERATE_BUILDALL
+
+$fatpacked{"Method/Generate/Constructor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_CONSTRUCTOR';
+ package Method::Generate::Constructor;
+
+ use strictures 1;
+ use Sub::Quote;
+ use base qw(Moo::Object);
+ use Sub::Defer;
+ use B 'perlstring';
+ use Moo::_Utils qw(_getstash);
+
+ sub register_attribute_specs {
+ my ($self, @new_specs) = @_;
+ my $specs = $self->{attribute_specs}||={};
+ while (my ($name, $new_spec) = splice @new_specs, 0, 2) {
+ if ($name =~ s/^\+//) {
+ die "has '+${name}' given but no ${name} attribute already exists"
+ unless my $old_spec = $specs->{$name};
+ foreach my $key (keys %$old_spec) {
+ if (!exists $new_spec->{$key}) {
+ $new_spec->{$key} = $old_spec->{$key}
+ unless $key eq 'handles';
+ }
+ elsif ($key eq 'moosify') {
+ $new_spec->{$key} = [
+ map { ref $_ eq 'ARRAY' ? @$_ : $_ }
+ ($old_spec->{$key}, $new_spec->{$key})
+ ];
+ }
+ }
+ }
+ if (exists $new_spec->{init_arg} && !defined $new_spec->{init_arg}
+ && $new_spec->{required}) {
+ die "${name} attribute can't be required with init_arg => undef";
+ }
+ $new_spec->{index} = scalar keys %$specs
+ unless defined $new_spec->{index};
+ $specs->{$name} = $new_spec;
+ }
+ $self;
+ }
+
+ sub all_attribute_specs {
+ $_[0]->{attribute_specs}
+ }
+
+ sub accessor_generator {
+ $_[0]->{accessor_generator}
+ }
+
+ sub construction_string {
+ my ($self) = @_;
+ $self->{construction_string}
+ ||= $self->_build_construction_string;
+ }
+
+ sub buildall_generator {
+ require Method::Generate::BuildAll;
+ Method::Generate::BuildAll->new;
+ }
+
+ sub _build_construction_string {
+ my ($self) = @_;
+ my $builder = $self->{construction_builder};
+ $builder ? $self->$builder
+ : 'bless('
+ .$self->accessor_generator->default_construction_string
+ .', $class);'
+ }
+
+ sub install_delayed {
+ my ($self) = @_;
+ my $package = $self->{package};
+ defer_sub "${package}::new" => sub {
+ unquote_sub $self->generate_method(
+ $package, 'new', $self->{attribute_specs}, { no_install => 1 }
+ )
+ };
+ $self;
+ }
+
+ sub generate_method {
+ my ($self, $into, $name, $spec, $quote_opts) = @_;
+ foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
+ $spec->{$no_init}{init_arg} = $no_init;
+ }
+ local $self->{captures} = {};
+ my $body = ' my $class = shift;'."\n"
+ .' $class = ref($class) if ref($class);'."\n";
+ $body .= $self->_handle_subconstructor($into, $name);
+ my $into_buildargs = $into->can('BUILDARGS');
+ if ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS ) {
+ $body .= $self->_generate_args_via_buildargs;
+ } else {
+ $body .= $self->_generate_args;
+ }
+ $body .= $self->_check_required($spec);
+ $body .= ' my $new = '.$self->construction_string.";\n";
+ $body .= $self->_assign_new($spec);
+ if ($into->can('BUILD')) {
+ $body .= $self->buildall_generator->buildall_body_for(
+ $into, '$new', '$args'
+ );
+ }
+ $body .= ' return $new;'."\n";
+ if ($into->can('DEMOLISH')) {
+ require Method::Generate::DemolishAll;
+ Method::Generate::DemolishAll->new->generate_method($into);
+ }
+ quote_sub
+ "${into}::${name}" => $body,
+ $self->{captures}, $quote_opts||{}
+ ;
+ }
+
+ sub _handle_subconstructor {
+ my ($self, $into, $name) = @_;
+ if (my $gen = $self->{subconstructor_handler}) {
+ ' if ($class ne '.perlstring($into).') {'."\n".
+ $gen.
+ ' }'."\n";
+ } else {
+ ''
+ }
+ }
+
+ sub _cap_call {
+ my ($self, $code, $captures) = @_;
+ @{$self->{captures}}{keys %$captures} = values %$captures if $captures;
+ $code;
+ }
+
+ sub _generate_args_via_buildargs {
+ my ($self) = @_;
+ q{ my $args = $class->BUILDARGS(@_);}."\n"
+ .q{ die "BUILDARGS did not return a hashref" unless ref($args) eq 'HASH';}
+ ."\n";
+ }
+
+ # inlined from Moo::Object - update that first.
+ sub _generate_args {
+ my ($self) = @_;
+ return <<'_EOA';
+ my $args;
+ if ( scalar @_ == 1 ) {
+ unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
+ die "Single parameters to new() must be a HASH ref"
+ ." data => ". $_[0] ."\n";
+ }
+ $args = { %{ $_[0] } };
+ }
+ elsif ( @_ % 2 ) {
+ die "The new() method for $class expects a hash reference or a key/value list."
+ . " You passed an odd number of arguments\n";
+ }
+ else {
+ $args = {@_};
+ }
+ _EOA
+
+ }
+
+ sub _assign_new {
+ my ($self, $spec) = @_;
+ my $ag = $self->accessor_generator;
+ my %test;
+ NAME: foreach my $name (sort keys %$spec) {
+ my $attr_spec = $spec->{$name};
+ next NAME unless defined($attr_spec->{init_arg})
+ or $ag->has_eager_default($name, $attr_spec);
+ $test{$name} = $attr_spec->{init_arg};
+ }
+ join '', map {
+ my $arg_key = perlstring($test{$_});
+ my $test = "exists \$args->{$arg_key}";
+ my $source = "\$args->{$arg_key}";
+ my $attr_spec = $spec->{$_};
+ $self->_cap_call($ag->generate_populate_set(
+ '$new', $_, $attr_spec, $source, $test, $test{$_},
+ ));
+ } sort keys %test;
+ }
+
+ sub _check_required {
+ my ($self, $spec) = @_;
+ my @required_init =
+ map $spec->{$_}{init_arg},
+ grep {
+ my %s = %{$spec->{$_}}; # ignore required if default or builder set
+ $s{required} and not($s{builder} or $s{default})
+ } sort keys %$spec;
+ return '' unless @required_init;
+ ' if (my @missing = grep !exists $args->{$_}, qw('
+ .join(' ', at required_init).')) {'."\n"
+ .q{ die "Missing required arguments: ".join(', ', sort @missing);}."\n"
+ ." }\n";
+ }
+
+ use Moo;
+ Moo->_constructor_maker_for(__PACKAGE__)->register_attribute_specs(
+ attribute_specs => {
+ is => 'ro',
+ reader => 'all_attribute_specs',
+ },
+ accessor_generator => { is => 'ro' },
+ construction_string => { is => 'lazy' },
+ construction_builder => { is => 'lazy' },
+ subconstructor_handler => { is => 'ro' },
+ package => { is => 'ro' },
+ );
+
+ 1;
+METHOD_GENERATE_CONSTRUCTOR
+
+$fatpacked{"Method/Generate/DemolishAll.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_DEMOLISHALL';
+ package Method::Generate::DemolishAll;
+
+ use strictures 1;
+ use base qw(Moo::Object);
+ use Sub::Quote;
+ use Moo::_Utils;
+ use B qw(perlstring);
+
+ sub generate_method {
+ my ($self, $into) = @_;
+ quote_sub "${into}::DEMOLISHALL", join '',
+ $self->_handle_subdemolish($into),
+ qq{ my \$self = shift;\n},
+ $self->demolishall_body_for($into, '$self', '@_'),
+ qq{ return \$self\n};
+ quote_sub "${into}::DESTROY", join '',
+ q! my $self = shift;
+ my $e = do {
+ local $?;
+ local $@;
+ require Moo::_Utils;
+ eval {
+ $self->DEMOLISHALL(Moo::_Utils::_in_global_destruction);
+ };
+ $@;
+ };
+
+ no warnings 'misc';
+ die $e if $e; # rethrow
+ !;
+ }
+
+ sub demolishall_body_for {
+ my ($self, $into, $me, $args) = @_;
+ my @demolishers =
+ grep *{_getglob($_)}{CODE},
+ map "${_}::DEMOLISH",
+ @{Moo::_Utils::_get_linear_isa($into)};
+ join '', map qq{ ${me}->${_}(${args});\n}, @demolishers;
+ }
+
+ sub _handle_subdemolish {
+ my ($self, $into) = @_;
+ ' if (ref($_[0]) ne '.perlstring($into).') {'."\n".
+ ' return shift->Moo::Object::DEMOLISHALL(@_)'.";\n".
+ ' }'."\n";
+ }
+
+ 1;
+METHOD_GENERATE_DEMOLISHALL
+
+$fatpacked{"Method/Inliner.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_INLINER';
+ package Method::Inliner;
+
+ use strictures 1;
+ use Text::Balanced qw(extract_bracketed);
+ use Sub::Quote ();
+
+ sub slurp { do { local (@ARGV, $/) = $_[0]; <> } }
+ sub splat {
+ open my $out, '>', $_[1] or die "can't open $_[1]: $!";
+ print $out $_[0] or die "couldn't write to $_[1]: $!";
+ }
+
+ sub inlinify {
+ my $file = $_[0];
+ my @chunks = split /(^sub.*?^}$)/sm, slurp $file;
+ warn join "\n--\n", @chunks;
+ my %code;
+ foreach my $chunk (@chunks) {
+ if (my ($name, $body) =
+ $chunk =~ /^sub (\S+) {\n(.*)\n}$/s
+ ) {
+ $code{$name} = $body;
+ }
+ }
+ foreach my $chunk (@chunks) {
+ my ($me) = $chunk =~ /^sub.*{\n my \((\$\w+).*\) = \@_;\n/ or next;
+ my $meq = quotemeta $me;
+ #warn $meq, $chunk;
+ my $copy = $chunk;
+ my ($fixed, $rest);
+ while ($copy =~ s/^(.*?)${meq}->(\S+)(?=\()//s) {
+ my ($front, $name) = ($1, $2);
+ ((my $body), $rest) = extract_bracketed($copy, '()');
+ warn "spotted ${name} - ${body}";
+ if ($code{$name}) {
+ warn "replacing";
+ s/^\(//, s/\)$// for $body;
+ $body = "${me}, ".$body;
+ $fixed .= $front.Sub::Quote::inlinify($code{$name}, $body);
+ } else {
+ $fixed .= $front.$me.'->'.$name.$body;
+ }
+ #warn $fixed; warn $rest;
+ $copy = $rest;
+ }
+ $fixed .= $rest if $fixed;
+ warn $fixed if $fixed;
+ $chunk = $fixed if $fixed;
+ }
+ print join '', @chunks;
+ }
+
+ 1;
+METHOD_INLINER
+
+$fatpacked{"Module/Runtime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_RUNTIME';
+ =head1 NAME
+
+ Module::Runtime - runtime module handling
+
+ =head1 SYNOPSIS
+
+ use Module::Runtime qw(
+ $module_name_rx is_module_name check_module_name
+ module_notional_filename require_module
+ );
+
+ if($module_name =~ /\A$module_name_rx\z/o) { ...
+ if(is_module_name($module_name)) { ...
+ check_module_name($module_name);
+
+ $notional_filename = module_notional_filename($module_name);
+ require_module($module_name);
+
+ use Module::Runtime qw(use_module use_package_optimistically);
+
+ $bi = use_module("Math::BigInt", 1.31)->new("1_234");
+ $widget = use_package_optimistically("Local::Widget")->new;
+
+ use Module::Runtime qw(
+ $top_module_spec_rx $sub_module_spec_rx
+ is_module_spec check_module_spec
+ compose_module_name
+ );
+
+ if($spec =~ /\A$top_module_spec_rx\z/o) { ...
+ if($spec =~ /\A$sub_module_spec_rx\z/o) { ...
+ if(is_module_spec("Standard::Prefix", $spec)) { ...
+ check_module_spec("Standard::Prefix", $spec);
+
+ $module_name =
+ compose_module_name("Standard::Prefix", $spec);
+
+ =head1 DESCRIPTION
+
+ The functions exported by this module deal with runtime handling of
+ Perl modules, which are normally handled at compile time. This module
+ avoids using any other modules, so that it can be used in low-level
+ infrastructure.
+
+ The parts of this module that work with module names apply the same syntax
+ that is used for barewords in Perl source. In principle this syntax
+ can vary between versions of Perl, and this module applies the syntax of
+ the Perl on which it is running. In practice the usable syntax hasn't
+ changed yet. There's some intent for Unicode module names to be supported
+ in the future, but this hasn't yet amounted to any consistent facility.
+
+ The functions of this module whose purpose is to load modules include
+ workarounds for three old Perl core bugs regarding C<require>. These
+ workarounds are applied on any Perl version where the bugs exist, except
+ for a case where one of the bugs cannot be adequately worked around in
+ pure Perl.
+
+ =head2 Module name syntax
+
+ The usable module name syntax has not changed from Perl 5.000 up to
+ Perl 5.19.8. The syntax is composed entirely of ASCII characters.
+ From Perl 5.6 onwards there has been some attempt to allow the use of
+ non-ASCII Unicode characters in Perl source, but it was fundamentally
+ broken (like the entirety of Perl 5.6's Unicode handling) and remained
+ pretty much entirely unusable until it got some attention in the Perl
+ 5.15 series. Although Unicode is now consistently accepted by the
+ parser in some places, it remains broken for module names. Furthermore,
+ there has not yet been any work on how to map Unicode module names into
+ filenames, so in that respect also Unicode module names are unusable.
+
+ The module name syntax is, precisely: the string must consist of one or
+ more segments separated by C<::>; each segment must consist of one or more
+ identifier characters (ASCII alphanumerics plus "_"); the first character
+ of the string must not be a digit. Thus "C<IO::File>", "C<warnings>",
+ and "C<foo::123::x_0>" are all valid module names, whereas "C<IO::>"
+ and "C<1foo::bar>" are not. C<'> separators are not permitted by this
+ module, though they remain usable in Perl source, being translated to
+ C<::> in the parser.
+
+ =head2 Core bugs worked around
+
+ The first bug worked around is core bug [perl #68590], which causes
+ lexical state in one file to leak into another that is C<require>d/C<use>d
+ from it. This bug is present from Perl 5.6 up to Perl 5.10, and is
+ fixed in Perl 5.11.0. From Perl 5.9.4 up to Perl 5.10.0 no satisfactory
+ workaround is possible in pure Perl. The workaround means that modules
+ loaded via this module don't suffer this pollution of their lexical
+ state. Modules loaded in other ways, or via this module on the Perl
+ versions where the pure Perl workaround is impossible, remain vulnerable.
+ The module L<Lexical::SealRequireHints> provides a complete workaround
+ for this bug.
+
+ The second bug worked around causes some kinds of failure in module
+ loading, principally compilation errors in the loaded module, to be
+ recorded in C<%INC> as if they were successful, so later attempts to load
+ the same module immediately indicate success. This bug is present up
+ to Perl 5.8.9, and is fixed in Perl 5.9.0. The workaround means that a
+ compilation error in a module loaded via this module won't be cached as
+ a success. Modules loaded in other ways remain liable to produce bogus
+ C<%INC> entries, and if a bogus entry exists then it will mislead this
+ module if it is used to re-attempt loading.
+
+ The third bug worked around causes the wrong context to be seen at
+ file scope of a loaded module, if C<require> is invoked in a location
+ that inherits context from a higher scope. This bug is present up to
+ Perl 5.11.2, and is fixed in Perl 5.11.3. The workaround means that
+ a module loaded via this module will always see the correct context.
+ Modules loaded in other ways remain vulnerable.
+
+ =cut
+
+ package Module::Runtime;
+
+ # Don't "use 5.006" here, because Perl 5.15.6 will load feature.pm if
+ # the version check is done that way.
+ BEGIN { require 5.006; }
+ # Don't "use warnings" here, to avoid dependencies. Do standardise the
+ # warning status by lexical override; unfortunately the only safe bitset
+ # to build in is the empty set, equivalent to "no warnings".
+ BEGIN { ${^WARNING_BITS} = ""; }
+ # Don't "use strict" here, to avoid dependencies.
+
+ our $VERSION = "0.014";
+
+ # Don't use Exporter here, to avoid dependencies.
+ our @EXPORT_OK = qw(
+ $module_name_rx is_module_name is_valid_module_name check_module_name
+ module_notional_filename require_module
+ use_module use_package_optimistically
+ $top_module_spec_rx $sub_module_spec_rx
+ is_module_spec is_valid_module_spec check_module_spec
+ compose_module_name
+ );
+ my %export_ok = map { ($_ => undef) } @EXPORT_OK;
+ sub import {
+ my $me = shift;
+ my $callpkg = caller(0);
+ my $errs = "";
+ foreach(@_) {
+ if(exists $export_ok{$_}) {
+ # We would need to do "no strict 'refs'" here
+ # if we had enabled strict at file scope.
+ if(/\A\$(.*)\z/s) {
+ *{$callpkg."::".$1} = \$$1;
+ } else {
+ *{$callpkg."::".$_} = \&$_;
+ }
+ } else {
+ $errs .= "\"$_\" is not exported by the $me module\n";
+ }
+ }
+ if($errs ne "") {
+ die "${errs}Can't continue after import errors ".
+ "at @{[(caller(0))[1]]} line @{[(caller(0))[2]]}.\n";
+ }
+ }
+
+ # Logic duplicated from Params::Classify. Duplicating it here avoids
+ # an extensive and potentially circular dependency graph.
+ sub _is_string($) {
+ my($arg) = @_;
+ return defined($arg) && ref(\$arg) eq "SCALAR";
+ }
+
+ =head1 REGULAR EXPRESSIONS
+
+ These regular expressions do not include any anchors, so to check
+ whether an entire string matches a syntax item you must supply the
+ anchors yourself.
+
+ =over
+
+ =item $module_name_rx
+
+ Matches a valid Perl module name in bareword syntax.
+
+ =cut
+
+ our $module_name_rx = qr/[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/;
+
+ =item $top_module_spec_rx
+
+ Matches a module specification for use with L</compose_module_name>,
+ where no prefix is being used.
+
+ =cut
+
+ my $qual_module_spec_rx =
+ qr#(?:/|::)[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;
+
+ my $unqual_top_module_spec_rx =
+ qr#[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;
+
+ our $top_module_spec_rx = qr/$qual_module_spec_rx|$unqual_top_module_spec_rx/o;
+
+ =item $sub_module_spec_rx
+
+ Matches a module specification for use with L</compose_module_name>,
+ where a prefix is being used.
+
+ =cut
+
+ my $unqual_sub_module_spec_rx = qr#[0-9A-Z_a-z]+(?:(?:/|::)[0-9A-Z_a-z]+)*#;
+
+ our $sub_module_spec_rx = qr/$qual_module_spec_rx|$unqual_sub_module_spec_rx/o;
+
+ =back
+
+ =head1 FUNCTIONS
+
+ =head2 Basic module handling
+
+ =over
+
+ =item is_module_name(ARG)
+
+ Returns a truth value indicating whether I<ARG> is a plain string
+ satisfying Perl module name syntax as described for L</$module_name_rx>.
+
+ =cut
+
+ sub is_module_name($) { _is_string($_[0]) && $_[0] =~ /\A$module_name_rx\z/o }
+
+ =item is_valid_module_name(ARG)
+
+ Deprecated alias for L</is_module_name>.
+
+ =cut
+
+ *is_valid_module_name = \&is_module_name;
+
+ =item check_module_name(ARG)
+
+ Check whether I<ARG> is a plain string
+ satisfying Perl module name syntax as described for L</$module_name_rx>.
+ Return normally if it is, or C<die> if it is not.
+
+ =cut
+
+ sub check_module_name($) {
+ unless(&is_module_name) {
+ die +(_is_string($_[0]) ? "`$_[0]'" : "argument").
+ " is not a module name\n";
+ }
+ }
+
+ =item module_notional_filename(NAME)
+
+ Generates a notional relative filename for a module, which is used in
+ some Perl core interfaces.
+ The I<NAME> is a string, which should be a valid module name (one or
+ more C<::>-separated segments). If it is not a valid name, the function
+ C<die>s.
+
+ The notional filename for the named module is generated and returned.
+ This filename is always in Unix style, with C</> directory separators
+ and a C<.pm> suffix. This kind of filename can be used as an argument to
+ C<require>, and is the key that appears in C<%INC> to identify a module,
+ regardless of actual local filename syntax.
+
+ =cut
+
+ sub module_notional_filename($) {
+ &check_module_name;
+ my($name) = @_;
+ $name =~ s!::!/!g;
+ return $name.".pm";
+ }
+
+ =item require_module(NAME)
+
+ This is essentially the bareword form of C<require>, in runtime form.
+ The I<NAME> is a string, which should be a valid module name (one or
+ more C<::>-separated segments). If it is not a valid name, the function
+ C<die>s.
+
+ The module specified by I<NAME> is loaded, if it hasn't been already,
+ in the manner of the bareword form of C<require>. That means that a
+ search through C<@INC> is performed, and a byte-compiled form of the
+ module will be used if available.
+
+ The return value is as for C<require>. That is, it is the value returned
+ by the module itself if the module is loaded anew, or C<1> if the module
+ was already loaded.
+
+ =cut
+
+ # Don't "use constant" here, to avoid dependencies.
+ BEGIN {
+ *_WORK_AROUND_HINT_LEAKAGE =
+ "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001)
+ ? sub(){1} : sub(){0};
+ *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0};
+ }
+
+ BEGIN { if(_WORK_AROUND_BROKEN_MODULE_STATE) { eval q{
+ sub Module::Runtime::__GUARD__::DESTROY {
+ delete $INC{$_[0]->[0]} if @{$_[0]};
+ }
+ 1;
+ }; die $@ if $@ ne ""; } }
+
+ sub require_module($) {
+ # Localise %^H to work around [perl #68590], where the bug exists
+ # and this is a satisfactory workaround. The bug consists of
+ # %^H state leaking into each required module, polluting the
+ # module's lexical state.
+ local %^H if _WORK_AROUND_HINT_LEAKAGE;
+ if(_WORK_AROUND_BROKEN_MODULE_STATE) {
+ my $notional_filename = &module_notional_filename;
+ my $guard = bless([ $notional_filename ],
+ "Module::Runtime::__GUARD__");
+ my $result = CORE::require($notional_filename);
+ pop @$guard;
+ return $result;
+ } else {
+ return scalar(CORE::require(&module_notional_filename));
+ }
+ }
+
+ =back
+
+ =head2 Structured module use
+
+ =over
+
+ =item use_module(NAME[, VERSION])
+
+ This is essentially C<use> in runtime form, but without the importing
+ feature (which is fundamentally a compile-time thing). The I<NAME> is
+ handled just like in C<require_module> above: it must be a module name,
+ and the named module is loaded as if by the bareword form of C<require>.
+
+ If a I<VERSION> is specified, the C<VERSION> method of the loaded module is
+ called with the specified I<VERSION> as an argument. This normally serves to
+ ensure that the version loaded is at least the version required. This is
+ the same functionality provided by the I<VERSION> parameter of C<use>.
+
+ On success, the name of the module is returned. This is unlike
+ L</require_module>, and is done so that the entire call to L</use_module>
+ can be used as a class name to call a constructor, as in the example in
+ the synopsis.
+
+ =cut
+
+ sub use_module($;$) {
+ my($name, $version) = @_;
+ require_module($name);
+ $name->VERSION($version) if @_ >= 2;
+ return $name;
+ }
+
+ =item use_package_optimistically(NAME[, VERSION])
+
+ This is an analogue of L</use_module> for the situation where there is
+ uncertainty as to whether a package/class is defined in its own module
+ or by some other means. It attempts to arrange for the named package to
+ be available, either by loading a module or by doing nothing and hoping.
+
+ An attempt is made to load the named module (as if by the bareword form
+ of C<require>). If the module cannot be found then it is assumed that
+ the package was actually already loaded by other means, and no error
+ is signalled. That's the optimistic bit.
+
+ This is mostly the same operation that is performed by the L<base> pragma
+ to ensure that the specified base classes are available. The behaviour
+ of L<base> was simplified in version 2.18, and later improved in version
+ 2.20, and on both occasions this function changed to match.
+
+ If a I<VERSION> is specified, the C<VERSION> method of the loaded package is
+ called with the specified I<VERSION> as an argument. This normally serves
+ to ensure that the version loaded is at least the version required.
+ On success, the name of the package is returned. These aspects of the
+ function work just like L</use_module>.
+
+ =cut
+
+ sub use_package_optimistically($;$) {
+ my($name, $version) = @_;
+ my $fn = module_notional_filename($name);
+ eval { local $SIG{__DIE__}; require_module($name); };
+ die $@ if $@ ne "" &&
+ ($@ !~ /\ACan't locate \Q$fn\E .+ at \Q@{[__FILE__]}\E line/s ||
+ $@ =~ /^Compilation\ failed\ in\ require
+ \ at\ \Q@{[__FILE__]}\E\ line/xm);
+ $name->VERSION($version) if @_ >= 2;
+ return $name;
+ }
+
+ =back
+
+ =head2 Module name composition
+
+ =over
+
+ =item is_module_spec(PREFIX, SPEC)
+
+ Returns a truth value indicating
+ whether I<SPEC> is valid input for L</compose_module_name>.
+ See below for what that entails. Whether a I<PREFIX> is supplied affects
+ the validity of I<SPEC>, but the exact value of the prefix is unimportant,
+ so this function treats I<PREFIX> as a truth value.
+
+ =cut
+
+ sub is_module_spec($$) {
+ my($prefix, $spec) = @_;
+ return _is_string($spec) &&
+ $spec =~ ($prefix ? qr/\A$sub_module_spec_rx\z/o :
+ qr/\A$top_module_spec_rx\z/o);
+ }
+
+ =item is_valid_module_spec(PREFIX, SPEC)
+
+ Deprecated alias for L</is_module_spec>.
+
+ =cut
+
+ *is_valid_module_spec = \&is_module_spec;
+
+ =item check_module_spec(PREFIX, SPEC)
+
+ Check whether I<SPEC> is valid input for L</compose_module_name>.
+ Return normally if it is, or C<die> if it is not.
+
+ =cut
+
+ sub check_module_spec($$) {
+ unless(&is_module_spec) {
+ die +(_is_string($_[1]) ? "`$_[1]'" : "argument").
+ " is not a module specification\n";
+ }
+ }
+
+ =item compose_module_name(PREFIX, SPEC)
+
+ This function is intended to make it more convenient for a user to specify
+ a Perl module name at runtime. Users have greater need for abbreviations
+ and context-sensitivity than programmers, and Perl module names get a
+ little unwieldy. I<SPEC> is what the user specifies, and this function
+ translates it into a module name in standard form, which it returns.
+
+ I<SPEC> has syntax approximately that of a standard module name: it
+ should consist of one or more name segments, each of which consists
+ of one or more identifier characters. However, C</> is permitted as a
+ separator, in addition to the standard C<::>. The two separators are
+ entirely interchangeable.
+
+ Additionally, if I<PREFIX> is not C<undef> then it must be a module
+ name in standard form, and it is prefixed to the user-specified name.
+ The user can inhibit the prefix addition by starting I<SPEC> with a
+ separator (either C</> or C<::>).
+
+ =cut
+
+ sub compose_module_name($$) {
+ my($prefix, $spec) = @_;
+ check_module_name($prefix) if defined $prefix;
+ &check_module_spec;
+ if($spec =~ s#\A(?:/|::)##) {
+ # OK
+ } else {
+ $spec = $prefix."::".$spec if defined $prefix;
+ }
+ $spec =~ s#/#::#g;
+ return $spec;
+ }
+
+ =back
+
+ =head1 BUGS
+
+ On Perl versions 5.7.2 to 5.8.8, if C<require> is overridden by the
+ C<CORE::GLOBAL> mechanism, it is likely to break the heuristics used by
+ L</use_package_optimistically>, making it signal an error for a missing
+ module rather than assume that it was already loaded. From Perl 5.8.9
+ onwards, and on 5.7.1 and earlier, this module can avoid being confused
+ by such an override. On the affected versions, a C<require> override
+ might be installed by L<Lexical::SealRequireHints>, if something requires
+ its bugfix but for some reason its XS implementation isn't available.
+
+ =head1 SEE ALSO
+
+ L<Lexical::SealRequireHints>,
+ L<base>,
+ L<perlfunc/require>,
+ L<perlfunc/use>
+
+ =head1 AUTHOR
+
+ Andrew Main (Zefram) <zefram at fysh.org>
+
+ =head1 COPYRIGHT
+
+ Copyright (C) 2004, 2006, 2007, 2009, 2010, 2011, 2012, 2014
+ Andrew Main (Zefram) <zefram at fysh.org>
+
+ =head1 LICENSE
+
+ This module is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+ =cut
+
+ 1;
+MODULE_RUNTIME
+
+$fatpacked{"Moo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO';
+ package Moo;
+
+ use strictures 1;
+ use Moo::_Utils;
+ use B 'perlstring';
+ use Sub::Defer ();
+ use Import::Into;
+
+ our $VERSION = '1.004002';
+ $VERSION = eval $VERSION;
+
+ require Moo::sification;
+
+ our %MAKERS;
+
+ sub _install_tracked {
+ my ($target, $name, $code) = @_;
+ $MAKERS{$target}{exports}{$name} = $code;
+ _install_coderef "${target}::${name}" => "Moo::${name}" => $code;
+ }
+
+ sub import {
+ my $target = caller;
+ my $class = shift;
+ _set_loaded(caller);
+ strictures->import::into(1);
+ if ($Role::Tiny::INFO{$target} and $Role::Tiny::INFO{$target}{is_role}) {
+ die "Cannot import Moo into a role";
+ }
+ $MAKERS{$target} ||= {};
+ _install_tracked $target => extends => sub {
+ $class->_set_superclasses($target, @_);
+ $class->_maybe_reset_handlemoose($target);
+ return;
+ };
+ _install_tracked $target => with => sub {
+ require Moo::Role;
+ Moo::Role->apply_roles_to_package($target, @_);
+ $class->_maybe_reset_handlemoose($target);
+ };
+ _install_tracked $target => has => sub {
+ my $name_proto = shift;
+ my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto;
+ if (@_ % 2 != 0) {
+ require Carp;
+ Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto)
+ . " attribute(s): even number of arguments expected, got " . scalar @_)
+ }
+ my %spec = @_;
+ foreach my $name (@name_proto) {
+ # Note that when multiple attributes specified, each attribute
+ # needs a separate \%specs hashref
+ my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
+ $class->_constructor_maker_for($target)
+ ->register_attribute_specs($name, $spec_ref);
+ $class->_accessor_maker_for($target)
+ ->generate_method($target, $name, $spec_ref);
+ $class->_maybe_reset_handlemoose($target);
+ }
+ return;
+ };
+ foreach my $type (qw(before after around)) {
+ _install_tracked $target => $type => sub {
+ require Class::Method::Modifiers;
+ _install_modifier($target, $type, @_);
+ return;
+ };
+ }
+ return if $MAKERS{$target}{is_class}; # already exported into this package
+ my $stash = _getstash($target);
+ my @not_methods = map { *$_{CODE}||() } grep !ref($_), values %$stash;
+ @{$MAKERS{$target}{not_methods}={}}{@not_methods} = @not_methods;
+ $MAKERS{$target}{is_class} = 1;
+ {
+ no strict 'refs';
+ @{"${target}::ISA"} = do {
+ require Moo::Object; ('Moo::Object');
+ } unless @{"${target}::ISA"};
+ }
+ if ($INC{'Moo/HandleMoose.pm'}) {
+ Moo::HandleMoose::inject_fake_metaclass_for($target);
+ }
+ }
+
+ sub unimport {
+ my $target = caller;
+ _unimport_coderefs($target, $MAKERS{$target});
+ }
+
+ sub _set_superclasses {
+ my $class = shift;
+ my $target = shift;
+ foreach my $superclass (@_) {
+ _load_module($superclass);
+ if ($INC{"Role/Tiny.pm"} && $Role::Tiny::INFO{$superclass}) {
+ require Carp;
+ Carp::croak("Can't extend role '$superclass'");
+ }
+ }
+ # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA
+ @{*{_getglob("${target}::ISA")}{ARRAY}} = @_;
+ if (my $old = delete $Moo::MAKERS{$target}{constructor}) {
+ delete _getstash($target)->{new};
+ Moo->_constructor_maker_for($target)
+ ->register_attribute_specs(%{$old->all_attribute_specs});
+ }
+ elsif (!$target->isa('Moo::Object')) {
+ Moo->_constructor_maker_for($target);
+ }
+ no warnings 'once'; # piss off. -- mst
+ $Moo::HandleMoose::MOUSE{$target} = [
+ grep defined, map Mouse::Util::find_meta($_), @_
+ ] if Mouse::Util->can('find_meta');
+ }
+
+ sub _maybe_reset_handlemoose {
+ my ($class, $target) = @_;
+ if ($INC{"Moo/HandleMoose.pm"}) {
+ Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
+ }
+ }
+
+ sub _accessor_maker_for {
+ my ($class, $target) = @_;
+ return unless $MAKERS{$target};
+ $MAKERS{$target}{accessor} ||= do {
+ my $maker_class = do {
+ if (my $m = do {
+ if (my $defer_target =
+ (Sub::Defer::defer_info($target->can('new'))||[])->[0]
+ ) {
+ my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
+ $MAKERS{$pkg} && $MAKERS{$pkg}{accessor};
+ } else {
+ undef;
+ }
+ }) {
+ ref($m);
+ } else {
+ require Method::Generate::Accessor;
+ 'Method::Generate::Accessor'
+ }
+ };
+ $maker_class->new;
+ }
+ }
+
+ sub _constructor_maker_for {
+ my ($class, $target, $select_super) = @_;
+ return unless $MAKERS{$target};
+ $MAKERS{$target}{constructor} ||= do {
+ require Method::Generate::Constructor;
+ require Sub::Defer;
+ my ($moo_constructor, $con);
+
+ if ($select_super && $MAKERS{$select_super}) {
+ $moo_constructor = 1;
+ $con = $MAKERS{$select_super}{constructor};
+ } else {
+ my $t_new = $target->can('new');
+ if ($t_new) {
+ if ($t_new == Moo::Object->can('new')) {
+ $moo_constructor = 1;
+ } elsif (my $defer_target = (Sub::Defer::defer_info($t_new)||[])->[0]) {
+ my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
+ if ($MAKERS{$pkg}) {
+ $moo_constructor = 1;
+ $con = $MAKERS{$pkg}{constructor};
+ }
+ }
+ } else {
+ $moo_constructor = 1; # no other constructor, make a Moo one
+ }
+ }
+ ($con ? ref($con) : 'Method::Generate::Constructor')
+ ->new(
+ package => $target,
+ accessor_generator => $class->_accessor_maker_for($target),
+ $moo_constructor ? (
+ $con ? (construction_string => $con->construction_string) : ()
+ ) : (
+ construction_builder => sub {
+ '$class->'.$target.'::SUPER::new('
+ .($target->can('FOREIGNBUILDARGS') ?
+ '$class->FOREIGNBUILDARGS(@_)' : '@_')
+ .')'
+ },
+ ),
+ subconstructor_handler => (
+ ' if ($Moo::MAKERS{$class}) {'."\n"
+ .' '.$class.'->_constructor_maker_for($class,'.perlstring($target).');'."\n"
+ .' return $class->new(@_)'.";\n"
+ .' } elsif ($INC{"Moose.pm"} and my $meta = Class::MOP::get_metaclass_by_name($class)) {'."\n"
+ .' return $meta->new_object($class->BUILDARGS(@_));'."\n"
+ .' }'."\n"
+ ),
+ )
+ ->install_delayed
+ ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}})
+ }
+ }
+
+ sub _concrete_methods_of {
+ my ($me, $role) = @_;
+ my $makers = $MAKERS{$role};
+ # grab role symbol table
+ my $stash = _getstash($role);
+ # reverse so our keys become the values (captured coderefs) in case
+ # they got copied or re-used since
+ my $not_methods = { reverse %{$makers->{not_methods}||{}} };
+ +{
+ # grab all code entries that aren't in the not_methods list
+ map {
+ my $code = *{$stash->{$_}}{CODE};
+ ( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code)
+ } grep !ref($stash->{$_}), keys %$stash
+ };
+ }
+
+ 1;
+ __END__
+
+ =pod
+
+ =encoding utf-8
+
+ =head1 NAME
+
+ Moo - Minimalist Object Orientation (with Moose compatibility)
+
+ =head1 SYNOPSIS
+
+ package Cat::Food;
+
+ use Moo;
+ use namespace::clean;
+
+ sub feed_lion {
+ my $self = shift;
+ my $amount = shift || 1;
+
+ $self->pounds( $self->pounds - $amount );
+ }
+
+ has taste => (
+ is => 'ro',
+ );
+
+ has brand => (
+ is => 'ro',
+ isa => sub {
+ die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ'
+ },
+ );
+
+ has pounds => (
+ is => 'rw',
+ isa => sub { die "$_[0] is too much cat food!" unless $_[0] < 15 },
+ );
+
+ 1;
+
+ And elsewhere:
+
+ my $full = Cat::Food->new(
+ taste => 'DELICIOUS.',
+ brand => 'SWEET-TREATZ',
+ pounds => 10,
+ );
+
+ $full->feed_lion;
+
+ say $full->pounds;
+
+ =head1 DESCRIPTION
+
+ This module is an extremely light-weight subset of L<Moose> optimised for
+ rapid startup and "pay only for what you use".
+
+ It also avoids depending on any XS modules to allow simple deployments. The
+ name C<Moo> is based on the idea that it provides almost -- but not quite -- two
+ thirds of L<Moose>.
+
+ Unlike L<Mouse> this module does not aim at full compatibility with
+ L<Moose>'s surface syntax, preferring instead of provide full interoperability
+ via the metaclass inflation capabilities described in L</MOO AND MOOSE>.
+
+ For a full list of the minor differences between L<Moose> and L<Moo>'s surface
+ syntax, see L</INCOMPATIBILITIES WITH MOOSE>.
+
+ =head1 WHY MOO EXISTS
+
+ If you want a full object system with a rich Metaprotocol, L<Moose> is
+ already wonderful.
+
+ However, sometimes you're writing a command line script or a CGI script
+ where fast startup is essential, or code designed to be deployed as a single
+ file via L<App::FatPacker>, or you're writing a CPAN module and you want it
+ to be usable by people with those constraints.
+
+ I've tried several times to use L<Mouse> but it's 3x the size of Moo and
+ takes longer to load than most of my Moo based CGI scripts take to run.
+
+ If you don't want L<Moose>, you don't want "less metaprotocol" like L<Mouse>,
+ you want "as little as possible" -- which means "no metaprotocol", which is
+ what Moo provides.
+
+ Better still, if you install and load L<Moose>, we set up metaclasses for your
+ L<Moo> classes and L<Moo::Role> roles, so you can use them in L<Moose> code
+ without ever noticing that some of your codebase is using L<Moo>.
+
+ Hence, Moo exists as its name -- Minimal Object Orientation -- with a pledge
+ to make it smooth to upgrade to L<Moose> when you need more than minimal
+ features.
+
+ =head1 MOO AND MOOSE
+
+ If L<Moo> detects L<Moose> being loaded, it will automatically register
+ metaclasses for your L<Moo> and L<Moo::Role> packages, so you should be able
+ to use them in L<Moose> code without anybody ever noticing you aren't using
+ L<Moose> everywhere.
+
+ L<Moo> will also create L<Moose type constraints|Moose::Manual::Types> for
+ classes and roles, so that C<< isa => 'MyClass' >> and C<< isa => 'MyRole' >>
+ work the same as for L<Moose> classes and roles.
+
+ Extending a L<Moose> class or consuming a L<Moose::Role> will also work.
+
+ So will extending a L<Mouse> class or consuming a L<Mouse::Role> - but note
+ that we don't provide L<Mouse> metaclasses or metaroles so the other way
+ around doesn't work. This feature exists for L<Any::Moose> users porting to
+ L<Moo>; enabling L<Mouse> users to use L<Moo> classes is not a priority for us.
+
+ This means that there is no need for anything like L<Any::Moose> for Moo
+ code - Moo and Moose code should simply interoperate without problem. To
+ handle L<Mouse> code, you'll likely need an empty Moo role or class consuming
+ or extending the L<Mouse> stuff since it doesn't register true L<Moose>
+ metaclasses like L<Moo> does.
+
+ If you want types to be upgraded to the L<Moose> types, use
+ L<MooX::Types::MooseLike> and install the L<MooseX::Types> library to
+ match the L<MooX::Types::MooseLike> library you're using - L<Moo> will
+ load the L<MooseX::Types> library and use that type for the newly created
+ metaclass.
+
+ If you need to disable the metaclass creation, add:
+
+ no Moo::sification;
+
+ to your code before Moose is loaded, but bear in mind that this switch is
+ currently global and turns the mechanism off entirely so don't put this
+ in library code.
+
+ =head1 MOO AND CLASS::XSACCESSOR
+
+ If a new enough version of L<Class::XSAccessor> is available, it
+ will be used to generate simple accessors, readers, and writers for
+ a speed boost. Simple accessors are those without lazy defaults,
+ type checks/coercions, or triggers. Readers and writers generated
+ by L<Class::XSAccessor> will behave slightly differently: they will
+ reject attempts to call them with the incorrect number of parameters.
+
+ =head1 MOO VERSUS ANY::MOOSE
+
+ L<Any::Moose> will load L<Mouse> normally, and L<Moose> in a program using
+ L<Moose> - which theoretically allows you to get the startup time of L<Mouse>
+ without disadvantaging L<Moose> users.
+
+ Sadly, this doesn't entirely work, since the selection is load order dependent
+ - L<Moo>'s metaclass inflation system explained above in L</MOO AND MOOSE> is
+ significantly more reliable.
+
+ So if you want to write a CPAN module that loads fast or has only pure perl
+ dependencies but is also fully usable by L<Moose> users, you should be using
+ L<Moo>.
+
+ For a full explanation, see the article
+ L<http://shadow.cat/blog/matt-s-trout/moo-versus-any-moose> which explains
+ the differing strategies in more detail and provides a direct example of
+ where L<Moo> succeeds and L<Any::Moose> fails.
+
+ =head1 IMPORTED METHODS
+
+ =head2 new
+
+ Foo::Bar->new( attr1 => 3 );
+
+ or
+
+ Foo::Bar->new({ attr1 => 3 });
+
+ =head2 BUILDARGS
+
+ sub BUILDARGS {
+ my ( $class, @args ) = @_;
+
+ unshift @args, "attr1" if @args % 2 == 1;
+
+ return { @args };
+ };
+
+ Foo::Bar->new( 3 );
+
+ The default implementation of this method accepts a hash or hash reference of
@@ Diff output truncated at 100000 characters. @@
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
More information about the devel
mailing list