diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-09-28 13:49:33 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-09-29 11:12:37 +0100 |
commit | f2d32da304293624412eaca03324da35a39c9f5e (patch) | |
tree | 0d40bcd4797bf7cf6fa8d4bc20204be9b9c90bf9 /ext | |
parent | 70361a71ff3810e2a1c0d257139ec1323e57ebfa (diff) | |
download | perl-f2d32da304293624412eaca03324da35a39c9f5e.tar.gz |
Move constant from ext/ to dist/
Diffstat (limited to 'ext')
-rw-r--r-- | ext/constant/lib/constant.pm | 392 | ||||
-rw-r--r-- | ext/constant/t/constant.t | 343 |
2 files changed, 0 insertions, 735 deletions
diff --git a/ext/constant/lib/constant.pm b/ext/constant/lib/constant.pm deleted file mode 100644 index a51ee7f277..0000000000 --- a/ext/constant/lib/constant.pm +++ /dev/null @@ -1,392 +0,0 @@ -package constant; -use 5.005; -use strict; -use warnings::register; - -use vars qw($VERSION %declared); -$VERSION = '1.19'; - -#======================================================================= - -# Some names are evil choices. -my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD }; -$keywords{UNITCHECK}++ if $] > 5.009; - -my %forced_into_main = map +($_, 1), - qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; - -my %forbidden = (%keywords, %forced_into_main); - -my $str_end = $] >= 5.006 ? "\\z" : "\\Z"; -my $normal_constant_name = qr/^_?[^\W_0-9]\w*$str_end/; -my $tolerable = qr/^[A-Za-z_]\w*$str_end/; -my $boolean = qr/^[01]?$str_end/; - -BEGIN { - # We'd like to do use constant _CAN_PCS => $] > 5.009002 - # but that's a bit tricky before we load the constant module :-) - # By doing this, we save 1 run time check for *every* call to import. - no strict 'refs'; - my $const = $] > 5.009002; - *_CAN_PCS = sub () {$const}; -} - -#======================================================================= -# import() - import symbols into user's namespace -# -# What we actually do is define a function in the caller's namespace -# which returns the value. The function we create will normally -# be inlined as a constant, thereby avoiding further sub calling -# overhead. -#======================================================================= -sub import { - my $class = shift; - return unless @_; # Ignore 'use constant;' - my $constants; - my $multiple = ref $_[0]; - my $pkg = caller; - my $flush_mro; - my $symtab; - - if (_CAN_PCS) { - no strict 'refs'; - $symtab = \%{$pkg . '::'}; - }; - - if ( $multiple ) { - if (ref $_[0] ne 'HASH') { - require Carp; - Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'"); - } - $constants = shift; - } else { - $constants->{+shift} = undef; - } - - foreach my $name ( keys %$constants ) { - unless (defined $name) { - require Carp; - Carp::croak("Can't use undef as constant name"); - } - - # Normal constant name - if ($name =~ $normal_constant_name and !$forbidden{$name}) { - # Everything is okay - - # Name forced into main, but we're not in main. Fatal. - } elsif ($forced_into_main{$name} and $pkg ne 'main') { - require Carp; - Carp::croak("Constant name '$name' is forced into main::"); - - # Starts with double underscore. Fatal. - } elsif ($name =~ /^__/) { - require Carp; - Carp::croak("Constant name '$name' begins with '__'"); - - # Maybe the name is tolerable - } elsif ($name =~ $tolerable) { - # Then we'll warn only if you've asked for warnings - if (warnings::enabled()) { - if ($keywords{$name}) { - warnings::warn("Constant name '$name' is a Perl keyword"); - } elsif ($forced_into_main{$name}) { - warnings::warn("Constant name '$name' is " . - "forced into package main::"); - } - } - - # Looks like a boolean - # use constant FRED == fred; - } elsif ($name =~ $boolean) { - require Carp; - if (@_) { - Carp::croak("Constant name '$name' is invalid"); - } else { - Carp::croak("Constant name looks like boolean value"); - } - - } else { - # Must have bad characters - require Carp; - Carp::croak("Constant name '$name' has invalid characters"); - } - - { - no strict 'refs'; - my $full_name = "${pkg}::$name"; - $declared{$full_name}++; - if ($multiple || @_ == 1) { - my $scalar = $multiple ? $constants->{$name} : $_[0]; - # The constant serves to optimise this entire block out on - # 5.8 and earlier. - if (_CAN_PCS && $symtab && !exists $symtab->{$name}) { - # No typeglob yet, so we can use a reference as space- - # efficient proxy for a constant subroutine - # The check in Perl_ck_rvconst knows that inlinable - # constants from cv_const_sv are read only. So we have to: - Internals::SvREADONLY($scalar, 1); - $symtab->{$name} = \$scalar; - ++$flush_mro; - } else { - *$full_name = sub () { $scalar }; - } - } elsif (@_) { - my @list = @_; - *$full_name = sub () { @list }; - } else { - *$full_name = sub () { }; - } - } - } - # Flush the cache exactly once if we make any direct symbol table changes. - mro::method_changed_in($pkg) if _CAN_PCS && $flush_mro; -} - -1; - -__END__ - -=head1 NAME - -constant - Perl pragma to declare constants - -=head1 SYNOPSIS - - use constant PI => 4 * atan2(1, 1); - use constant DEBUG => 0; - - print "Pi equals ", PI, "...\n" if DEBUG; - - use constant { - SEC => 0, - MIN => 1, - HOUR => 2, - MDAY => 3, - MON => 4, - YEAR => 5, - WDAY => 6, - YDAY => 7, - ISDST => 8, - }; - - use constant WEEKDAYS => qw( - Sunday Monday Tuesday Wednesday Thursday Friday Saturday - ); - - print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n"; - -=head1 DESCRIPTION - -This pragma allows you to declare constants at compile-time. - -When you declare a constant such as C<PI> using the method shown -above, each machine your script runs upon can have as many digits -of accuracy as it can use. Also, your program will be easier to -read, more likely to be maintained (and maintained correctly), and -far less likely to send a space probe to the wrong planet because -nobody noticed the one equation in which you wrote C<3.14195>. - -When a constant is used in an expression, Perl replaces it with its -value at compile time, and may then optimize the expression further. -In particular, any code in an C<if (CONSTANT)> block will be optimized -away if the constant is false. - -=head1 NOTES - -As with all C<use> directives, defining a constant happens at -compile time. Thus, it's probably not correct to put a constant -declaration inside of a conditional statement (like C<if ($foo) -{ use constant ... }>). - -Constants defined using this module cannot be interpolated into -strings like variables. However, concatenation works just fine: - - print "Pi equals PI...\n"; # WRONG: does not expand "PI" - print "Pi equals ".PI."...\n"; # right - -Even though a reference may be declared as a constant, the reference may -point to data which may be changed, as this code shows. - - use constant ARRAY => [ 1,2,3,4 ]; - print ARRAY->[1]; - ARRAY->[1] = " be changed"; - print ARRAY->[1]; - -Dereferencing constant references incorrectly (such as using an array -subscript on a constant hash reference, or vice versa) will be trapped at -compile time. - -Constants belong to the package they are defined in. To refer to a -constant defined in another package, specify the full package name, as -in C<Some::Package::CONSTANT>. Constants may be exported by modules, -and may also be called as either class or instance methods, that is, -as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where -C<$obj> is an instance of C<Some::Package>. Subclasses may define -their own constants to override those in their base class. - -The use of all caps for constant names is merely a convention, -although it is recommended in order to make constants stand out -and to help avoid collisions with other barewords, keywords, and -subroutine names. Constant names must begin with a letter or -underscore. Names beginning with a double underscore are reserved. Some -poor choices for names will generate warnings, if warnings are enabled at -compile time. - -=head2 List constants - -Constants may be lists of more (or less) than one value. A constant -with no values evaluates to C<undef> in scalar context. Note that -constants with more than one value do I<not> return their last value in -scalar context as one might expect. They currently return the number -of values, but B<this may change in the future>. Do not use constants -with multiple values in scalar context. - -B<NOTE:> This implies that the expression defining the value of a -constant is evaluated in list context. This may produce surprises: - - use constant TIMESTAMP => localtime; # WRONG! - use constant TIMESTAMP => scalar localtime; # right - -The first line above defines C<TIMESTAMP> as a 9-element list, as -returned by C<localtime()> in list context. To set it to the string -returned by C<localtime()> in scalar context, an explicit C<scalar> -keyword is required. - -List constants are lists, not arrays. To index or slice them, they -must be placed in parentheses. - - my @workdays = WEEKDAYS[1 .. 5]; # WRONG! - my @workdays = (WEEKDAYS)[1 .. 5]; # right - -=head2 Defining multiple constants at once - -Instead of writing multiple C<use constant> statements, you may define -multiple constants in a single statement by giving, instead of the -constant name, a reference to a hash where the keys are the names of -the constants to be defined. Obviously, all constants defined using -this method must have a single value. - - use constant { - FOO => "A single value", - BAR => "This", "won't", "work!", # Error! - }; - -This is a fundamental limitation of the way hashes are constructed in -Perl. The error messages produced when this happens will often be -quite cryptic -- in the worst case there may be none at all, and -you'll only later find that something is broken. - -When defining multiple constants, you cannot use the values of other -constants defined in the same declaration. This is because the -calling package doesn't know about any constant within that group -until I<after> the C<use> statement is finished. - - use constant { - BITMASK => 0xAFBAEBA8, - NEGMASK => ~BITMASK, # Error! - }; - -=head2 Magic constants - -Magical values and references can be made into constants at compile -time, allowing for way cool stuff like this. (These error numbers -aren't totally portable, alas.) - - use constant E2BIG => ($! = 7); - print E2BIG, "\n"; # something like "Arg list too long" - print 0+E2BIG, "\n"; # "7" - -You can't produce a tied constant by giving a tied scalar as the -value. References to tied variables, however, can be used as -constants without any problems. - -=head1 TECHNICAL NOTES - -In the current implementation, scalar constants are actually -inlinable subroutines. As of version 5.004 of Perl, the appropriate -scalar constant is inserted directly in place of some subroutine -calls, thereby saving the overhead of a subroutine call. See -L<perlsub/"Constant Functions"> for details about how and when this -happens. - -In the rare case in which you need to discover at run time whether a -particular constant has been declared via this module, you may use -this function to examine the hash C<%constant::declared>. If the given -constant name does not include a package name, the current package is -used. - - sub declared ($) { - use constant 1.01; # don't omit this! - my $name = shift; - $name =~ s/^::/main::/; - my $pkg = caller; - my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; - $constant::declared{$full_name}; - } - -=head1 CAVEATS - -In the current version of Perl, list constants are not inlined -and some symbols may be redefined without generating a warning. - -It is not possible to have a subroutine or a keyword with the same -name as a constant in the same package. This is probably a Good Thing. - -A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT -ENV INC SIG> is not allowed anywhere but in package C<main::>, for -technical reasons. - -Unlike constants in some languages, these cannot be overridden -on the command line or via environment variables. - -You can get into trouble if you use constants in a context which -automatically quotes barewords (as is true for any subroutine call). -For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will -be interpreted as a string. Use C<$hash{CONSTANT()}> or -C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from -kicking in. Similarly, since the C<< => >> operator quotes a bareword -immediately to its left, you have to say C<< CONSTANT() => 'value' >> -(or simply use a comma in place of the big arrow) instead of -C<< CONSTANT => 'value' >>. - -=head1 SEE ALSO - -L<Readonly> - Facility for creating read-only scalars, arrays, hashes. - -L<Const> - Facility for creating read-only variables. Similar to C<Readonly>, -but uses C<SvREADONLY> instead of C<tie>. - -L<Attribute::Constant> - Make read-only variables via attribute - -L<Scalar::Readonly> - Perl extension to the C<SvREADONLY> scalar flag - -L<Hash::Util> - A selection of general-utility hash subroutines (mostly -to lock/unlock keys and values) - -=head1 BUGS - -Please report any bugs or feature requests via the perlbug(1) utility. - -=head1 AUTHORS - -Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from -many other folks. - -Multiple constant declarations at once added by Casey West, -E<lt>F<casey@geeknest.com>E<gt>. - -Documentation mostly rewritten by Ilmari Karonen, -E<lt>F<perl@itz.pp.sci.fi>E<gt>. - -This program is maintained by the Perl 5 Porters. -The CPAN distribution is maintained by SE<eacute>bastien Aperghis-Tramoni -E<lt>F<sebastien@aperghis.net>E<gt>. - -=head1 COPYRIGHT & LICENSE - -Copyright (C) 1997, 1999 Tom Phoenix - -This module is free software; you can redistribute it or modify it -under the same terms as Perl itself. - -=cut diff --git a/ext/constant/t/constant.t b/ext/constant/t/constant.t deleted file mode 100644 index a42b7d2281..0000000000 --- a/ext/constant/t/constant.t +++ /dev/null @@ -1,343 +0,0 @@ -#!./perl -T - -use warnings; -use vars qw{ @warnings $fagwoosh $putt $kloong}; -BEGIN { # ...and save 'em for later - $SIG{'__WARN__'} = sub { push @warnings, @_ } -} -END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings } - - -use strict; -use Test::More tests => 95; -my $TB = Test::More->builder; - -BEGIN { use_ok('constant'); } - -use constant PI => 4 * atan2 1, 1; - -ok defined PI, 'basic scalar constant'; -is substr(PI, 0, 7), '3.14159', ' in substr()'; - -sub deg2rad { PI * $_[0] / 180 } - -my $ninety = deg2rad 90; - -cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression'; - -use constant UNDEF1 => undef; # the right way -use constant UNDEF2 => ; # the weird way -use constant 'UNDEF3' ; # the 'short' way -use constant EMPTY => ( ) ; # the right way for lists - -is UNDEF1, undef, 'right way to declare an undef'; -is UNDEF2, undef, ' weird way'; -is UNDEF3, undef, ' short way'; - -# XXX Why is this way different than the other ones? -my @undef = UNDEF1; -is @undef, 1; -is $undef[0], undef; - -@undef = UNDEF2; -is @undef, 0; -@undef = UNDEF3; -is @undef, 0; -@undef = EMPTY; -is @undef, 0; - -use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; -use constant COUNTLIST => reverse 1, 2, 3, 4, 5; -use constant COUNTLAST => (COUNTLIST)[-1]; - -is COUNTDOWN, '54321'; -my @cl = COUNTLIST; -is @cl, 5; -is COUNTDOWN, join '', @cl; -is COUNTLAST, 1; -is((COUNTLIST)[1], 4); - -use constant ABC => 'ABC'; -is "abc${\( ABC )}abc", "abcABCabc"; - -use constant DEF => 'D', 'E', chr ord 'F'; -is "d e f @{[ DEF ]} d e f", "d e f D E F d e f"; - -use constant SINGLE => "'"; -use constant DOUBLE => '"'; -use constant BACK => '\\'; -my $tt = BACK . SINGLE . DOUBLE ; -is $tt, q(\\'"); - -use constant MESS => q('"'\\"'"\\); -is MESS, q('"'\\"'"\\); -is length(MESS), 8; - -use constant LEADING => " \t1234"; -cmp_ok LEADING, '==', 1234; -is LEADING, " \t1234"; - -use constant ZERO1 => 0; -use constant ZERO2 => 0.0; -use constant ZERO3 => '0.0'; -is ZERO1, '0'; -is ZERO2, '0'; -is ZERO3, '0.0'; - -{ - package Other; - use constant PI => 3.141; -} - -cmp_ok(abs(PI - 3.1416), '<', 0.0001); -is Other::PI, 3.141; - -use constant E2BIG => $! = 7; -cmp_ok E2BIG, '==', 7; -# This is something like "Arg list too long", but the actual message -# text may vary, so we can't test much better than this. -cmp_ok length(E2BIG), '>', 6; - -is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings; -@warnings = (); # just in case -undef &PI; -ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or - diag join "\n", "unexpected warning", @warnings; -shift @warnings; - -is @warnings, 0, "unexpected warning"; - -my $curr_test = $TB->current_test; -use constant CSCALAR => \"ok 35\n"; -use constant CHASH => { foo => "ok 36\n" }; -use constant CARRAY => [ undef, "ok 37\n" ]; -use constant CCODE => sub { "ok $_[0]\n" }; - -my $output = $TB->output ; -print $output ${+CSCALAR}; -print $output CHASH->{foo}; -print $output CARRAY->[1]; -print $output CCODE->($curr_test+4); - -$TB->current_test($curr_test+4); - -eval q{ CCODE->{foo} }; -ok scalar($@ =~ /^Constant is not a HASH/); - - -# Allow leading underscore -use constant _PRIVATE => 47; -is _PRIVATE, 47; - -# Disallow doubled leading underscore -eval q{ - use constant __DISALLOWED => "Oops"; -}; -like $@, qr/begins with '__'/; - -# Check on declared() and %declared. This sub should be EXACTLY the -# same as the one quoted in the docs! -sub declared ($) { - use constant 1.01; # don't omit this! - my $name = shift; - $name =~ s/^::/main::/; - my $pkg = caller; - my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; - $constant::declared{$full_name}; -} - -ok declared 'PI'; -ok $constant::declared{'main::PI'}; - -ok !declared 'PIE'; -ok !$constant::declared{'main::PIE'}; - -{ - package Other; - use constant IN_OTHER_PACK => 42; - ::ok ::declared 'IN_OTHER_PACK'; - ::ok $constant::declared{'Other::IN_OTHER_PACK'}; - ::ok ::declared 'main::PI'; - ::ok $constant::declared{'main::PI'}; -} - -ok declared 'Other::IN_OTHER_PACK'; -ok $constant::declared{'Other::IN_OTHER_PACK'}; - -@warnings = (); -eval q{ - no warnings; - #local $^W if $] < 5.006; - use warnings 'constant'; - use constant 'BEGIN' => 1 ; - use constant 'INIT' => 1 ; - use constant 'CHECK' => 1 ; - use constant 'END' => 1 ; - use constant 'DESTROY' => 1 ; - use constant 'AUTOLOAD' => 1 ; - use constant 'STDIN' => 1 ; - use constant 'STDOUT' => 1 ; - use constant 'STDERR' => 1 ; - use constant 'ARGV' => 1 ; - use constant 'ARGVOUT' => 1 ; - use constant 'ENV' => 1 ; - use constant 'INC' => 1 ; - use constant 'SIG' => 1 ; - use constant 'UNITCHECK' => 1; -}; - -my @Expected_Warnings = - ( - qr/^Constant name 'BEGIN' is a Perl keyword at/, - qr/^Constant subroutine BEGIN redefined at/, - qr/^Constant name 'INIT' is a Perl keyword at/, - qr/^Constant name 'CHECK' is a Perl keyword at/, - qr/^Constant name 'END' is a Perl keyword at/, - qr/^Constant name 'DESTROY' is a Perl keyword at/, - qr/^Constant name 'AUTOLOAD' is a Perl keyword at/, - qr/^Constant name 'STDIN' is forced into package main:: a/, - qr/^Constant name 'STDOUT' is forced into package main:: at/, - qr/^Constant name 'STDERR' is forced into package main:: at/, - qr/^Constant name 'ARGV' is forced into package main:: at/, - qr/^Constant name 'ARGVOUT' is forced into package main:: at/, - qr/^Constant name 'ENV' is forced into package main:: at/, - qr/^Constant name 'INC' is forced into package main:: at/, - qr/^Constant name 'SIG' is forced into package main:: at/, - qr/^Constant name 'UNITCHECK' is a Perl keyword at/, -); - -unless ($] > 5.009) { - # Remove the UNITCHECK warning - pop @Expected_Warnings; - # But keep the count the same - push @Expected_Warnings, qr/^$/; - push @warnings, ""; -} - -# when run under "make test" -if (@warnings == 16) { - push @warnings, ""; - push @Expected_Warnings, qr/^$/; -} -# when run directly: perl -wT -Ilib t/constant.t -elsif (@warnings == 17) { - splice @Expected_Warnings, 1, 0, - qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/; -} -# when run directly under 5.6.2: perl -wT -Ilib t/constant.t -elsif (@warnings == 15) { - splice @Expected_Warnings, 1, 1; - push @warnings, "", ""; - push @Expected_Warnings, qr/^$/, qr/^$/; -} -else { - my $rule = " -" x 20; - diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n"; - diag map { " $_" } @warnings; - diag $rule, $/; -} - -is @warnings, 17; - -for my $idx (0..$#warnings) { - like $warnings[$idx], $Expected_Warnings[$idx]; -} - -@warnings = (); - - -use constant { - THREE => 3, - FAMILY => [ qw( John Jane Sally ) ], - AGES => { John => 33, Jane => 28, Sally => 3 }, - RFAM => [ [ qw( John Jane Sally ) ] ], - SPIT => sub { shift }, -}; - -is @{+FAMILY}, THREE; -is @{+FAMILY}, @{RFAM->[0]}; -is FAMILY->[2], RFAM->[0]->[2]; -is AGES->{FAMILY->[1]}, 28; -is THREE**3, SPIT->(@{+FAMILY}**3); - -# Allow name of digits/underscores only if it begins with underscore -{ - use warnings FATAL => 'constant'; - eval q{ - use constant _1_2_3 => 'allowed'; - }; - ok( $@ eq '' ); -} - -sub slotch (); - -{ - my @warnings; - local $SIG{'__WARN__'} = sub { push @warnings, @_ }; - eval 'use constant slotch => 3; 1' or die $@; - - is ("@warnings", "", "No warnings if a prototype exists"); - - my $value = eval 'slotch'; - is ($@, ''); - is ($value, 3); -} - -sub zit; - -{ - my @warnings; - local $SIG{'__WARN__'} = sub { push @warnings, @_ }; - eval 'use constant zit => 4; 1' or die $@; - - # empty prototypes are reported differently in different versions - my $no_proto = $] < 5.008004 ? "" : ": none"; - - is(scalar @warnings, 1, "1 warning"); - like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/, - "about the prototype mismatch"); - - my $value = eval 'zit'; - is ($@, ''); - is ($value, 4); -} - -$fagwoosh = 'geronimo'; -$putt = 'leutwein'; -$kloong = 'schlozhauer'; - -{ - my @warnings; - local $SIG{'__WARN__'} = sub { push @warnings, @_ }; - eval 'use constant fagwoosh => 5; 1' or die $@; - - is ("@warnings", "", "No warnings if the typeglob exists already"); - - my $value = eval 'fagwoosh'; - is ($@, ''); - is ($value, 5); - - my @value = eval 'fagwoosh'; - is ($@, ''); - is_deeply (\@value, [5]); - - eval 'use constant putt => 6, 7; 1' or die $@; - - is ("@warnings", "", "No warnings if the typeglob exists already"); - - @value = eval 'putt'; - is ($@, ''); - is_deeply (\@value, [6, 7]); - - eval 'use constant "klong"; 1' or die $@; - - is ("@warnings", "", "No warnings if the typeglob exists already"); - - $value = eval 'klong'; - is ($@, ''); - is ($value, undef); - - @value = eval 'klong'; - is ($@, ''); - is_deeply (\@value, []); -} |