Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

* Write Mojolicious applications with Dancer syntax via "selfvars::au…

…toload"! \o/

* selfvars 0.31.
  • Loading branch information...
commit c3898eaff434aa511ad18b88f3cf7b9fa7a39977 1 parent d1d4a06
@audreyt authored
View
7 Changes
@@ -1,4 +1,9 @@
-[Changes for 0.21 - 2010-12-14]
+[Changes for 0.31 - 2011-05-27]
+
+* Introduce "selfvars::autoload", a helper module that makes it
+ possible to write Mojolicious applications with Dancer syntax.
+
+[Changes for 0.22 - 2010-12-14]
* Add =encoding utf8 to POD; no functional changes.
View
3  MANIFEST
@@ -14,6 +14,7 @@ inc/Test/Builder.pm
inc/Test/Builder/Module.pm
inc/Test/More.pm
lib/selfvars.pm
+lib/selfvars/autoload.pm
Makefile.PL
MANIFEST This list of files
META.yml
@@ -22,9 +23,11 @@ SIGNATURE Public-key signature (added by MakeMaker)
t/00.load.t
t/02.eval.t
t/03.interpolation.t
+t/0hopts.t
t/0simple.t
t/lib/Counter.pm
t/lib/EvalTest.pm
+t/lib/HOpts.pm
t/lib/InterpolationTest.pm
t/pod-coverage.t
t/pod.t
View
4 inc/Module/Install.pm
@@ -31,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '1.00';
+ $VERSION = '1.01';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -467,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2010 Adam Kennedy.
+# Copyright 2008 - 2011 Adam Kennedy.
View
2  inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
}
# Suspend handler for "redefined" warnings
View
2  inc/Module/Install/Can.pm
@@ -9,7 +9,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
View
2  inc/Module/Install/Fetch.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
View
2  inc/Module/Install/Include.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
View
2  inc/Module/Install/Makefile.pm
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
View
9 inc/Module/Install/Metadata.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -515,6 +515,7 @@ sub __extract_license {
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
@@ -550,9 +551,9 @@ sub license_from {
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
- \Qhttp://rt.cpan.org/\E[^>]+|
- \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
- \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ https?\Q://rt.cpan.org/\E[^>]+|
+ https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
+ https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
View
2  inc/Module/Install/Win32.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
View
2  inc/Module/Install/WriteAll.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
View
4 inc/PerlIO.pm
@@ -1,7 +1,7 @@
#line 1
package PerlIO;
-our $VERSION = '1.06';
+our $VERSION = '1.07';
# Map layer name to package that defines it
our %alias;
@@ -30,4 +30,4 @@ sub F_UTF8 () { 0x8000 }
1;
__END__
-#line 344
+#line 332
View
192 inc/Test/Builder.pm
@@ -5,7 +5,7 @@ use 5.006;
use strict;
use warnings;
-our $VERSION = '0.94';
+our $VERSION = '0.98';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
@@ -24,7 +24,7 @@ BEGIN {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
- # occassionally forget the contents of the variable when sharing it.
+ # occasionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
@@ -99,25 +99,35 @@ sub child {
$self->croak("You already have a child named ($self->{Child_Name}) running");
}
+ my $parent_in_todo = $self->in_todo;
+
+ # Clear $TODO for the child.
+ my $orig_TODO = $self->find_TODO(undef, 1, undef);
+
my $child = bless {}, ref $self;
$child->reset;
# Add to our indentation
$child->_indent( $self->_indent . ' ' );
+
$child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
+ if ($parent_in_todo) {
+ $child->{Fail_FH} = $self->{Todo_FH};
+ }
# This will be reset in finalize. We do this here lest one child failure
# cause all children to fail.
$child->{Child_Error} = $?;
$? = 0;
$child->{Parent} = $self;
+ $child->{Parent_TODO} = $orig_TODO;
$child->{Name} = $name || "Child of " . $self->name;
$self->{Child_Name} = $child->name;
return $child;
}
-#line 201
+#line 211
sub subtest {
my $self = shift;
@@ -129,27 +139,50 @@ sub subtest {
# Turn the child into the parent so anyone who has stored a copy of
# the Test::Builder singleton will get the child.
- my $child = $self->child($name);
- my %parent = %$self;
- %$self = %$child;
+ my($error, $child, %parent);
+ {
+ # child() calls reset() which sets $Level to 1, so we localize
+ # $Level first to limit the scope of the reset to the subtest.
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ $child = $self->child($name);
+ %parent = %$self;
+ %$self = %$child;
+
+ my $run_the_subtests = sub {
+ $subtests->();
+ $self->done_testing unless $self->_plan_handled;
+ 1;
+ };
- my $error;
- if( !eval { $subtests->(); 1 } ) {
- $error = $@;
+ if( !eval { $run_the_subtests->() } ) {
+ $error = $@;
+ }
}
# Restore the parent and the copied child.
%$child = %$self;
%$self = %parent;
+ # Restore the parent's $TODO
+ $self->find_TODO(undef, 1, $child->{Parent_TODO});
+
# Die *after* we restore the parent.
die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
return $child->finalize;
}
+#line 281
-#line 250
+sub _plan_handled {
+ my $self = shift;
+ return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
+}
+
+
+#line 306
sub finalize {
my $self = shift;
@@ -158,11 +191,14 @@ sub finalize {
if( $self->{Child_Name} ) {
$self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
}
+
+ local $? = 0; # don't fail if $subtests happened to set $? nonzero
$self->_ending;
# XXX This will only be necessary for TAP envelopes (we think)
#$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $ok = 1;
$self->parent->{Child_Name} = undef;
if ( $self->{Skip_All} ) {
@@ -190,17 +226,17 @@ sub _indent {
return $self->{Indent};
}
-#line 300
+#line 359
sub parent { shift->{Parent} }
-#line 312
+#line 371
sub name { shift->{Name} }
sub DESTROY {
my $self = shift;
- if ( $self->parent ) {
+ if ( $self->parent and $$ == $self->{Original_Pid} ) {
my $name = $self->name;
$self->diag(<<"FAIL");
Child ($name) exited without calling finalize()
@@ -210,7 +246,7 @@ FAIL
}
}
-#line 336
+#line 395
our $Level;
@@ -227,6 +263,7 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Have_Output_Plan} = 0;
+ $self->{Done_Testing} = 0;
$self->{Original_Pid} = $$;
$self->{Child_Name} = undef;
@@ -256,7 +293,7 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
return;
}
-#line 414
+#line 474
my %plan_cmds = (
no_plan => \&no_plan,
@@ -303,8 +340,7 @@ sub _plan_tests {
return;
}
-
-#line 470
+#line 529
sub expected_tests {
my $self = shift;
@@ -322,7 +358,7 @@ sub expected_tests {
return $self->{Expected_Tests};
}
-#line 494
+#line 553
sub no_plan {
my($self, $arg) = @_;
@@ -335,8 +371,7 @@ sub no_plan {
return 1;
}
-
-#line 528
+#line 586
sub _output_plan {
my($self, $max, $directive, $reason) = @_;
@@ -354,7 +389,8 @@ sub _output_plan {
return;
}
-#line 579
+
+#line 638
sub done_testing {
my($self, $num_tests) = @_;
@@ -397,7 +433,7 @@ sub done_testing {
}
-#line 630
+#line 689
sub has_plan {
my $self = shift;
@@ -407,7 +443,7 @@ sub has_plan {
return(undef);
}
-#line 647
+#line 706
sub skip_all {
my( $self, $reason ) = @_;
@@ -421,7 +457,7 @@ sub skip_all {
exit(0);
}
-#line 672
+#line 731
sub exported_to {
my( $self, $pack ) = @_;
@@ -432,7 +468,7 @@ sub exported_to {
return $self->{Exported_To};
}
-#line 702
+#line 761
sub ok {
my( $self, $test, $name ) = @_;
@@ -592,14 +628,12 @@ sub _is_dualvar {
return $numval != 0 and $numval ne $val ? 1 : 0;
}
-#line 876
+#line 939
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_str( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -616,8 +650,6 @@ sub is_num {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_num( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -675,7 +707,7 @@ sub _isnt_diag {
DIAGNOSTIC
}
-#line 973
+#line 1032
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
@@ -709,7 +741,7 @@ sub isnt_num {
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
-#line 1022
+#line 1081
sub like {
my( $self, $this, $regex, $name ) = @_;
@@ -725,7 +757,7 @@ sub unlike {
return $self->_regex_ok( $this, $regex, '!~', $name );
}
-#line 1046
+#line 1105
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
@@ -741,8 +773,9 @@ sub cmp_ok {
my($pack, $file, $line) = $self->caller();
+ # This is so that warnings come out at the caller's level
$test = eval qq[
-#line 1 "cmp_ok [from $file line $line]"
+#line $line "(eval in cmp_ok) $file"
\$got $type \$expect;
];
$error = $@;
@@ -805,7 +838,7 @@ sub _caller_context {
return $code;
}
-#line 1145
+#line 1205
sub BAIL_OUT {
my( $self, $reason ) = @_;
@@ -815,14 +848,14 @@ sub BAIL_OUT {
exit 255;
}
-#line 1158
+#line 1218
{
no warnings 'once';
*BAILOUT = \&BAIL_OUT;
}
-#line 1172
+#line 1232
sub skip {
my( $self, $why ) = @_;
@@ -853,7 +886,7 @@ sub skip {
return 1;
}
-#line 1213
+#line 1273
sub todo_skip {
my( $self, $why ) = @_;
@@ -881,7 +914,7 @@ sub todo_skip {
return 1;
}
-#line 1293
+#line 1353
sub maybe_regex {
my( $self, $regex ) = @_;
@@ -961,7 +994,7 @@ DIAGNOSTIC
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1389
+#line 1449
sub _try {
my( $self, $code, %opts ) = @_;
@@ -981,7 +1014,7 @@ sub _try {
return wantarray ? ( $return, $error ) : $return;
}
-#line 1418
+#line 1478
sub is_fh {
my $self = shift;
@@ -995,7 +1028,7 @@ sub is_fh {
eval { tied($maybe_fh)->can('TIEHANDLE') };
}
-#line 1461
+#line 1521
sub level {
my( $self, $level ) = @_;
@@ -1006,7 +1039,7 @@ sub level {
return $Level;
}
-#line 1493
+#line 1553
sub use_numbers {
my( $self, $use_nums ) = @_;
@@ -1017,7 +1050,7 @@ sub use_numbers {
return $self->{Use_Nums};
}
-#line 1526
+#line 1586
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -1035,7 +1068,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
*{ __PACKAGE__ . '::' . $method } = $code;
}
-#line 1579
+#line 1639
sub diag {
my $self = shift;
@@ -1043,7 +1076,7 @@ sub diag {
$self->_print_comment( $self->_diag_fh, @_ );
}
-#line 1594
+#line 1654
sub note {
my $self = shift;
@@ -1080,7 +1113,7 @@ sub _print_comment {
return 0;
}
-#line 1644
+#line 1704
sub explain {
my $self = shift;
@@ -1099,7 +1132,7 @@ sub explain {
} @_;
}
-#line 1673
+#line 1733
sub _print {
my $self = shift;
@@ -1114,20 +1147,21 @@ sub _print_to_fh {
return if $^C;
my $msg = join '', @msgs;
+ my $indent = $self->_indent;
local( $\, $", $, ) = ( undef, ' ', '' );
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n# }sg;
+ $msg =~ s{\n(?!\z)}{\n$indent# }sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\z/;
- return print $fh $self->_indent, $msg;
+ return print $fh $indent, $msg;
}
-#line 1732
+#line 1793
sub output {
my( $self, $fh ) = @_;
@@ -1223,8 +1257,8 @@ sub _open_testhandles {
open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
- # $self->_copy_io_layers( \*STDOUT, $Testout );
- # $self->_copy_io_layers( \*STDERR, $Testerr );
+ $self->_copy_io_layers( \*STDOUT, $Testout );
+ $self->_copy_io_layers( \*STDERR, $Testerr );
$self->{Opened_Testhandles} = 1;
@@ -1239,14 +1273,22 @@ sub _copy_io_layers {
require PerlIO;
my @src_layers = PerlIO::get_layers($src);
- binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+ _apply_layers($dst, @src_layers) if @src_layers;
}
);
return;
}
-#line 1857
+sub _apply_layers {
+ my ($fh, @layers) = @_;
+ my %seen;
+ my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
+ binmode($fh, join(":", "", "raw", @unique));
+}
+
+
+#line 1926
sub reset_outputs {
my $self = shift;
@@ -1258,7 +1300,7 @@ sub reset_outputs {
return;
}
-#line 1883
+#line 1952
sub _message_at_caller {
my $self = shift;
@@ -1279,7 +1321,7 @@ sub croak {
}
-#line 1923
+#line 1992
sub current_test {
my( $self, $num ) = @_;
@@ -1312,7 +1354,7 @@ sub current_test {
return $self->{Curr_Test};
}
-#line 1971
+#line 2040
sub is_passing {
my $self = shift;
@@ -1325,7 +1367,7 @@ sub is_passing {
}
-#line 1993
+#line 2062
sub summary {
my($self) = shift;
@@ -1333,14 +1375,14 @@ sub summary {
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 2048
+#line 2117
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 2077
+#line 2146
sub todo {
my( $self, $pack ) = @_;
@@ -1354,19 +1396,21 @@ sub todo {
return '';
}
-#line 2099
+#line 2173
sub find_TODO {
- my( $self, $pack ) = @_;
+ my( $self, $pack, $set, $new_value ) = @_;
$pack = $pack || $self->caller(1) || $self->exported_to;
return unless $pack;
no strict 'refs'; ## no critic
- return ${ $pack . '::TODO' };
+ my $old_value = ${ $pack . '::TODO' };
+ $set and ${ $pack . '::TODO' } = $new_value;
+ return $old_value;
}
-#line 2117
+#line 2193
sub in_todo {
my $self = shift;
@@ -1375,7 +1419,7 @@ sub in_todo {
return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
}
-#line 2167
+#line 2243
sub todo_start {
my $self = shift;
@@ -1390,7 +1434,7 @@ sub todo_start {
return;
}
-#line 2189
+#line 2265
sub todo_end {
my $self = shift;
@@ -1411,7 +1455,7 @@ sub todo_end {
return;
}
-#line 2222
+#line 2298
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my( $self, $height ) = @_;
@@ -1426,9 +1470,9 @@ sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
return wantarray ? @caller : $caller[0];
}
-#line 2239
+#line 2315
-#line 2253
+#line 2329
#'#
sub _sanity_check {
@@ -1441,7 +1485,7 @@ sub _sanity_check {
return;
}
-#line 2274
+#line 2350
sub _whoa {
my( $self, $check, $desc ) = @_;
@@ -1456,7 +1500,7 @@ WHOA
return;
}
-#line 2298
+#line 2374
sub _my_exit {
$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
@@ -1464,7 +1508,7 @@ sub _my_exit {
return 1;
}
-#line 2310
+#line 2386
sub _ending {
my $self = shift;
@@ -1583,7 +1627,7 @@ END {
$Test->_ending if defined $Test;
}
-#line 2498
+#line 2574
1;
View
2  inc/Test/Builder/Module.pm
@@ -8,7 +8,7 @@ use Test::Builder;
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '0.94';
+our $VERSION = '0.98';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
View
74 inc/Test/More.pm
@@ -18,7 +18,7 @@ sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.94';
+our $VERSION = '0.98';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module;
@@ -88,7 +88,7 @@ sub ok ($;$) {
return $tb->ok( $test, $name );
}
-#line 367
+#line 372
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -104,7 +104,7 @@ sub isnt ($$;$) {
*isn't = \&isnt;
-#line 411
+#line 416
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -112,7 +112,7 @@ sub like ($$;$) {
return $tb->like(@_);
}
-#line 426
+#line 431
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -120,7 +120,7 @@ sub unlike ($$;$) {
return $tb->unlike(@_);
}
-#line 471
+#line 476
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -128,7 +128,7 @@ sub cmp_ok($$$;$) {
return $tb->cmp_ok(@_);
}
-#line 506
+#line 511
sub can_ok ($@) {
my( $proto, @methods ) = @_;
@@ -162,7 +162,7 @@ sub can_ok ($@) {
return $ok;
}
-#line 572
+#line 577
sub isa_ok ($$;$) {
my( $object, $class, $obj_name ) = @_;
@@ -222,7 +222,7 @@ WHOA
return $ok;
}
-#line 651
+#line 656
sub new_ok {
my $tb = Test::More->builder;
@@ -247,16 +247,16 @@ sub new_ok {
return $obj;
}
-#line 719
+#line 741
-sub subtest($&) {
+sub subtest {
my ($name, $subtests) = @_;
my $tb = Test::More->builder;
return $tb->subtest(@_);
}
-#line 743
+#line 765
sub pass (;$) {
my $tb = Test::More->builder;
@@ -270,7 +270,7 @@ sub fail (;$) {
return $tb->ok( 0, @_ );
}
-#line 806
+#line 833
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -332,7 +332,7 @@ sub _eval {
return( $eval_result, $eval_error );
}
-#line 875
+#line 902
sub require_ok ($) {
my($module) = shift;
@@ -340,7 +340,7 @@ sub require_ok ($) {
my $pack = caller;
- # Try to deterine if we've been given a module name or file.
+ # Try to determine if we've been given a module name or file.
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
@@ -376,7 +376,7 @@ sub _is_module_name {
return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
}
-#line 952
+#line 979
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -476,14 +476,14 @@ sub _type {
return '' if !ref $thing;
- for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
return $type if UNIVERSAL::isa( $thing, $type );
}
return '';
}
-#line 1112
+#line 1139
sub diag {
return Test::More->builder->diag(@_);
@@ -493,13 +493,13 @@ sub note {
return Test::More->builder->note(@_);
}
-#line 1138
+#line 1165
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1204
+#line 1231
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -527,7 +527,7 @@ sub skip {
last SKIP;
}
-#line 1288
+#line 1315
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -548,7 +548,7 @@ sub todo_skip {
last TODO;
}
-#line 1343
+#line 1370
sub BAIL_OUT {
my $reason = shift;
@@ -557,7 +557,7 @@ sub BAIL_OUT {
$tb->BAIL_OUT($reason);
}
-#line 1382
+#line 1409
#'#
sub eq_array {
@@ -581,6 +581,8 @@ sub _eq_array {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -591,6 +593,21 @@ sub _eq_array {
return $ok;
}
+sub _equal_nonrefs {
+ my( $e1, $e2 ) = @_;
+
+ return if ref $e1 or ref $e2;
+
+ if ( defined $e1 ) {
+ return 1 if defined $e2 and $e1 eq $e2;
+ }
+ else {
+ return 1 if !defined $e2;
+ }
+
+ return;
+}
+
sub _deep_check {
my( $e1, $e2 ) = @_;
my $tb = Test::More->builder;
@@ -603,9 +620,6 @@ sub _deep_check {
local %Refs_Seen = %Refs_Seen;
{
- # Quiet uninitialized value warnings when comparing undefs.
- no warnings 'uninitialized';
-
$tb->_unoverload_str( \$e1, \$e2 );
# Either they're both references or both not.
@@ -616,7 +630,7 @@ sub _deep_check {
$ok = 0;
}
elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both defined.
+ # Shortcut if they're both undefined.
$ok = 1;
}
elsif( _dne($e1) xor _dne($e2) ) {
@@ -683,7 +697,7 @@ WHOA
}
}
-#line 1515
+#line 1556
sub eq_hash {
local @Data_Stack = ();
@@ -706,6 +720,8 @@ sub _eq_hash {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -716,7 +732,7 @@ sub _eq_hash {
return $ok;
}
-#line 1572
+#line 1615
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -741,6 +757,6 @@ sub eq_set {
);
}
-#line 1774
+#line 1817
1;
View
8 inc/parent.pm
@@ -2,7 +2,7 @@
package parent;
use strict;
use vars qw($VERSION);
-$VERSION = '0.223';
+$VERSION = '0.225';
sub import {
my $class = shift;
@@ -24,9 +24,7 @@ sub import {
{
no strict 'refs';
- # This is more efficient than push for the new MRO
- # at least until the new MRO is fixed
- @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , @_);
+ push @{"$inheritor\::ISA"}, @_;
};
};
@@ -34,4 +32,6 @@ sub import {
__END__
+=encoding utf8
+
#line 136
View
5 lib/selfvars.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw( $VERSION $self @args %opts %hopts );
BEGIN {
- $VERSION = '0.22';
+ $VERSION = '0.31';
}
sub import {
@@ -214,6 +214,7 @@ selfvars - Provide $self, @args, %opts and %hopts variables for OO programs
$self->{x} = $opts{x};
$self->{y} = $opts{y};
}
+
### Use %hopts with $obj->yada( x => 1, y => 2 ) call syntax
sub yada {
$self->{x} = $hopts{x}
@@ -222,7 +223,7 @@ selfvars - Provide $self, @args, %opts and %hopts variables for OO programs
=head1 DESCRIPTION
-This moudles exports four special variables: C<$self>, C<@args>, C<%opts> and C<%hopts>.
+This module exports four special variables: C<$self>, C<@args>, C<%opts> and C<%hopts>.
They are really just handy helpers to get rid of:
View
107 lib/selfvars/autoload.pm
@@ -0,0 +1,107 @@
+package selfvars::autoload;
+use 5.005;
+use strict;
+use selfvars ();
+
+sub import {
+ no strict 'refs';
+ my $pkg = caller;
+ *{"$pkg\::AUTOLOAD"} = \&autoload;
+ shift; unshift @_, 'selfvars';
+ goto &selfvars::import;
+}
+
+sub autoload {
+ no strict 'vars';
+ my $method = $AUTOLOAD;
+
+ my $self = do {
+ package DB;
+ my $i = 1;
+ () = caller($i);
+ $DB::args[0];
+ } or do {
+ require Carp;
+ Carp::croak("Undefined subroutine &$AUTOLOAD called");
+ };
+
+ $method =~ s/.*:://;
+ if (my $code = $self->can($method)) {
+ unshift @_, $self;
+ goto &$code;
+ }
+ $self->$method(@_); # ...and let it fail...
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+selfvars::autoload - Turn missing_sub(...) into $_[0]->missing_sub(...) implicitly
+
+=head1 SYNOPSIS
+
+ use Mojolicious::Lite; # The raison d'etre for this module...
+
+ # Import $self, @args, %opts and %hopts into your package;
+ # see "perldoc selfvars" for import options and usage.
+ use selfvars::autoload;
+
+ # Normal invocation with two "$self"s
+ get '/' => sub {
+ my $self = shift;
+ $self->render(text => 'Hello World!');
+ };
+
+ # It's OK to omit "my $self = shift":
+ get '/selfish' => sub {
+ $self->render(text => 'Hello World!');
+ };
+
+ # It's OK to omit the "$self->" part too!
+ get '/selfless' => sub {
+ render(text => 'Hello World!');
+ };
+
+ # dance!
+ app->start;
+
+=head1 DESCRIPTION
+
+This module exports four special variables: C<$self>, C<@args>, C<%opts> and C<%hopts>;
+see L<selfvars> for the full description and import options.
+
+In addition to that, this module sets up an C<AUTOLOAD> subroutine in the importing
+package, so any calls to missing functions becomes a method call with C<$_[0]> as
+the invocant.
+
+If C<$_[0]> is not present, then we ranse an C<Undefined subroutine> exception as usual.
+
+The net effect is that we can start writing Mojolicious apps with Dancer syntax. :-)
+
+=head1 DEPENDENCIES
+
+None.
+
+=head1 SEE ALSO
+
+L<selfvars>, L<Mojolicious>, L<Dancer>
+
+=head1 AUTHORS
+
+唐鳳 E<lt>cpan@audreyt.orgE<gt>
+
+=head1 CC0 1.0 Universal
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to selfvars.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=cut
Please sign in to comment.
Something went wrong with that request. Please try again.