diff --git a/lib/App/ModuleBuildTiny.pm b/lib/App/ModuleBuildTiny.pm index 36f390b..d67f5fc 100644 --- a/lib/App/ModuleBuildTiny.pm +++ b/lib/App/ModuleBuildTiny.pm @@ -8,18 +8,23 @@ use Exporter 5.57 'import'; our @EXPORT = qw/modulebuildtiny/; use Config; -use CPAN::Meta; -use Data::Section::Simple 'get_data_section'; +use CPAN::Meta; # XXX Not core +# CPAN::Meta::Prereqs::Filter XXX not core +use Data::Section::Simple 'get_data_section'; # XXX not core use Encode qw/encode_utf8 decode_utf8/; use ExtUtils::Manifest 1.75 qw/manifind maniskip maniread/; use File::Basename qw/dirname/; use File::Path qw/mkpath/; -use File::Slurper qw/write_text write_binary read_binary/; use File::Spec::Functions qw/catfile rel2abs/; use Getopt::Long 2.36 'GetOptionsFromArray'; use JSON::PP qw/decode_json/; -use Module::Runtime 'require_module'; -use Text::Template; +use App::ModuleBuildTiny::Utils qw( + require_module + write_text + write_binary + read_binary +); +use Text::Template; # XXX not core use App::ModuleBuildTiny::Dist; diff --git a/lib/App/ModuleBuildTiny/Dist.pm b/lib/App/ModuleBuildTiny/Dist.pm index 0d7d485..2606853 100644 --- a/lib/App/ModuleBuildTiny/Dist.pm +++ b/lib/App/ModuleBuildTiny/Dist.pm @@ -4,17 +4,21 @@ use 5.014; use warnings; our $VERSION = '0.042'; -use CPAN::Meta; +use CPAN::Meta; # XXX Not core use Config; use Encode qw/encode_utf8 decode_utf8/; use File::Basename qw/basename dirname/; use File::Copy qw/copy/; use File::Path qw/mkpath rmtree/; use File::Spec::Functions qw/catfile catdir rel2abs/; -use File::Slurper qw/write_text read_text read_binary/; -use File::chdir; +use File::chdir; # XXX Not core use ExtUtils::Manifest qw/manifind maniskip maniread/; -use Module::Runtime 'require_module'; +use App::ModuleBuildTiny::Utils qw( + require_module + write_text + write_binary + read_binary +); use Module::Metadata 1.000037; use Pod::Escapes qw/e2char/; use Pod::Simple::Text 3.23; diff --git a/lib/App/ModuleBuildTiny/Utils.pm b/lib/App/ModuleBuildTiny/Utils.pm new file mode 100644 index 0000000..1c3d9da --- /dev/null +++ b/lib/App/ModuleBuildTiny/Utils.pm @@ -0,0 +1,155 @@ +package App::ModuleBuildTiny::Utils; + +use 5.014; +use warnings; +our $VERSION = '0.042'; + +use Encode 2.11 qw/FB_CROAK STOP_AT_PARTIAL/; +use PerlIO::encoding; +use Carp; + +use Exporter 5.57 'import'; +our @EXPORT_OK = qw( + require_module + write_text + write_binary + read_binary +); + +# START: Copied from Module::Runtime +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 App::ModuleBuiltTiny::Utils::__GUARD__::DESTROY { + delete $INC{$_[0]->[0]} if @{$_[0]}; + } + 1; +}; + die $@ if $@ ne ""; + } +} + +our $module_name_rx = qr/[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/; + +sub _is_string($) { + my($arg) = @_; + return defined($arg) && ref(\$arg) eq "SCALAR"; +} + +sub is_module_name($) { _is_string($_[0]) && $_[0] =~ /\A$module_name_rx\z/o } + +sub check_module_name($) { + unless(&is_module_name) { + die +(_is_string($_[0]) ? "`$_[0]'" : "argument"). + " is not a module name\n"; + } +} + + +sub module_notional_filename($) { + &check_module_name; + my($name) = @_; + $name =~ s!::!/!g; + return $name.".pm"; +} + +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], + "App::ModuleBuiltTiny::Utils::__GUARD__" ); + my $result = CORE::require($notional_filename); + pop @$guard; + return $result; + } + else { + return scalar( CORE::require(&module_notional_filename) ); + } +} + +# END: Copied from Module::Runtime + +# START: Copied from File::Slurper + +sub read_binary { + my $filename = shift; + + # This logic is a bit ugly, but gives a significant speed boost + # because slurpy readline is not optimized for non-buffered usage + open my $fh, '<:unix', $filename or croak "Couldn't open $filename: $!"; + if ( my $size = -s $fh ) { + my $buf; + my ( $pos, $read ) = 0; + do { + defined( $read = read $fh, ${$buf}, $size - $pos, $pos ) + or croak "Couldn't read $filename: $!"; + $pos += $read; + } while ( $read && $pos < $size ); + return ${$buf}; + } + else { + return do { local $/; <$fh> }; + } +} + +use constant { + CRLF_DEFAULT => $^O eq 'MSWin32', + HAS_UTF8_STRICT => scalar do { + local $@; + eval { require PerlIO::utf8_strict } + }, +}; + +sub _text_layers { + my ( $encoding, $crlf ) = @_; + $crlf = CRLF_DEFAULT if $crlf && $crlf eq 'auto'; + + if ( HAS_UTF8_STRICT && $encoding =~ /^utf-?8\b/i ) { + return $crlf ? ':unix:utf8_strict:crlf' : ':unix:utf8_strict'; + } + else { + # non-ascii compatible encodings such as UTF-16 need encoding before crlf + return $crlf + ? ":raw:encoding($encoding):crlf" + : ":raw:encoding($encoding)"; + } +} + +sub write_text { + my ( $filename, undef, $encoding, $crlf ) = @_; + $encoding ||= 'utf-8'; + my $layer = _text_layers( $encoding, $crlf ); + + local $PerlIO::encoding::fallback = STOP_AT_PARTIAL | FB_CROAK; + open my $fh, ">$layer", $filename or croak "Couldn't open $filename: $!"; + print $fh $_[1] or croak "Couldn't write to $filename: $!"; + close $fh or croak "Couldn't write to $filename: $!"; + return; +} + +sub write_binary { + my $filename = $_[0]; + open my $fh, ">:raw", $filename or croak "Couldn't open $filename: $!"; + print $fh $_[1] or croak "Couldn't write to $filename: $!"; + close $fh or croak "Couldn't write to $filename: $!"; + return; +} + +# END: copied from File::Slurper + +1;