+die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
+ if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' )
+ && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
+
+KEYWORDS
+
+sub Croaker
+{
+ require Carp; # this initializes %CarpInternal
+ local $Carp::CarpInternal{'warnings'};
+ delete $Carp::CarpInternal{'warnings'};
+ Carp::croak(@_);
+}
+
+sub _expand_bits {
+ my $bits = shift;
+ my $want_len = ($LAST_BIT + 7) >> 3;
+ my $len = length($bits);
+ if ($len != $want_len) {
+ if ($bits eq "") {
+ $bits = "\x00" x $want_len;
+ } elsif ($len > $want_len) {
+ substr $bits, $want_len, $len-$want_len, "";
+ } else {
+ my $a = vec($bits, $Offsets{all} >> 1, 2);
+ $a |= $a << 2;
+ $a |= $a << 4;
+ $bits .= chr($a) x ($want_len - $len);
+ }
+ }
+ return $bits;
+}
+
+sub _bits {
+ my $mask = shift ;
+ my $catmask ;
+ my $fatal = 0 ;
+ my $no_fatal = 0 ;
+
+ $mask = _expand_bits($mask);
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ $fatal = 1;
+ $no_fatal = 0;
+ }
+ elsif ($word eq 'NONFATAL') {
+ $fatal = 0;
+ $no_fatal = 1;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ;
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ return $mask ;
+}
+
+sub bits
+{
+ # called from B::Deparse.pm
+ push @_, 'all' unless @_ ;
+ return _bits("", @_) ;
+}
+
+sub import
+{
+ shift;
+
+ my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
+
+ # append 'all' when implied (empty import list or after a lone
+ # "FATAL" or "NONFATAL")
+ push @_, 'all'
+ if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL'));
+
+ ${^WARNING_BITS} = _bits($mask, @_);
+}
+
+sub unimport
+{
+ shift;
+
+ my $catmask ;
+ my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
+
+ # append 'all' when implied (empty import list or after a lone "FATAL")
+ push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
+
+ $mask = _expand_bits($mask);
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ next;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask = ~(~$mask | $catmask | $DeadBits{$word});
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ ${^WARNING_BITS} = $mask ;
+}
+
+my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
+
+sub LEVEL () { 8 };
+sub MESSAGE () { 4 };
+sub FATAL () { 2 };
+sub NORMAL () { 1 };
+
+sub __chk
+{
+ my $category ;
+ my $offset ;
+ my $isobj = 0 ;
+ my $wanted = shift;
+ my $has_message = $wanted & MESSAGE;
+ my $has_level = $wanted & LEVEL ;
+
+ if ($has_level) {
+ if (@_ != ($has_message ? 3 : 2)) {
+ my $sub = (caller 1)[3];
+ my $syntax = $has_message
+ ? "category, level, 'message'"
+ : 'category, level';
+ Croaker("Usage: $sub($syntax)");
+ }
+ }
+ elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) {
+ my $sub = (caller 1)[3];
+ my $syntax = $has_message ? "[category,] 'message'" : '[category]';
+ Croaker("Usage: $sub($syntax)");
+ }
+
+ my $message = pop if $has_message;
+
+ if (@_) {
+ # check the category supplied.
+ $category = shift ;
+ if (my $type = ref $category) {
+ Croaker("not an object")
+ if exists $builtin_type{$type};
+ $category = $type;
+ $isobj = 1 ;
+ }
+ $offset = $Offsets{$category};
+ Croaker("Unknown warnings category '$category'")
+ unless defined $offset;
+ }
+ else {
+ $category = (caller(1))[0] ;
+ $offset = $Offsets{$category};
+ Croaker("package '$category' not registered for warnings")
+ unless defined $offset ;
+ }
+
+ my $i;
+
+ if ($isobj) {
+ my $pkg;
+ $i = 2;
+ while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
+ last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
+ }
+ $i -= 2 ;
+ }
+ elsif ($has_level) {
+ $i = 2 + shift;
+ }
+ else {
+ $i = _error_loc(); # see where Carp will allocate the error
+ }
+
+ # Default to 0 if caller returns nothing. Default to $DEFAULT if it
+ # explicitly returns undef.
+ my(@callers_bitmask) = (caller($i))[9] ;
+ my $callers_bitmask =
+ @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
+ length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all};
+
+ my @results;
+ foreach my $type (FATAL, NORMAL) {
+ next unless $wanted & $type;
+
+ push @results, vec($callers_bitmask, $offset + $type - 1, 1);
+ }
+
+ # &enabled and &fatal_enabled
+ return $results[0] unless $has_message;
+
+ # &warnif, and the category is neither enabled as warning nor as fatal
+ return if ($wanted & (NORMAL | FATAL | MESSAGE))
+ == (NORMAL | FATAL | MESSAGE)
+ && !($results[0] || $results[1]);
+
+ # If we have an explicit level, bypass Carp.
+ if ($has_level and @callers_bitmask) {
+ # logic copied from util.c:mess_sv
+ my $stuff = " at " . join " line ", (caller $i)[1,2];
+ $stuff .= sprintf ", <%s> %s %d",
+ *${^LAST_FH}{NAME},
+ ($/ eq "\n" ? "line" : "chunk"), $.
+ if $. && ${^LAST_FH};
+ die "$message$stuff.\n" if $results[0];
+ return warn "$message$stuff.\n";
+ }
+
+ require Carp;
+ Carp::croak($message) if $results[0];
+ # will always get here for &warn. will only get here for &warnif if the
+ # category is enabled
+ Carp::carp($message);
+}
+
+sub _mkMask
+{
+ my ($bit) = @_;
+ my $mask = "";
+
+ vec($mask, $bit, 1) = 1;
+ return $mask;
+}
+
+sub register_categories
+{
+ my @names = @_;
+
+ for my $name (@names) {
+ if (! defined $Bits{$name}) {
+ $Offsets{$name} = $LAST_BIT;
+ $Bits{$name} = _mkMask($LAST_BIT++);
+ $DeadBits{$name} = _mkMask($LAST_BIT++);
+ if (length($Bits{$name}) > length($Bits{all})) {
+ $Bits{all} .= "\x55";
+ $DeadBits{all} .= "\xaa";
+ }
+ }
+ }
+}
+
+sub _error_loc {
+ require Carp;
+ goto &Carp::short_error_loc; # don't introduce another stack frame
+}
+
+sub enabled
+{
+ return __chk(NORMAL, @_);
+}
+
+sub fatal_enabled
+{
+ return __chk(FATAL, @_);
+}
+
+sub warn
+{
+ return __chk(FATAL | MESSAGE, @_);
+}
+
+sub warnif
+{
+ return __chk(NORMAL | FATAL | MESSAGE, @_);
https://perl5.git.perl.org / perl5.git / blobdiff