"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/strict.pm" (18 Apr 2017, 4738 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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