--- /dev/null
+blib*
+pm_to_blib*
+
+Makefile
+Makefile.old
+Build
+_build*
+
+*.tar.gz
+indirect-*
+
+core.*
+*.[co]
+*.so
+*.bs
+*.out
+*.def
+*.exp
+
+cover_db
+*.gcda
+*.gcov
+*.gcno
--- /dev/null
+Revision history for indirect
+
+0.01 2008-08-10 20:40 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+README
+indirect.xs
+lib/indirect.pm
+samples/indirect.pl
+t/00-load.t
+t/10-good-no.t
+t/11-good-use.t
+t/20-bad-no.t
+t/21-bad-use.t
+t/22-bad-fatal.t
+t/30-scope.t
+t/90-boilerplate.t
+t/91-pod.t
+t/92-pod-coverage.t
+t/95-portability-files.t
+t/99-kwalitee.t
+t/data/bad.d
+t/data/good.d
+t/data/mixed.d
+META.yml Module meta-data (added by MakeMaker)
--- /dev/null
+--- #YAML:1.0
+name: indirect
+version: 0.01
+abstract: Lexically warn about using the indirect object syntax.
+license: perl
+author:
+ - Vincent Pit <perl@profvince.com>
+generated_by: ExtUtils::MakeMaker version 6.42
+distribution_type: module
+requires:
+ XSLoader: 0
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
+build_requires:
+ ExtUtils::MakeMaker: 0
+ IPC::Cmd: 0
+ Test::More: 0
--- /dev/null
+use 5.009004;
+
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+my $BUILD_REQUIRES = {
+ 'ExtUtils::MakeMaker' => 0,
+ 'IPC::Cmd' => 0,
+ 'Test::More' => 0,
+};
+
+sub build_req {
+ my $tometa = ' >> $(DISTVNAME)/META.yml;';
+ my $build_req = 'echo "build_requires:" ' . $tometa;
+ foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) {
+ my $ver = $BUILD_REQUIRES->{$mod};
+ $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa;
+ }
+ return $build_req;
+}
+
+WriteMakefile(
+ NAME => 'indirect',
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ LICENSE => 'perl',
+ VERSION_FROM => 'lib/indirect.pm',
+ ABSTRACT_FROM => 'lib/indirect.pm',
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'XSLoader' => 0,
+ },
+ dist => {
+ PREOP => 'pod2text lib/indirect.pm > $(DISTVNAME)/README; '
+ . build_req,
+ COMPRESS => 'gzip -9f', SUFFIX => 'gz'
+ },
+ clean => { FILES => 'indirect-* *.gcov *.gcda *.gcno cover_db' },
+);
--- /dev/null
+NAME
+ indirect - Lexically warn about using the indirect object syntax.
+
+VERSION
+ Version 0.01
+
+SYNOPSIS
+ no indirect;
+ my $x = new Apple 1, 2, 3; # warns
+ {
+ use indirect;
+ my $y = new Pear; # ok
+ }
+ no indirect ':fatal';
+ if (defied $foo) { ... } # croaks, note the typo
+
+DESCRIPTION
+ When enabled (or disabled as some may prefer, since you actually turn it
+ on by calling "no indirect"), this pragma warns about indirect object
+ syntax constructs that may have slipped into your code. This syntax is
+ now considered harmful, since its parsing has many quirks and its use is
+ error prone (when "sub" isn't defined, "sub $x" is actually interpreted
+ as "$x->sub").
+
+ It currently does not warn when the object is enclosed between braces
+ (like "meth { $obj } @args") or for core functions ("print" or "say").
+ This may change in the future, or may be added as optional features that
+ would be enabled by passing options to "unimport".
+
+METHODS
+ "unimport @opts"
+ Magically called when "no indirect @args" is encountered. Turns the
+ module on. If @opts contains ':fatal', the module will croak on the
+ first indirect syntax met.
+
+ "import"
+ Magically called at each "use indirect". Turns the module off.
+
+DEPENDENCIES
+ perl 5.9.4.
+
+ XSLoader (standard since perl 5.006).
+
+ Tests require IPC::Cmd (standard since 5.9.5).
+
+AUTHOR
+ Vincent Pit, "<perl at profvince.com>", <http://www.profvince.com>.
+
+ You can contact me by mail or on #perl @ FreeNode (vincent or
+ Prof_Vince).
+
+BUGS
+ Please report any bugs or feature requests to "bug-indirect at
+ rt.cpan.org", or through the web interface at
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=indirect>. I will be
+ notified, and then you'll automatically be notified of progress on your
+ bug as I make changes.
+
+SUPPORT
+ You can find documentation for this module with the perldoc command.
+
+ perldoc indirect
+
+ACKNOWLEDGEMENTS
+ Bram, for motivation and advices.
+
+COPYRIGHT & LICENSE
+ Copyright 2008 Vincent Pit, all rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
--- /dev/null
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef SvPVX_const
+# define SvPVX_const SvPVX
+#endif
+
+STATIC U32 indirect_initialized = 0;
+STATIC U32 indirect_hash = 0;
+
+STATIC const char indirect_msg[] = "Indirect call of method \"%s\" on object \"%s\"";
+
+STATIC HV *indirect_map = NULL;
+STATIC const char *indirect_linestr = NULL;
+
+STATIC UV indirect_hint(pTHX) {
+#define indirect_hint() indirect_hint(aTHX)
+ SV *id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+ NULL,
+ "indirect", 8,
+ 0,
+ indirect_hash);
+ return SvOK(id) ? SvUV(id) : 0;
+}
+
+STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) {
+#define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N))
+ char buf[32];
+ const char *pl_linestr;
+ SV *val;
+
+ /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q)
+ * In this case the linestr has temporarly changed, but the old buffer should
+ * still be alive somewhere. */
+
+ if (!PL_parser->lex_inwhat) {
+ pl_linestr = SvPVX_const(PL_parser->linestr);
+ if (indirect_linestr != pl_linestr) {
+ hv_clear(indirect_map);
+ indirect_linestr = pl_linestr;
+ }
+ }
+
+ val = newSVsv(sv);
+ SvUPGRADE(val, SVt_PVIV);
+ SvUVX(val) = PTR2UV(src);
+ if (!hv_store(indirect_map, buf, sprintf(buf, "%u", PTR2UV(o)), val, 0))
+ SvREFCNT_dec(val);
+}
+
+STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV **name) {
+#define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S))
+ char buf[32];
+ SV **val;
+
+ if (indirect_linestr != SvPVX(PL_parser->linestr))
+ return NULL;
+
+ val = hv_fetch(indirect_map, buf, sprintf(buf, "%u", PTR2UV(o)), 0);
+ if (!val) {
+ *name = NULL;
+ return NULL;
+ }
+
+ *name = *val;
+ return INT2PTR(const char *, SvUVX(*val));
+}
+
+STATIC UV indirect_intuit(const char *meth, const char *obj) {
+ const char *s;
+ int indirect = 0, quotelike = 0;
+
+ for (s = meth; s < obj; ++s) {
+ switch (*s) {
+ case ',':
+ case '(':
+ case '=':
+ case '\'':
+ case '"':
+ case '`':
+ return 0;
+ case '-':
+ indirect = 1;
+ break;
+ case '>':
+ if (indirect)
+ return 0;
+ break;
+ case 'q':
+ indirect = 0;
+ if (quotelike == 1)
+ quotelike = 2;
+ break;
+ case 'w':
+ case 'r':
+ case 'x':
+ indirect = 0;
+ if (quotelike != 2)
+ quotelike = 0;
+ break;
+ default:
+ indirect = 0;
+ if (isSPACE(*s))
+ quotelike = 1;
+ else if (quotelike == 2 && !isALNUM(*s))
+ return 0;
+ else
+ quotelike = 0;
+ }
+ }
+
+ return 1;
+}
+
+STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) {
+#define indirect_find(N, S) indirect_find(aTHX_ (N), (S))
+ STRLEN len;
+ const char *p = NULL, *r = SvPV_const(sv, len);
+
+ if (!len)
+ return s;
+
+ p = strstr(s, r);
+ while (p) {
+ p += len;
+ if (!isALNUM(*p))
+ break;
+ p = strstr(p + 1, r);
+ }
+
+ return p;
+}
+
+STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_const(pTHX_ OP *o) {
+ if (indirect_hint()) {
+ SV *sv = cSVOPo_sv;
+ if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV))
+ indirect_map_store(o, indirect_find(sv, PL_parser->oldbufptr), sv);
+ }
+
+ return CALL_FPTR(indirect_old_ck_const)(aTHX_ o);
+}
+
+STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
+ if (indirect_hint()) {
+ OP *op = cUNOPo->op_first;
+ SV *name = cSVOPx_sv(op);
+ if (SvPOK(name) && (SvTYPE(name) >= SVt_PV)) {
+ SV *sv = sv_2mortal(newSVpvn("$", 1));
+ sv_catsv(sv, name);
+ indirect_map_store(o, indirect_find(sv, PL_parser->oldbufptr), sv);
+ }
+ }
+
+ return CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
+}
+
+STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
+ if (indirect_hint()) {
+ SV *sv;
+ const char *s = PL_parser->oldbufptr, *t = PL_parser->bufptr - 1;
+
+ while (s < t && isSPACE(*s)) ++s;
+ while (t > s && isSPACE(*t)) --t;
+ sv = sv_2mortal(newSVpvn(s, t - s + 1));
+
+ indirect_map_store(o, s, sv);
+ }
+
+ return CALL_FPTR(indirect_old_ck_padany)(aTHX_ o);
+}
+
+STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_method(pTHX_ OP *o) {
+ if (indirect_hint()) {
+ OP *op = cUNOPo->op_first;
+ SV *sv;
+ const char *s = indirect_map_fetch(op, &sv);
+ if (!s) {
+ sv = cSVOPx_sv(op);
+ if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
+ goto done;
+ sv = sv_mortalcopy(sv);
+ s = indirect_find(sv, PL_parser->oldbufptr);
+ }
+ o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
+ /* o may now be a method_named */
+ indirect_map_store(o, s, sv);
+ return o;
+ }
+
+done:
+ return CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
+}
+
+STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
+ LISTOP *op;
+ OP *om, *oo;
+ UV hint = indirect_hint();
+
+ if (hint) {
+ const char *pm, *po;
+ SV *svm, *svo;
+ op = (LISTOP *) o;
+ while (op->op_type != OP_PUSHMARK)
+ op = (LISTOP *) op->op_first;
+ oo = op->op_sibling;
+ om = oo;
+ while (om->op_sibling)
+ om = om->op_sibling;
+ if (om->op_type == OP_METHOD)
+ om = cUNOPx(om)->op_first;
+ pm = indirect_map_fetch(om, &svm);
+ po = indirect_map_fetch(oo, &svo);
+ if (pm && po && pm < po && indirect_intuit(pm, po))
+ ((hint == 2) ? croak : warn)(indirect_msg, SvPV_nolen(svm), SvPV_nolen(svo));
+ }
+
+ return CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o);
+}
+
+MODULE = indirect PACKAGE = indirect
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+ if (!indirect_initialized++) {
+ PERL_HASH(indirect_hash, "indirect", 8);
+ indirect_map = newHV();
+ indirect_old_ck_const = PL_check[OP_CONST];
+ PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_ck_const);
+ indirect_old_ck_rv2sv = PL_check[OP_RV2SV];
+ PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_ck_rv2sv);
+ indirect_old_ck_padany = PL_check[OP_PADANY];
+ PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_ck_padany);
+ indirect_old_ck_method = PL_check[OP_METHOD];
+ PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method);
+ indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
+ PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub);
+ }
+}
--- /dev/null
+package indirect;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+indirect - Lexically warn about using the indirect object syntax.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION;
+BEGIN {
+ $VERSION = '0.01';
+}
+
+=head1 SYNOPSIS
+
+ no indirect;
+ my $x = new Apple 1, 2, 3; # warns
+ {
+ use indirect;
+ my $y = new Pear; # ok
+ }
+ no indirect ':fatal';
+ if (defied $foo) { ... } # croaks, note the typo
+
+=head1 DESCRIPTION
+
+When enabled (or disabled as some may prefer, since you actually turn it on by calling C<no indirect>), this pragma warns about indirect object syntax constructs that may have slipped into your code. This syntax is now considered harmful, since its parsing has many quirks and its use is error prone (when C<sub> isn't defined, C<sub $x> is actually interpreted as C<< $x->sub >>).
+
+It currently does not warn when the object is enclosed between braces (like C<meth { $obj } @args>) or for core functions (C<print> or C<say>). This may change in the future, or may be added as optional features that would be enabled by passing options to C<unimport>.
+
+=head1 METHODS
+
+=head2 C<unimport @opts>
+
+Magically called when C<no indirect @args> is encountered. Turns the module on. If C<@opts> contains C<':fatal'>, the module will croak on the first indirect syntax met.
+
+=head2 C<import>
+
+Magically called at each C<use indirect>. Turns the module off.
+
+=cut
+
+BEGIN {
+ require XSLoader;
+ XSLoader::load(__PACKAGE__, $VERSION);
+}
+
+sub import {
+ $^H{indirect} = undef;
+}
+
+sub unimport {
+ (undef, my $type) = @_;
+ $^H{indirect} = (defined $type and $type eq ':fatal') ? 2 : 1;
+}
+
+=head1 DEPENDENCIES
+
+L<perl> 5.9.4.
+
+L<XSLoader> (standard since perl 5.006).
+
+Tests require L<IPC::Cmd> (standard since 5.9.5).
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-indirect at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=indirect>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc indirect
+
+=head1 ACKNOWLEDGEMENTS
+
+Bram, for motivation and advices.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2008 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of indirect
--- /dev/null
+#!/usr/bin/env perl
+
+#use strict;
+#use warnings;
+
+use lib qw{blib/lib blib/arch};
+
+sub Hlagh::new { my $class = shift; bless { }, ref($class) || $class ; }
+
+sub foo { shift; print "foo $_[0]\n" }
+sub bar { print "wut\n"; }
+my $bar = bless { }, 'main';
+
+my %h;
+my $x = 1;
+
+no indirect;
+
+$x = new Hlagh 1, 2, 3;
+my $y = slap $x "what", 5;
+$h{foo} = 12;
+
+use indirect;
+
+foo 4, 5;
+
+no indirect;
+
+my $pkg = 'Hlagh';
+my $cb = 'new';
+
+foo(6, 7, 8); my $y = new $_ qr/bar/;
+
+my $y = Hlagh->new;
+$y = new Hlagh;
+my $z = foo meh, 1, 2;
+$y = meh $x, 7;
+$y = foo(3, 4);
+$y = Hlagh->new();
+$y = Hlagh->new(1, 2, 3);
+$y = Hlagh->$cb;
+$y = new Hlagh;
+$y = new Hlagh 1, 2, 3;
+$y =
+ new
+ Hlagh
+ 1 ,
+ 2, 3;
+$y = new $pkg;
+$y = new $pkg 'what';
+$y = $pkg->new;
+$y = $pkg->new(1, 2, 3);
+$y = $pkg->$cb;
+$y = new(Hlagh);
+$y = new { Hlagh };
+$y = new { $y };
+$y = Hlagh
+ -> new
+ ( 1 , 2, 3);
+$y = Hlagh
+ -> $ cb
+ ( 1 , 2, 3);
+$y = new Hlagh $,;
+$y = new Hlagh ',';
+print { $^H{dongs} } 'bleh';
+print STDERR 1;
+print STDERR 'what';
+print STDERR q{wat};
+my $fh;
+print $fh 'dongs';
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'indirect' );
+}
+
+diag( "Testing indirect $indirect::VERSION, Perl $], $^X" );
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $total;
+BEGIN {
+ $total = 32;
+}
+
+use Test::More tests => $total + 1;
+
+use IPC::Cmd qw/run/;
+
+(my $success, my $err_code, undef, undef, my $stderr)
+ = run command => [
+ $^X,
+ map('-I' . $_, @INC),
+ '-M-indirect',
+ '-c',
+ 't/data/good.d'
+ ];
+unless ($success) {
+ $stderr = pop @$stderr if ref $stderr eq 'ARRAY';
+ BAIL_OUT("Failed to execute data file (error $err_code) : $stderr");
+}
+$stderr = join "\n", @$stderr if ref $stderr eq 'ARRAY';
+
+my %fail;
+my $extra_fail = 0;
+
+while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) {
+ my ($m, $o) = ($1, $2);
+ my $id;
+ if ($m =~ /^(?:new|potato)(\d+)$/) {
+ $id = $1;
+ } elsif ($o =~ /^Hlagh(\d+)$/) {
+ $id = $1;
+ } else {
+ diag "$m $o";
+ ++$extra_fail;
+ }
+ if ($id) {
+ fail("test $id shouldn't have failed");
+ $fail{$id} = 1;
+ }
+}
+
+pass("test $_ hasn't failed") for grep { !$fail{$_} } 1 .. $total;
+is($extra_fail, 0, 'no extra fails');
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $total;
+BEGIN {
+ $total = 32;
+}
+
+use Test::More tests => $total + 1;
+
+use IPC::Cmd qw/run/;
+
+(my $success, my $err_code, undef, undef, my $stderr)
+ = run command => [
+ $^X,
+ map('-I' . $_, @INC),
+ '-Mindirect',
+ '-c',
+ 't/data/good.d'
+ ];
+unless ($success) {
+ $stderr = pop @$stderr if ref $stderr eq 'ARRAY';
+ BAIL_OUT("Failed to execute data file (error $err_code) : $stderr");
+}
+$stderr = join "\n", @$stderr if ref $stderr eq 'ARRAY';
+
+my %fail;
+my $extra_fail = 0;
+
+while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) {
+ my ($m, $o) = ($1, $2);
+ my $id;
+ if ($m =~ /^(?:new|potato)(\d+)$/) {
+ $id = $1;
+ } elsif ($o =~ /^Hlagh(\d+)$/) {
+ $id = $1;
+ } else {
+ diag "$m $o";
+ ++$extra_fail;
+ }
+ if ($id) {
+ fail("test $id shouldn't have failed");
+ $fail{$id} = 1;
+ }
+}
+
+pass("test $_ hasn't failed") for grep { !$fail{$_} } 1 .. $total;
+is($extra_fail, 0, 'no extra fails');
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $total;
+BEGIN {
+ $total = 28;
+}
+
+use Test::More tests => $total + 1;
+
+use IPC::Cmd qw/run/;
+
+(my $success, my $err_code, undef, undef, my $stderr)
+ = run command => [
+ $^X,
+ map('-I' . $_, @INC),
+ '-M-indirect',
+ '-c',
+ 't/data/bad.d'
+ ];
+unless ($success) {
+ $stderr = pop @$stderr if ref $stderr eq 'ARRAY';
+ BAIL_OUT("Failed to execute data file (error $err_code) : $stderr");
+}
+$stderr = join "\n", @$stderr if ref $stderr eq 'ARRAY';
+
+my %fail = map { $_ => 1 } 1 .. $total;
+my $extra_fail = 0;
+
+while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) {
+ my ($m, $o) = ($1, $2);
+ my $id;
+ if ($m =~ /^(?:new|potato)(\d+)$/) {
+ $id = $1;
+ } elsif ($o =~ /^Hlagh(\d+)$/) {
+ $id = $1;
+ } else {
+ diag "$m $o";
+ ++$extra_fail;
+ }
+ if ($id) {
+ ok($fail{$id}, "test $id failed as expected");
+ delete $fail{$id};
+ }
+}
+
+fail("test $_ hasn't failed") for sort { $a <=> $b } keys %fail;
+is($extra_fail, 0, 'no extra fails');
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $total;
+BEGIN {
+ $total = 28;
+}
+
+use Test::More tests => $total + 1;
+
+use IPC::Cmd qw/run/;
+
+(my $success, my $err_code, undef, undef, my $stderr)
+ = run command => [
+ $^X,
+ map('-I' . $_, @INC),
+ '-Mindirect',
+ '-c',
+ 't/data/bad.d'
+ ];
+unless ($success) {
+ $stderr = pop @$stderr if ref $stderr eq 'ARRAY';
+ BAIL_OUT("Failed to execute data file (error $err_code) : $stderr");
+}
+$stderr = join "\n", @$stderr if ref $stderr eq 'ARRAY';
+
+my %fail;
+my $extra_fail = 0;
+
+while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) {
+ my ($m, $o) = ($1, $2);
+ my $id;
+ if ($m =~ /^(?:new|potato)(\d+)$/) {
+ $id = $1;
+ } elsif ($o =~ /^Hlagh(\d+)$/) {
+ $id = $1;
+ } else {
+ diag "$m $o";
+ ++$extra_fail;
+ }
+ if ($id) {
+ fail("test $id shouldn't have failed");
+ $fail{$id} = 1;
+ }
+}
+
+pass("test $_ hasn't failed") for grep { !$fail{$_} } 1 .. $total;
+is($extra_fail, 0, 'no extra fails');
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $total;
+BEGIN {
+ $total = 20;
+}
+
+use Test::More tests => 1;
+
+use IPC::Cmd qw/run/;
+
+(my $success, my $err_code, undef, undef, my $stderr)
+ = run command => [
+ $^X,
+ map('-I' . $_, @INC),
+ '-M-indirect=:fatal',
+ '-c',
+ 't/data/bad.d'
+ ];
+
+$stderr = join "\n", @$stderr if ref $stderr eq 'ARRAY';
+ok(!$success && $err_code && $stderr =~ /^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"Hlagh1"/mg, 'croak when :fatal is specified');
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $total;
+BEGIN {
+ $total = 8;
+}
+
+use Test::More tests => $total + 1;
+
+use IPC::Cmd qw/run/;
+
+(my $success, my $err_code, undef, undef, my $stderr)
+ = run command => [
+ $^X,
+ map('-I' . $_, @INC),
+ '-c',
+ 't/data/mixed.d'
+ ];
+unless ($success) {
+ $stderr = pop @$stderr if ref $stderr eq 'ARRAY';
+ BAIL_OUT("Failed to execute data file (error $err_code) : $stderr");
+}
+$stderr = join "\n", @$stderr if ref $stderr eq 'ARRAY';
+
+my %fail = map { $_ => 1 } 2, 3, 5, 7;
+my %failed;
+my $extra_fail = 0;
+
+while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) {
+ my ($m, $o) = ($1, $2);
+ my $id;
+ if ($o =~ /^P(\d+)$/) {
+ $id = $1;
+ } else {
+ diag "$m $o";
+ ++$extra_fail;
+ }
+ if ($id) {
+ if (exists $fail{$id}) {
+ pass("test $id failed as expected");
+ delete $fail{$id};
+ $failed{$id} = 1;
+ } else {
+ fail("test $id shouldn't have failed");
+ }
+ }
+}
+
+pass("test $_ hasn't failed") for grep { !$failed{$_} } 1 .. $total;
+fail("test $_ should have failed") for sort { $a <=> $b } keys %fail;
+is($extra_fail, 0, 'no extra fails');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open( my $fh, '<', $filename )
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+);
+
+module_boilerplate_ok('lib/indirect.pm');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
+
+all_pod_coverage_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Portability::Files";
+plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@;
+run_tests();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $obj;
+my $pkg;
+my $cb;
+
+$obj = new Hlagh1;
+$obj = new Hlagh2();
+$obj = new Hlagh3(1);
+$obj = new Hlagh4(1, 2);
+
+$obj = new Hlagh5 ;
+$obj = new Hlagh6 ( ) ;
+$obj = new Hlagh7 ( 1 ) ;
+$obj = new Hlagh8 ( 1 , 2 ) ;
+
+$obj = new
+ Hlagh9
+ ;
+$obj = new
+ Hlagh10 (
+ ) ;
+$obj =
+ new
+ Hlagh11 ( 1
+ ) ;
+$obj =
+new
+Hlagh12
+ ( 1 ,
+ 2 ) ;
+
+my $x;
+$obj = new13 $x;
+$obj = new14 $x();
+$obj = new15 $x('foo');
+$obj = new16 $x qq{foo}, 1;
+$obj = new17 $x qr{foo\s+bar}, 1 .. 1;
+$obj = new18 $x(qw/bar baz/);
+
+$obj = new19
+ $_;
+$obj = new20
+ $_ ( );
+$obj = new21 $_ qr/foo/ ;
+$obj = new22 $_ qq(bar baz);
+
+potato23 $x;
+potato24 $x, 1, 2;
+
+$obj = Hlagh25Hlagh25 Hlagh25;
+$obj = Hlagh26Hlagh26 Hlagh26; # Hlagh26Hlagh26 Hlagh26
+$obj = new27 new27new27;
+$obj = new28 new28new28; # new28 new28new28
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $obj;
+my $pkg;
+my $cb;
+
+$obj = Hlagh1->new;
+$obj = Hlagh2->new();
+$obj = Hlagh3->new(1);
+$obj = Hlagh4->new(q{foo}, bar => $obj);
+
+$obj = Hlagh5 -> new ;
+$obj = Hlagh6 -> new ( ) ;
+$obj = Hlagh7 -> new ( 1 ) ;
+$obj = Hlagh8 -> new ( 'foo' , bar => $obj );
+
+$obj = Hlagh9
+ ->
+ new ;
+$obj = Hlagh10
+
+ ->
+new (
+ ) ;
+$obj = Hlagh11
+ -> new (
+ 1 ) ;
+$obj = Hlagh12 ->
+ new ( "foo"
+ , bar
+ => $obj );
+
+$obj = Hlagh13->$cb;
+$obj = Hlagh14->$cb();
+$obj = Hlagh15->$cb($pkg);
+$obj = Hlagh16->$cb(sub { 'foo' }, bar => $obj);
+
+$obj = $pkg->new17 ;
+$obj = $pkg -> new18 ( );
+$obj = $pkg
+ ->
+ new19 ( $pkg );
+$obj =
+ $pkg
+->
+new20 ( qr/foo/,
+ foo => qr/bar/ );
+
+$obj
+ =
+$pkg
+->
+$cb
+;
+$obj = $pkg -> ($cb) ();
+$obj = $pkg->$cb( $obj );
+$obj = $pkg->$cb(qw/foo bar baz/);
+
+my $x;
+
+$obj = new25 { $x };
+$obj = new26
+ {
+ $x }
+ ();
+$obj = new27 {
+ $x } qq/foo/;
+$obj = new28
+ {
+ $x
+ }(qw/bar baz/);
+
+sub potato29;
+sub potato30;
+
+potato29 $x;
+potato30 $x, 1 , 2;
+
+print STDOUT "bananananananana\n";
+print $x "oh hai\n";
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+my $a = new P1;
+
+{
+ no indirect;
+ my $b = new P2;
+ {
+ my $c = new P3;
+ }
+ {
+ use indirect;
+ my $d = new P4;
+ }
+ my $e = new P5;
+}
+
+my $f = new P6;
+
+no indirect;
+
+my $g = new P7;
+
+use indirect;
+
+my $h = new P8;
projects / perl / modules / indirect.git / commitdiff