Hello community, here is the log from the commit of package perl-Sub-Quote for openSUSE:Factory checked in at 2017-06-09 15:58:07 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/perl-Sub-Quote (Old) and /work/SRC/openSUSE:Factory/.perl-Sub-Quote.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "perl-Sub-Quote" Fri Jun 9 15:58:07 2017 rev:2 rq:502480 version:2.004000 Changes: -------- --- /work/SRC/openSUSE:Factory/perl-Sub-Quote/perl-Sub-Quote.changes 2017-01-22 00:49:48.291584965 +0100 +++ /work/SRC/openSUSE:Factory/.perl-Sub-Quote.new/perl-Sub-Quote.changes 2017-06-09 15:58:12.472890277 +0200 @@ -1,0 +2,13 @@ +Fri Jun 9 06:25:54 UTC 2017 - [email protected] + +- updated to 2.004000 + see /usr/share/doc/packages/perl-Sub-Quote/Changes + + 2.004000 - 2017-06-07 + - more extensive quotify tests + - split tests into separate files + - propagate package to deferred subs, even if unnamed + - reject invalid attributes + - include line numbers compile errors (PR#1, djerius) + +------------------------------------------------------------------- Old: ---- Sub-Quote-2.003001.tar.gz New: ---- Sub-Quote-2.004000.tar.gz cpanspec.yml ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ perl-Sub-Quote.spec ++++++ --- /var/tmp/diff_new_pack.Ts5mqn/_old 2017-06-09 15:58:14.032670129 +0200 +++ /var/tmp/diff_new_pack.Ts5mqn/_new 2017-06-09 15:58:14.032670129 +0200 @@ -17,14 +17,15 @@ Name: perl-Sub-Quote -Version: 2.003001 +Version: 2.004000 Release: 0 %define cpan_name Sub-Quote -Summary: Efficient Generation of Subroutines Via String Eval +Summary: Efficient generation of subroutines via string eval License: Artistic-1.0 or GPL-1.0+ Group: Development/Libraries/Perl Url: http://search.cpan.org/dist/Sub-Quote/ -Source0: http://www.cpan.org/authors/id/H/HA/HAARG/%{cpan_name}-%{version}.tar.gz +Source0: https://cpan.metacpan.org/authors/id/H/HA/HAARG/%{cpan_name}-%{version}.tar.gz +Source1: cpanspec.yml BuildArch: noarch BuildRoot: %{_tmppath}/%{name}-%{version}-build BuildRequires: perl ++++++ Sub-Quote-2.003001.tar.gz -> Sub-Quote-2.004000.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/Changes new/Sub-Quote-2.004000/Changes --- old/Sub-Quote-2.003001/Changes 2016-12-09 09:20:22.000000000 +0100 +++ new/Sub-Quote-2.004000/Changes 2017-06-07 03:08:49.000000000 +0200 @@ -1,5 +1,12 @@ Revision history for Sub::Quote +2.004000 - 2017-06-07 + - more extensive quotify tests + - split tests into separate files + - propagate package to deferred subs, even if unnamed + - reject invalid attributes + - include line numbers compile errors (PR#1, djerius) + 2.003001 - 2016-12-09 - fix use of Sub::Name diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/MANIFEST new/Sub-Quote-2.004000/MANIFEST --- old/Sub-Quote-2.003001/MANIFEST 2016-12-09 09:20:32.000000000 +0100 +++ new/Sub-Quote-2.004000/MANIFEST 2017-06-07 03:30:43.000000000 +0200 @@ -5,8 +5,12 @@ Makefile.PL MANIFEST This list of files t/croak-locations.t +t/hints.t +t/inline.t +t/leaks.t t/lib/ErrorLocation.pm t/lib/InlineModule.pm +t/quotify.t t/sub-defer-no-subname.t t/sub-defer-threads.t t/sub-defer.t diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/META.json new/Sub-Quote-2.004000/META.json --- old/Sub-Quote-2.003001/META.json 2016-12-09 09:20:32.000000000 +0100 +++ new/Sub-Quote-2.004000/META.json 2017-06-07 03:30:43.000000000 +0200 @@ -1,5 +1,5 @@ { - "abstract" : "efficient generation of subroutines via string eval", + "abstract" : "Efficient generation of subroutines via string eval", "author" : [ "mst - Matt S. Trout (cpan:MSTROUT) <[email protected]>" ], @@ -10,7 +10,7 @@ ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec";, - "version" : "2" + "version" : 2 }, "name" : "Sub-Quote", "no_index" : { @@ -63,7 +63,7 @@ }, "x_IRC" : "irc://irc.perl.org/#moose" }, - "version" : "2.003001", + "version" : "2.004000", "x_authority" : "cpan:MSTROUT", - "x_serialization_backend" : "JSON::PP version 2.27300" + "x_serialization_backend" : "JSON::PP version 2.94" } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/META.yml new/Sub-Quote-2.004000/META.yml --- old/Sub-Quote-2.003001/META.yml 2016-12-09 09:20:32.000000000 +0100 +++ new/Sub-Quote-2.004000/META.yml 2017-06-07 03:30:42.000000000 +0200 @@ -1,5 +1,5 @@ --- -abstract: 'efficient generation of subroutines via string eval' +abstract: 'Efficient generation of subroutines via string eval' author: - 'mst - Matt S. Trout (cpan:MSTROUT) <[email protected]>' build_requires: @@ -28,6 +28,6 @@ bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote license: http://dev.perl.org/licenses/ repository: https://github.com/moose/Sub-Quote.git -version: '2.003001' +version: '2.004000' x_authority: cpan:MSTROUT x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/README new/Sub-Quote-2.004000/README --- old/Sub-Quote-2.003001/README 2016-12-09 09:20:32.000000000 +0100 +++ new/Sub-Quote-2.004000/README 2017-06-07 03:30:43.000000000 +0200 @@ -1,5 +1,5 @@ NAME - Sub::Quote - efficient generation of subroutines via string eval + Sub::Quote - Efficient generation of subroutines via string eval SYNOPSIS package Silly; @@ -221,6 +221,8 @@ kanashiro - Lucas Kanashiro (cpan:KANASHIRO) <[email protected]> + djerius - Diab Jerius (cpan:DJERIUS) <[email protected]> + COPYRIGHT Copyright (c) 2010-2016 the Sub::Quote "AUTHOR" and "CONTRIBUTORS" as listed above. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/lib/Sub/Defer.pm new/Sub-Quote-2.004000/lib/Sub/Defer.pm --- old/Sub-Quote-2.003001/lib/Sub/Defer.pm 2016-12-09 09:20:18.000000000 +0100 +++ new/Sub-Quote-2.004000/lib/Sub/Defer.pm 2017-06-07 03:08:15.000000000 +0200 @@ -5,7 +5,7 @@ use Scalar::Util qw(weaken); use Carp qw(croak); -our $VERSION = '2.003001'; +our $VERSION = '2.004000'; $VERSION = eval $VERSION; our @EXPORT = qw(defer_sub undefer_sub undefer_all); @@ -99,6 +99,10 @@ if $target; $package ||= $options && $options->{package} || caller; my @attributes = @{$options && $options->{attributes} || []}; + if (@attributes) { + /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_" + for @attributes; + } my $deferred; my $undeferred; my $deferred_info = [ $target, $maker, \$undeferred ]; @@ -106,7 +110,7 @@ my $code = q[#line ].(__LINE__+2).q[ "].__FILE__.qq["\n] . qq[package $package;\n] - . ($target ? "sub $subname" : '+sub') . join(' ', map ":$_", @attributes) + . ($target ? "sub $subname" : '+sub') . join('', map " :$_", @attributes) . q[ { package Sub::Defer; # uncoverable subroutine @@ -151,7 +155,7 @@ =head1 NAME -Sub::Defer - defer generation of subroutines until they are first called +Sub::Defer - Defer generation of subroutines until they are first called =head1 SYNOPSIS diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/lib/Sub/Quote.pm new/Sub-Quote-2.004000/lib/Sub/Quote.pm --- old/Sub-Quote-2.003001/lib/Sub/Quote.pm 2016-12-09 09:20:18.000000000 +0100 +++ new/Sub-Quote-2.004000/lib/Sub/Quote.pm 2017-06-07 03:08:15.000000000 +0200 @@ -15,7 +15,7 @@ *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0}; } -our $VERSION = '2.003001'; +our $VERSION = '2.004000'; $VERSION = eval $VERSION; our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub); @@ -24,15 +24,16 @@ our %QUOTED; sub quotify { + my $value = $_[0]; no warnings 'numeric'; - ! defined $_[0] ? 'undef()' + ! defined $value ? 'undef()' # numeric detection - : (length( (my $dummy = '') & $_[0] ) - && 0 + $_[0] eq $_[0] - && $_[0] * 0 == 0 - ) ? $_[0] - : _HAVE_PERLSTRING ? B::perlstring($_[0]) - : qq["\Q$_[0]\E"]; + : (length( (my $dummy = '') & $value ) + && 0 + $value eq $value + && $value * 0 == 0 + ) ? $value + : _HAVE_PERLSTRING ? B::perlstring($value) + : qq["\Q$value\E"]; } sub sanitize_identifier { @@ -105,6 +106,10 @@ } my @caller = caller(0); my $attributes = $options->{attributes}; + if ($attributes) { + /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_" + for @$attributes; + } my $quoted_info = { name => $name, code => $code, @@ -125,10 +130,17 @@ return $sub; } else { - my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub { - $unquoted if 0; - unquote_sub($quoted_info->{deferred}); - }, ($attributes ? { attributes => $attributes } : ()); + my $deferred = defer_sub( + ($options->{no_install} ? undef : $name), + sub { + $unquoted if 0; + unquote_sub($quoted_info->{deferred}); + }, + { + ($attributes ? ( attributes => $attributes ) : ()), + ($name ? () : ( package => $quoted_info->{package} )), + }, + ); weaken($quoted_info->{deferred} = $deferred); weaken($QUOTED{$deferred} = $quoted_info); return $deferred; @@ -216,6 +228,9 @@ $e = $@; } unless ($success) { + my $space = length($make_sub =~ tr/\n//); + my $line = 0; + $make_sub =~ s/^/sprintf "%${space}d: ", ++$line/emg; croak "Eval went very, very wrong:\n\n${make_sub}\n\n$e"; } weaken($QUOTED{$$unquoted} = $quoted_info); @@ -243,7 +258,7 @@ =head1 NAME -Sub::Quote - efficient generation of subroutines via string eval +Sub::Quote - Efficient generation of subroutines via string eval =head1 SYNOPSIS @@ -489,6 +504,8 @@ kanashiro - Lucas Kanashiro (cpan:KANASHIRO) <[email protected]> +djerius - Diab Jerius (cpan:DJERIUS) <[email protected]> + =head1 COPYRIGHT Copyright (c) 2010-2016 the Sub::Quote L</AUTHOR> and L</CONTRIBUTORS> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/t/hints.t new/Sub-Quote-2.004000/t/hints.t --- old/Sub-Quote-2.003001/t/hints.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Sub-Quote-2.004000/t/hints.t 2017-05-29 19:13:37.000000000 +0200 @@ -0,0 +1,226 @@ +BEGIN { + %^H = (); + my %clear_hints = sub { %{(caller(0))[10]||{}} }->(); + $INC{'ClearHintsHash.pm'} = __FILE__; + package ClearHintsHash; + sub hints { %clear_hints } + sub import { + $^H |= 0x020000; + %^H = hints; + } +} + +use strict; +use warnings; +no warnings 'once'; +use Test::More; +use Test::Fatal; + +use Sub::Quote qw( + quote_sub + unquote_sub + quoted_from_sub +); + +{ + use strict; + no strict 'subs'; + local $TODO = "hints from caller not available on perl < 5.8" + if "$]" < 5.008_000; + like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} })->(); }, + qr/strict refs/, + 'hints preserved from context'; +} + +{ + my $hints; + { + use strict; + no strict 'subs'; + BEGIN { $hints = $^H } + } + like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} }, {}, { hints => $hints })->(); }, + qr/strict refs/, + 'hints used from options'; +} + +{ + my $sub = do { + no warnings; + unquote_sub quote_sub(q{ 0 + undef }); + }; + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, @_ }; + $sub->(); + is scalar @warnings, 0, + '"no warnings" preserved from context'; +} + +{ + my $sub = do { + no warnings; + use warnings; + unquote_sub quote_sub(q{ 0 + undef }); + }; + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, @_ }; + $sub->(); + like $warnings[0], + qr/uninitialized/, + '"use warnings" preserved from context'; +} + +{ + my $warn_bits; + eval q{ + use warnings FATAL => 'uninitialized'; + BEGIN { $warn_bits = ${^WARNING_BITS} } + 1; + } or die $@; + no warnings 'uninitialized'; + like exception { quote_sub(q{ 0 + undef }, {}, { warning_bits => $warn_bits })->(); }, + qr/uninitialized/, + 'warnings used from options'; +} + +BEGIN { + package UseHintHash; + $INC{'UseHintHash.pm'} = 1; + + sub import { + $^H |= 0x020000; + $^H{__PACKAGE__.'/enabled'} = 1; + } +} + +{ + my %hints; + { + use ClearHintsHash; + use UseHintHash; + BEGIN { %hints = %^H } + } + + { + local $TODO = 'hints hash from context not available on perl 5.8' + if "$]" < 5.010_000; + + use ClearHintsHash; + use UseHintHash; + is_deeply quote_sub(q{ + our %temp_hints_hash; + BEGIN { %temp_hints_hash = %^H } + \%temp_hints_hash; + })->(), \%hints, + 'hints hash preserved from context'; + } + + is_deeply quote_sub(q{ + our %temp_hints_hash; + BEGIN { %temp_hints_hash = %^H } + \%temp_hints_hash; + }, {}, { hintshash => \%hints })->(), \%hints, + 'hints hash used from options'; +} + +{ + use ClearHintsHash; + my $sub = quote_sub(q{ + our %temp_hints_hash; + BEGIN { %temp_hints_hash = %^H } + \%temp_hints_hash; + }); + my $wrap_sub = do { + use UseHintHash; + my (undef, $code, $cap) = @{quoted_from_sub($sub)}; + quote_sub $code, $cap||(); + }; + is_deeply $wrap_sub->(), { ClearHintsHash::hints }, + 'empty hints maintained when inlined'; +} + +BEGIN { + package BetterNumbers; + $INC{'BetterNumbers.pm'} = 1; + use overload (); + + sub import { + my ($class, $add) = @_; + # closure vs not + if (defined $add) { + overload::constant 'integer', sub { $_[0] + $add }; + } + else { + overload::constant 'integer', sub { $_[0] + 1 }; + } + } +} + +TODO: { + my ($options, $context_sub, $direct_val); + { + use BetterNumbers; + BEGIN { $options = { hints => $^H, hintshash => { %^H } } } + $direct_val = 10; + $context_sub = quote_sub(q{ 10 }); + } + my $options_sub = quote_sub(q{ 10 }, {}, $options); + + is $direct_val, 11, + 'integer overload is working'; + + todo_skip "refs in hints hash not yet implemented", 4; + { + my $context_val; + is exception { $context_val = $context_sub->() }, undef, + 'hints hash refs from context not broken'; + local $TODO = 'hints hash from context not available on perl 5.8' + if !$TODO && "$]" < 5.010_000; + is $context_val, 11, + 'hints hash refs preserved from context'; + } + + { + my $options_val; + is exception { $options_val = $options_sub->() }, undef, + 'hints hash refs from options not broken'; + is $options_val, 11, + 'hints hash refs used from options'; + } +} + +TODO: { + my ($options, $context_sub, $direct_val); + { + use BetterNumbers +2; + BEGIN { $options = { hints => $^H, hintshash => { %^H } } } + $direct_val = 10; + $context_sub = quote_sub(q{ 10 }); + } + my $options_sub = quote_sub(q{ 10 }, {}, $options); + + is $direct_val, 12, + 'closure integer overload is working'; + + todo_skip "refs in hints hash not yet implemented", 4; + + { + my $context_val; + is exception { $context_val = $context_sub->() }, undef, + 'hints hash closure refs from context not broken'; + local $TODO = 'hints hash from context not available on perl 5.8' + if !$TODO && "$]" < 5.010_000; + is $context_val, 12, + 'hints hash closure refs preserved from context'; + } + + { + my $options_val; + is exception { $options_val = $options_sub->() }, undef, + 'hints hash closure refs from options not broken'; + is $options_val, 12, + 'hints hash closure refs used from options'; + } +} + +done_testing; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/t/inline.t new/Sub-Quote-2.004000/t/inline.t --- old/Sub-Quote-2.003001/t/inline.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Sub-Quote-2.004000/t/inline.t 2017-05-30 22:51:32.000000000 +0200 @@ -0,0 +1,82 @@ +use strict; +use warnings; +no warnings 'once'; +use Test::More; +use Test::Fatal; +use Data::Dumper; + +use Sub::Quote qw( + capture_unroll + inlinify +); + +my $captures = { + '$x' => \1, + '$y' => \2, +}; +my $prelude = capture_unroll '$captures', $captures, 4; +my $out = eval + $prelude + . '[ $x, $y ]'; +is "$@", '', 'capture_unroll produces valid code'; +is_deeply $out, [ 1, 2 ], 'unrolled variables get correct values'; + +like exception { + capture_unroll '$captures', { '&foo' => \sub { 5 } }, 4; +}, qr/^capture key should start with @, % or \$/, + 'capture_unroll rejects vars other than scalar, hash, or array'; + +{ + my $inlined_code = inlinify q{ + my ($x, $y) = @_; + + [ $x, $y ]; + }, '$x, $y', $prelude; + my $out = eval $inlined_code; + is "$@", '', 'inlinify produces valid code' + or diag "code:\n$inlined_code"; + is_deeply $out, [ 1, 2 ], 'inlinified code get correct values'; + unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/, + "matching variables aren't reassigned"; +} + +{ + $Bar::baz = 3; + my $inlined_code = inlinify q{ + package Bar; + my ($x, $y) = @_; + + [ $x, $y, our $baz ]; + }, '$x, $y', $prelude; + my $out = eval $inlined_code; + is "$@", '', 'inlinify produces valid code' + or diag "code:\n$inlined_code"; + is_deeply $out, [ 1, 2, 3 ], 'inlinified code get correct values'; + unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/, + "matching variables aren't reassigned"; +} + +{ + my $inlined_code = inlinify q{ + my ($d, $f) = @_; + + [ $d, $f ]; + }, '$x, $y', $prelude; + my $out = eval $inlined_code; + is "$@", '', 'inlinify with unmatched params produces valid code' + or diag "code:\n$inlined_code"; + is_deeply $out, [ 1, 2 ], 'inlinified code get correct values'; +} + +{ + my $inlined_code = inlinify q{ + my $z = $_[0]; + $z; + }, '$y', $prelude; + my $out = eval $inlined_code; + is "$@", '', 'inlinify with out @_ produces valid code' + or diag "code:\n$inlined_code"; + is $out, 2, 'inlinified code get correct values'; +} + +done_testing; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/t/leaks.t new/Sub-Quote-2.004000/t/leaks.t --- old/Sub-Quote-2.003001/t/leaks.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Sub-Quote-2.004000/t/leaks.t 2017-05-30 22:51:32.000000000 +0200 @@ -0,0 +1,77 @@ +use strict; +use warnings; +no warnings 'once'; +use Test::More; +use Test::Fatal; +use Data::Dumper; + +use Sub::Quote qw( + quote_sub + unquote_sub + quoted_from_sub +); + +{ + my $foo = quote_sub '{}'; + my $foo_string = "$foo"; + undef $foo; + + is quoted_from_sub($foo_string), undef, + "quoted subs don't leak"; + + Sub::Quote->CLONE; + ok !exists $Sub::Quote::QUOTED{$foo_string}, + 'CLONE cleans out expired entries'; +} + +{ + my $foo = quote_sub '{}'; + my $foo_string = "$foo"; + Sub::Quote->CLONE; + undef $foo; + + is quoted_from_sub($foo_string), undef, + "CLONE doesn't strengthen refs"; +} + +{ + my $foo = quote_sub '{}'; + my $foo_string = "$foo"; + my $foo_info = quoted_from_sub($foo_string); + undef $foo; + + is exception { Sub::Quote->CLONE }, undef, + 'CLONE works when quoted info saved externally'; + ok exists $Sub::Quote::QUOTED{$foo_string}, + 'CLONE keeps entries that had info saved'; +} + +{ + my $foo = quote_sub '{}'; + my $foo_string = "$foo"; + my $foo_info = $Sub::Quote::QUOTED{$foo_string}; + undef $foo; + + is exception { Sub::Quote->CLONE }, undef, + 'CLONE works when quoted info kept alive externally'; + ok !exists $Sub::Quote::QUOTED{$foo_string}, + 'CLONE removes expired entries that were kept alive externally'; +} + +{ + my $foo = quote_sub '{}'; + my $foo_string = "$foo"; + my $sub = unquote_sub $foo; + my $sub_string = "$sub"; + + Sub::Quote->CLONE; + + ok quoted_from_sub($sub_string), + 'CLONE maintains entries referenced by unquoted sub'; + + undef $sub; + ok quoted_from_sub($foo_string)->[3], + 'unquoted sub still available if quoted sub exists'; +} + +done_testing; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/t/quotify.t new/Sub-Quote-2.004000/t/quotify.t --- old/Sub-Quote-2.003001/t/quotify.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Sub-Quote-2.004000/t/quotify.t 2017-05-30 22:52:35.000000000 +0200 @@ -0,0 +1,149 @@ +use strict; +use warnings; +no warnings 'once'; +use Test::More; +use Test::Fatal; +use Data::Dumper; +use B; + +use constant HAVE_UTF8 => defined &utf8::upgrade && defined &utf8::is_utf8;; + +use Sub::Quote qw( + quotify +); + +sub _dump { + my $value = shift; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Useqq = 1; + my $d = Data::Dumper::Dumper($value); + $d =~ s/\s+$//; + $d; +} + +sub is_numeric { + my $val = shift; + my $sv = B::svref_2object(\$val); + !!($sv->FLAGS & ( B::SVp_IOK | B::SVp_NOK ) ) +} + +my %flags; +{ + no strict 'refs'; + for my $flag (qw( + SVs_TEMP + SVs_OBJECT + SVs_GMG + SVs_SMG + SVs_RMG + SVf_IOK + SVf_NOK + SVf_POK + SVf_OOK + SVf_FAKE + SVf_READONLY + SVf_PROTECT + SVf_BREAK + SVp_IOK + SVp_NOK + SVp_POK + )) { + if (defined &{'B::'.$flag}) { + $flags{$flag} = &{'B::'.$flag}; + } + } +} +sub flags { + my $val = shift; + my $flags = B::svref_2object(\$val)->FLAGS; + join ' ', sort grep $flags & $flags{$_}, keys %flags; +} + +BEGIN { + if (HAVE_UTF8) { + eval ' + sub eval_utf8 { + my $value = shift; + my $output; + eval "use utf8; \$output = $value; 1;" or die $@; + $output; + } + 1; + ' or die $@; + } +} + +my @numbers = ( + -20 .. 20, + (map 1 / $_, -10 .. -2, 2 .. 10), +); + +my @strings = ( + "\x00", + "a", + "\xC3\x84", + "\xE8", + "\xFC", + "\xFF", + "\x{1F4A9}", +); + +if (HAVE_UTF8) { + utf8::downgrade($_, 1) + for @strings; +} + +my @utf8_strings; +if (HAVE_UTF8) { + @utf8_strings = @strings; + utf8::upgrade($_) + for @utf8_strings; +} + +my @quotify = ( + undef, + (map { + my $used_as_string = $_; + my $string = "$used_as_string"; + ($_, $used_as_string, $string); + } @numbers), + @strings, + @utf8_strings, +); + +my $eval_utf8; + +for my $value (@quotify) { + my $value_name + = _dump($value) + . (HAVE_UTF8 && utf8::is_utf8($value) ? ' utf8' : '') + . (is_numeric($value) ? ' num' : ''); + + my $quoted = quotify(my $copy = $value); + utf8::downgrade($quoted, 1) + if HAVE_UTF8; + + is flags($copy), flags($value), + "$value_name: quotify doesn't modify input"; + + my $evaled; + eval "\$evaled = $quoted; 1" or die $@; + + is is_numeric($evaled), is_numeric($value), + "$value_name: numeric status maintained"; + + is $value, $evaled, + "$value_name: value maintained"; + + if (HAVE_UTF8) { + my $utf8_evaled = eval_utf8($quoted); + + is is_numeric($value), is_numeric($utf8_evaled), + "$value_name: numeric status maintained under utf8"; + + is $value, $utf8_evaled, + "$value_name: value maintained under utf8"; + } +} + +done_testing; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Sub-Quote-2.003001/t/sub-quote.t new/Sub-Quote-2.004000/t/sub-quote.t --- old/Sub-Quote-2.003001/t/sub-quote.t 2016-12-08 01:56:23.000000000 +0100 +++ new/Sub-Quote-2.004000/t/sub-quote.t 2017-06-07 03:05:39.000000000 +0200 @@ -1,15 +1,3 @@ -BEGIN { - %^H = (); - my %clear_hints = sub { %{(caller(0))[10]||{}} }->(); - $INC{'ClearHintsHash.pm'} = __FILE__; - package ClearHintsHash; - sub hints { %clear_hints } - sub import { - $^H |= 0x020000; - %^H = hints; - } -} - use strict; use warnings; no warnings 'once'; @@ -24,8 +12,11 @@ capture_unroll inlinify sanitize_identifier + quotify ); +use B; + our %EVALED; my $one = quote_sub q{ @@ -130,13 +121,21 @@ my $broken_quoted = quote_sub q{ return 5<; + Guh }; +my $err = exception { $broken_quoted->() }; like( - exception { $broken_quoted->() }, qr/Eval went very, very wrong/, + $err, qr/Eval went very, very wrong/, "quoted sub with syntax error dies when called" ); +my ($location) = $err =~ /syntax error at .+? line (\d+)/; +like( + $err, qr/$location:\s*return 5<;/, + "syntax errors include usable line numbers" +); + sub in_main { 1 } is exception { quote_sub(q{ in_main(); })->(); }, undef, 'package preserved from context'; @@ -149,269 +148,6 @@ is exception { quote_sub(q{ in_arf(); }, {}, { package => 'Arf' })->(); }, undef, 'package used from options'; -{ - use strict; - no strict 'subs'; - local $TODO = "hints from caller not available on perl < 5.8" - if "$]" < 5.008_000; - like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} })->(); }, - qr/strict refs/, - 'hints preserved from context'; -} - -{ - my $hints; - { - use strict; - no strict 'subs'; - BEGIN { $hints = $^H } - } - like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} }, {}, { hints => $hints })->(); }, - qr/strict refs/, - 'hints used from options'; -} - -{ - my $sub = do { - no warnings; - unquote_sub quote_sub(q{ 0 + undef }); - }; - my @warnings; - local $SIG{__WARN__} = sub { push @warnings, @_ }; - $sub->(); - is scalar @warnings, 0, - '"no warnings" preserved from context'; -} - -{ - my $sub = do { - no warnings; - use warnings; - unquote_sub quote_sub(q{ 0 + undef }); - }; - my @warnings; - local $SIG{__WARN__} = sub { push @warnings, @_ }; - $sub->(); - like $warnings[0], - qr/uninitialized/, - '"use warnings" preserved from context'; -} - -{ - my $warn_bits; - eval q{ - use warnings FATAL => 'uninitialized'; - BEGIN { $warn_bits = ${^WARNING_BITS} } - 1; - } or die $@; - no warnings 'uninitialized'; - like exception { quote_sub(q{ 0 + undef }, {}, { warning_bits => $warn_bits })->(); }, - qr/uninitialized/, - 'warnings used from options'; -} - -BEGIN { - package UseHintHash; - $INC{'UseHintHash.pm'} = 1; - - sub import { - $^H |= 0x020000; - $^H{__PACKAGE__.'/enabled'} = 1; - } -} - -{ - my %hints; - { - use ClearHintsHash; - use UseHintHash; - BEGIN { %hints = %^H } - } - - { - local $TODO = 'hints hash from context not available on perl 5.8' - if "$]" < 5.010_000; - - use ClearHintsHash; - use UseHintHash; - is_deeply quote_sub(q{ - our %temp_hints_hash; - BEGIN { %temp_hints_hash = %^H } - \%temp_hints_hash; - })->(), \%hints, - 'hints hash preserved from context'; - } - - is_deeply quote_sub(q{ - our %temp_hints_hash; - BEGIN { %temp_hints_hash = %^H } - \%temp_hints_hash; - }, {}, { hintshash => \%hints })->(), \%hints, - 'hints hash used from options'; -} - -{ - use ClearHintsHash; - my $sub = quote_sub(q{ - our %temp_hints_hash; - BEGIN { %temp_hints_hash = %^H } - \%temp_hints_hash; - }); - my $wrap_sub = do { - use UseHintHash; - my (undef, $code, $cap) = @{quoted_from_sub($sub)}; - quote_sub $code, $cap||(); - }; - is_deeply $wrap_sub->(), { ClearHintsHash::hints }, - 'empty hints maintained when inlined'; -} - -BEGIN { - package BetterNumbers; - $INC{'BetterNumbers.pm'} = 1; - use overload (); - - sub import { - my ($class, $add) = @_; - # closure vs not - if (defined $add) { - overload::constant 'integer', sub { $_[0] + $add }; - } - else { - overload::constant 'integer', sub { $_[0] + 1 }; - } - } -} - -TODO: { - my ($options, $context_sub, $direct_val); - { - use BetterNumbers; - BEGIN { $options = { hints => $^H, hintshash => { %^H } } } - $direct_val = 10; - $context_sub = quote_sub(q{ 10 }); - } - my $options_sub = quote_sub(q{ 10 }, {}, $options); - - is $direct_val, 11, - 'integer overload is working'; - - todo_skip "refs in hints hash not yet implemented", 4; - { - my $context_val; - is exception { $context_val = $context_sub->() }, undef, - 'hints hash refs from context not broken'; - local $TODO = 'hints hash from context not available on perl 5.8' - if !$TODO && "$]" < 5.010_000; - is $context_val, 11, - 'hints hash refs preserved from context'; - } - - { - my $options_val; - is exception { $options_val = $options_sub->() }, undef, - 'hints hash refs from options not broken'; - is $options_val, 11, - 'hints hash refs used from options'; - } -} - -TODO: { - my ($options, $context_sub, $direct_val); - { - use BetterNumbers +2; - BEGIN { $options = { hints => $^H, hintshash => { %^H } } } - $direct_val = 10; - $context_sub = quote_sub(q{ 10 }); - } - my $options_sub = quote_sub(q{ 10 }, {}, $options); - - is $direct_val, 12, - 'closure integer overload is working'; - - todo_skip "refs in hints hash not yet implemented", 4; - - { - my $context_val; - is exception { $context_val = $context_sub->() }, undef, - 'hints hash closure refs from context not broken'; - local $TODO = 'hints hash from context not available on perl 5.8' - if !$TODO && "$]" < 5.010_000; - is $context_val, 12, - 'hints hash closure refs preserved from context'; - } - - { - my $options_val; - is exception { $options_val = $options_sub->() }, undef, - 'hints hash closure refs from options not broken'; - is $options_val, 12, - 'hints hash closure refs used from options'; - } -} - -{ - my $foo = quote_sub '{}'; - my $foo_string = "$foo"; - undef $foo; - - is quoted_from_sub($foo_string), undef, - "quoted subs don't leak"; - - Sub::Quote->CLONE; - ok !exists $Sub::Quote::QUOTED{$foo_string}, - 'CLONE cleans out expired entries'; -} - -{ - my $foo = quote_sub '{}'; - my $foo_string = "$foo"; - Sub::Quote->CLONE; - undef $foo; - - is quoted_from_sub($foo_string), undef, - "CLONE doesn't strengthen refs"; -} - -{ - my $foo = quote_sub '{}'; - my $foo_string = "$foo"; - my $foo_info = quoted_from_sub($foo_string); - undef $foo; - - is exception { Sub::Quote->CLONE }, undef, - 'CLONE works when quoted info saved externally'; - ok exists $Sub::Quote::QUOTED{$foo_string}, - 'CLONE keeps entries that had info saved'; -} - -{ - my $foo = quote_sub '{}'; - my $foo_string = "$foo"; - my $foo_info = $Sub::Quote::QUOTED{$foo_string}; - undef $foo; - - is exception { Sub::Quote->CLONE }, undef, - 'CLONE works when quoted info kept alive externally'; - ok !exists $Sub::Quote::QUOTED{$foo_string}, - 'CLONE removes expired entries that were kept alive externally'; -} - -{ - my $foo = quote_sub '{}'; - my $foo_string = "$foo"; - my $sub = unquote_sub $foo; - my $sub_string = "$sub"; - - Sub::Quote->CLONE; - - ok quoted_from_sub($sub_string), - 'CLONE maintains entries referenced by unquoted sub'; - - undef $sub; - ok quoted_from_sub($foo_string)->[3], - 'unquoted sub still available if quoted sub exists'; -} { my $foo = quote_sub '{}'; @@ -427,109 +163,9 @@ 'unquoted sub still included in quote info'; } -use Data::Dumper; -my $dump = sub { - local $Data::Dumper::Terse = 1; - my $d = Data::Dumper::Dumper($_[0]); - $d =~ s/\s+$//; - $d; -}; - -my @strings = (0, 1, "\x00", "a", "\xFC", "\x{1F4A9}"); -my $eval = sub { eval Sub::Quote::quotify($_[0])}; - -my @failed = grep { my $o = $eval->($_); !defined $o || $o ne $_ } @strings; - -ok !@failed, "evaling quotify returns same value for all strings" - or diag "Failed strings: " . join(' ', map { $dump->($_) } @failed); - -SKIP: { - skip "working utf8 pragma not available", 1 - if "$]" < 5.008_000; - my $eval_utf8 = eval 'sub { use utf8; eval Sub::Quote::quotify($_[0]) }'; - - my @failed_utf8 = grep { my $o = $eval_utf8->($_); !defined $o || $o ne $_ } - @strings; - ok !@failed_utf8, "evaling quotify under utf8 returns same value for all strings" - or diag "Failed strings: " . join(' ', map { $dump->($_) } @failed_utf8); -} - -unlike Sub::Quote::quotify($_), qr/[^0-9.-]/, - "quotify preserves $_ as number" - for 0, 1, 1.5, 0.5, -10; - my @stuff = (qsub q{ print "hello"; }, 1, 2); is scalar @stuff, 3, 'qsub only accepts a single parameter'; -my $captures = { - '$x' => \1, - '$y' => \2, -}; -my $prelude = capture_unroll '$captures', $captures, 4; -my $out = eval - $prelude - . '[ $x, $y ]'; -is "$@", '', 'capture_unroll produces valid code'; -is_deeply $out, [ 1, 2 ], 'unrolled variables get correct values'; - -like exception { - capture_unroll '$captures', { '&foo' => \sub { 5 } }, 4; -}, qr/^capture key should start with @, % or \$/, - 'capture_unroll rejects vars other than scalar, hash, or array'; - -{ - my $inlined_code = inlinify q{ - my ($x, $y) = @_; - - [ $x, $y ]; - }, '$x, $y', $prelude; - my $out = eval $inlined_code; - is "$@", '', 'inlinify produces valid code' - or diag "code:\n$inlined_code"; - is_deeply $out, [ 1, 2 ], 'inlinified code get correct values'; - unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/, - "matching variables aren't reassigned"; -} - -{ - $Bar::baz = 3; - my $inlined_code = inlinify q{ - package Bar; - my ($x, $y) = @_; - - [ $x, $y, our $baz ]; - }, '$x, $y', $prelude; - my $out = eval $inlined_code; - is "$@", '', 'inlinify produces valid code' - or diag "code:\n$inlined_code"; - is_deeply $out, [ 1, 2, 3 ], 'inlinified code get correct values'; - unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/, - "matching variables aren't reassigned"; -} - -{ - my $inlined_code = inlinify q{ - my ($d, $f) = @_; - - [ $d, $f ]; - }, '$x, $y', $prelude; - my $out = eval $inlined_code; - is "$@", '', 'inlinify with unmatched params produces valid code' - or diag "code:\n$inlined_code"; - is_deeply $out, [ 1, 2 ], 'inlinified code get correct values'; -} - -{ - my $inlined_code = inlinify q{ - my $z = $_[0]; - $z; - }, '$y', $prelude; - my $out = eval $inlined_code; - is "$@", '', 'inlinify with out @_ produces valid code' - or diag "code:\n$inlined_code"; - is $out, 2, 'inlinified code get correct values'; -} - { my @warnings; local $ENV{SUB_QUOTE_DEBUG} = 1; ++++++ cpanspec.yml ++++++ --- #description_paragraphs: 3 #description: |- # override description from CPAN #summary: override summary from CPAN #no_testing: broken upstream #sources: # - source1 # - source2 #patches: # foo.patch: -p1 # bar.patch: #preamble: |- # BuildRequires: gcc-c++ #post_prep: |- # hunspell=`pkg-config --libs hunspell | sed -e 's,-l,,; s, *,,g'` # sed -i -e "s,hunspell-X,$hunspell," t/00-prereq.t Makefile.PL #post_build: |- # rm unused.files #post_install: |- # sed on %{name}.files #license: SUSE-NonFree #skip_noarch: 1 #custom_build: |- #./Build build flags=%{?_smp_mflags} --myflag #custom_test: |- #startserver && make test #ignore_requires: Bizarre::Module
