| 1 | package strict; |
| 2 | |
| 3 | $strict::VERSION = "1.11"; |
| 4 | |
| 5 | my ( %bitmask, %explicit_bitmask ); |
| 6 | |
| 7 | BEGIN { |
| 8 | # Verify that we're called correctly so that strictures will work. |
| 9 | # Can't use Carp, since Carp uses us! |
| 10 | # see also warnings.pm. |
| 11 | die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2] |
| 12 | if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' ) |
| 13 | && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' ); |
| 14 | |
| 15 | %bitmask = ( |
| 16 | refs => 0x00000002, |
| 17 | subs => 0x00000200, |
| 18 | vars => 0x00000400, |
| 19 | ); |
| 20 | |
| 21 | %explicit_bitmask = ( |
| 22 | refs => 0x00000020, |
| 23 | subs => 0x00000040, |
| 24 | vars => 0x00000080, |
| 25 | ); |
| 26 | |
| 27 | my $bits = 0; |
| 28 | $bits |= $_ for values %bitmask; |
| 29 | |
| 30 | my $inline_all_bits = $bits; |
| 31 | *all_bits = sub () { $inline_all_bits }; |
| 32 | |
| 33 | $bits = 0; |
| 34 | $bits |= $_ for values %explicit_bitmask; |
| 35 | |
| 36 | my $inline_all_explicit_bits = $bits; |
| 37 | *all_explicit_bits = sub () { $inline_all_explicit_bits }; |
| 38 | } |
| 39 | |
| 40 | sub bits { |
| 41 | my $bits = 0; |
| 42 | my @wrong; |
| 43 | foreach my $s (@_) { |
| 44 | if (exists $bitmask{$s}) { |
| 45 | $^H |= $explicit_bitmask{$s}; |
| 46 | |
| 47 | $bits |= $bitmask{$s}; |
| 48 | } |
| 49 | else { |
| 50 | push @wrong, $s; |
| 51 | } |
| 52 | } |
| 53 | if (@wrong) { |
| 54 | require Carp; |
| 55 | Carp::croak("Unknown 'strict' tag(s) '@wrong'"); |
| 56 | } |
| 57 | $bits; |
| 58 | } |
| 59 | |
| 60 | sub import { |
| 61 | shift; |
| 62 | $^H |= @_ ? &bits : all_bits | all_explicit_bits; |
| 63 | } |
| 64 | |
| 65 | sub unimport { |
| 66 | shift; |
| 67 | |
| 68 | if (@_) { |
| 69 | $^H &= ~&bits; |
| 70 | } |
| 71 | else { |
| 72 | $^H &= ~all_bits; |
| 73 | $^H |= all_explicit_bits; |
| 74 | } |
| 75 | } |
| 76 | |
| 77 | 1; |
| 78 | __END__ |
| 79 | |
| 80 | =head1 NAME |
| 81 | |
| 82 | strict - Perl pragma to restrict unsafe constructs |
| 83 | |
| 84 | =head1 SYNOPSIS |
| 85 | |
| 86 | use strict; |
| 87 | |
| 88 | use strict "vars"; |
| 89 | use strict "refs"; |
| 90 | use strict "subs"; |
| 91 | |
| 92 | use strict; |
| 93 | no strict "vars"; |
| 94 | |
| 95 | =head1 DESCRIPTION |
| 96 | |
| 97 | The C<strict> pragma disables certain Perl expressions that could behave |
| 98 | unexpectedly or are difficult to debug, turning them into errors. The |
| 99 | effect of this pragma is limited to the current file or scope block. |
| 100 | |
| 101 | If no import list is supplied, all possible restrictions are assumed. |
| 102 | (This is the safest mode to operate in, but is sometimes too strict for |
| 103 | casual programming.) Currently, there are three possible things to be |
| 104 | strict about: "subs", "vars", and "refs". |
| 105 | |
| 106 | =over 6 |
| 107 | |
| 108 | =item C<strict refs> |
| 109 | |
| 110 | This generates a runtime error if you |
| 111 | use symbolic references (see L<perlref>). |
| 112 | |
| 113 | use strict 'refs'; |
| 114 | $ref = \$foo; |
| 115 | print $$ref; # ok |
| 116 | $ref = "foo"; |
| 117 | print $$ref; # runtime error; normally ok |
| 118 | $file = "STDOUT"; |
| 119 | print $file "Hi!"; # error; note: no comma after $file |
| 120 | |
| 121 | There is one exception to this rule: |
| 122 | |
| 123 | $bar = \&{'foo'}; |
| 124 | &$bar; |
| 125 | |
| 126 | is allowed so that C<goto &$AUTOLOAD> would not break under stricture. |
| 127 | |
| 128 | |
| 129 | =item C<strict vars> |
| 130 | |
| 131 | This generates a compile-time error if you access a variable that was |
| 132 | neither explicitly declared (using any of C<my>, C<our>, C<state>, or C<use |
| 133 | vars>) nor fully qualified. (Because this is to avoid variable suicide |
| 134 | problems and subtle dynamic scoping issues, a merely C<local> variable isn't |
| 135 | good enough.) See L<perlfunc/my>, L<perlfunc/our>, L<perlfunc/state>, |
| 136 | L<perlfunc/local>, and L<vars>. |
| 137 | |
| 138 | use strict 'vars'; |
| 139 | $X::foo = 1; # ok, fully qualified |
| 140 | my $foo = 10; # ok, my() var |
| 141 | local $baz = 9; # blows up, $baz not declared before |
| 142 | |
| 143 | package Cinna; |
| 144 | our $bar; # Declares $bar in current package |
| 145 | $bar = 'HgS'; # ok, global declared via pragma |
| 146 | |
| 147 | The local() generated a compile-time error because you just touched a global |
| 148 | name without fully qualifying it. |
| 149 | |
| 150 | Because of their special use by sort(), the variables $a and $b are |
| 151 | exempted from this check. |
| 152 | |
| 153 | =item C<strict subs> |
| 154 | |
| 155 | This disables the poetry optimization, generating a compile-time error if |
| 156 | you try to use a bareword identifier that's not a subroutine, unless it |
| 157 | is a simple identifier (no colons) and that it appears in curly braces or |
| 158 | on the left hand side of the C<< => >> symbol. |
| 159 | |
| 160 | use strict 'subs'; |
| 161 | $SIG{PIPE} = Plumber; # blows up |
| 162 | $SIG{PIPE} = "Plumber"; # fine: quoted string is always ok |
| 163 | $SIG{PIPE} = \&Plumber; # preferred form |
| 164 | |
| 165 | =back |
| 166 | |
| 167 | See L<perlmodlib/Pragmatic Modules>. |
| 168 | |
| 169 | =head1 HISTORY |
| 170 | |
| 171 | C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted |
| 172 | compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or |
| 173 | inside curlies), but without forcing it always to a literal string. |
| 174 | |
| 175 | Starting with Perl 5.8.1 strict is strict about its restrictions: |
| 176 | if unknown restrictions are used, the strict pragma will abort with |
| 177 | |
| 178 | Unknown 'strict' tag(s) '...' |
| 179 | |
| 180 | As of version 1.04 (Perl 5.10), strict verifies that it is used as |
| 181 | "strict" to avoid the dreaded Strict trap on case insensitive file |
| 182 | systems. |
| 183 | |
| 184 | =cut |