RIBASUSHI / DBIx-Class-0.082810 / t / lib / DBICTest / Util / OverrideRequire.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

              
package DBICTest::Util::OverrideRequire;
# no use/require of any kind - work bare
BEGIN {
  # Neat STDERR require call tracer
  #
  # 0 - no trace
  # 1 - just requires and return values
  # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto)
  # 3 - full stacktrace
  *TRACE = sub () { 0 };
}
# Takes a single coderef and replaces CORE::GLOBAL::require with it.
#
# On subsequent require() calls, the coderef will be invoked with
# two arguments - ($next_require, $module_name_copy)
#
# $next_require is a coderef closing over the module name. It needs
# to be invoked at some point without arguments for the actual
# require to take place (this way your coderef in essence becomes an
# around modifier)
#
# $module_name_copy is a string-copy of what $next_require is closing
# over. The reason for the copy is that you may trigger a side effect
# on magical values, and subsequently abort the require (e.g.
# require v.5.8.8 magic)
#
# All of this almost verbatim copied from Lexical::SealRequireHints
# Zefram++
sub override_global_require (&) {
  my $override_cref = shift;
  our $next_require = defined(&CORE::GLOBAL::require)
    ? \&CORE::GLOBAL::require
    : sub {
      my ($arg) = @_;
      # The shenanigans with $CORE::GLOBAL::{require}
      # are required because if there's a
      # &CORE::GLOBAL::require when the eval is
      # executed then the CORE::require in there is
      # interpreted as plain require on some Perl
      # versions, leading to recursion.
      my $grequire = delete $CORE::GLOBAL::{require};
      my $res = eval sprintf '
        local $SIG{__DIE__};
        $CORE::GLOBAL::{require} = $grequire;
        package %s;
        CORE::require($arg);
      ', scalar caller(0);  # the caller already had its package replaced
      my $err = $@ if $@ ne '';
      if( TRACE ) {
        if (TRACE == 1) {
          printf STDERR "Require of '%s' (returned: '%s')\n",
            (my $m_copy = $arg),
            (my $r_copy = $res),
          ;
        }
        else {
          my ($fr_num, @fr, @tr, $excise);
          while (@fr = caller($fr_num++)) {
            # Package::Stash::XS is a cock and gets mightily confused if one
            # uses a regex in the require hook. Even though it happens only
            # on < 5.8.7 it's still rather embarassing (also wtf does P::S::XS
            # even need to regex its own module name?!). So we do not use re :)
            if (TRACE == 3 or (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) ) {
              push @tr, [@fr]
            }
            # the caller before this would be the override site - kill it away
            # if the cref writer uses goto - well tough, tracer won't work
            if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') {
              $excise ||= $tr[-2]
                if TRACE == 2;
            }
          }
          my @stack =
            map { "$_->[1], line $_->[2]" }
            grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] }
            @tr
          ;
          printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
            (my $m_copy = $arg),
            (my $r_copy = $res||''),
            join "\n", (map { "    $_" } @stack)
          ;
        }
      }
      die $err if defined $err;
      return $res;
    }
  ;
  # Need to suppress the redefinition warning, without
  # invoking warnings.pm.
  BEGIN { ${^WARNING_BITS} = ""; }
  *CORE::GLOBAL::require = sub {
    die "wrong number of arguments to require\n"
      unless @_ == 1;
    # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
    my ($arg_copy) = our ($arg) = @_;
    return $override_cref->(sub {
      die "The require delegate takes no arguments\n"
        if @_;
      my $res = eval sprintf '
        local $SIG{__DIE__};
        package %s;
        $next_require->($arg);
      ', scalar caller(2);  # 2 for the indirection of the $override_cref around
      die $@ if $@ ne '';
      return $res;
    }, $arg_copy);
  }
}
1;