package ex::constant::vars;
$ex::constant::vars::VERSION = '0.07';
use 5.006;
use strict;
use warnings;
use Carp;

require Exporter;

our @ISA        = qw(
                      Exporter
                      ex::constant::vars::scalar
                      ex::constant::vars::array
                      ex::constant::vars::hash
                    );
our @EXPORT_OK  = qw( const SCALAR ARRAY HASH );

sub const {
  my $type   = shift;
  my @values = splice @_, 1;
  if ( $type eq 'scalar' ) {
    return tie ${$_[0]}, __PACKAGE__ . '::' . $type, @values;
  } elsif ( $type eq 'array' ) {
    return tie @{$_[0]}, __PACKAGE__ . '::' . $type, @values;
  } else {
    return tie %{$_[0]}, __PACKAGE__ . '::' . $type, @values;
  }
}

sub SCALAR (\$$) { 'scalar', @_ }
sub ARRAY  (\@@) { 'array',  @_ }
sub HASH   (\%%) { 'hash',   @_ }

sub import {
  my $self = shift;
  return unless @_;
  if ( @_ == 1 && $_[0] eq 'const' ) {
    $self->export_to_level( 1, $self, @EXPORT_OK );
  } else {
    my %variables = @_;
    my $caller    = caller( 0 );
    while ( my( $var, $val ) = each %variables ) {
      my( $prefix, $name ) = split //, $var, 2;
      croak "'$var' not a valid variable name" unless $prefix =~ /^[\$\@\%]$/;
      if ( $prefix eq '$' ) {
        no strict 'refs';
        *{__PACKAGE__ . "::variables::$name"} = \$val;
        *{"${caller}::$name"} = \${__PACKAGE__ . "::variables::$name"};
        const SCALAR ${"${caller}::$name"}, $val;
      } elsif ( $prefix eq '@' ) {
        no strict 'refs';
        *{__PACKAGE__ . "::variables::$name"} = \@{$val};
        *{"${caller}::$name"} = \@{__PACKAGE__ . "::variables::$name"};
        const ARRAY @{"${caller}::$name"}, @{$val};
      } elsif ( $prefix eq '%' ) {
        no strict 'refs';
        *{__PACKAGE__ . "::variables::$name"} = \%{$val};
        *{"${caller}::$name"} = \%{__PACKAGE__ . "::variables::$name"};
        const HASH %{"${caller}::$name"}, %{$val};
      }
    }
  }
}


package ex::constant::vars::scalar;
$ex::constant::vars::scalar::VERSION = '0.07';
use Carp;
$Carp::CarpLevel = 1;
sub TIESCALAR { shift; bless \(my $scalar = shift), __PACKAGE__ }
sub FETCH     { ${$_[0]} }
sub STORE     { croak "Modification of a read-only value attempted" }


package ex::constant::vars::array;
$ex::constant::vars::array::VERSION = '0.07';
use Carp;
$Carp::CarpLevel = 1;
sub TIEARRAY  { shift; bless $_=\@_, __PACKAGE__ }
sub FETCH     { $_[0]->[$_[1]] }
sub FETCHSIZE { @{$_[0]} }
sub EXISTS    { exists $_[0]->[$_[1]] }
sub STORE     { croak "Modification of a read-only value attempted" }
*CLEAR   = *EXTEND = *POP       = *PUSH   = *SHIFT =
*UNSHIFT = *SPLICE = *STORESIZE = *DELETE = \*STORE;


package ex::constant::vars::hash;
$ex::constant::vars::hash::VERSION = '0.07';
use Carp;
$Carp::CarpLevel = 1;
sub TIEHASH  { bless {@_[1...$#_]}, __PACKAGE__ }
sub FETCH    { $_[0]->{$_[1]} }
sub FIRSTKEY { keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY  { each %{$_[0]} }
sub EXISTS   { exists $_[0]->{$_[1]} }
sub STORE    { croak "Modification of a read-only value attempted" }
*CLEAR = *DELETE = \*STORE;

1;

__END__

=head1 NAME

ex::constant::vars - create readonly variables (alternative to constant pragma)

=head1 SYNOPSIS

Using the C<tie()> interface:

  use ex::constant::vars;
  tie my $pi,     'ex::constant::vars', 4 * atan2( 1, 1 );
  tie my @family, 'ex::constant::vars', qw( John Jane );
  tie my %age,    'ex::constant::vars', John => 27,
                                        Jane => 'Back off!';

Using the C<const()> function:

  use ex::constant::vars 'const';
  const SCALAR my $pi,     4 * atan2( 1, 1 );
  const ARRAY  my @family, qw( John Jane );
  const HASH   my %age,    John => 27, Jane => 'Back off!';

Using C<import()> for compile time creation:

  use ex::constant::vars (
    '$pi'     => 4 * atan2( 1, 1 ),
    '@family' => [ qw( John Jane ) ],
    '%age'    => { John => 27, Jane => 'Back off!' },
  );

=head1 DESCRIPTION

This package allows you to create readonly variables.
Unlike the C<constant> pragma,
this module lets you create readonly scalars, arrays and hashes.

The L<Const::Fast> module is a much better solution for
immutable variables.

This module C<tie()>s variables to a class
that disables any attempt to modify a variable's data.

=over 4

=item Scalar

You cannot change the value in any way: not only assignment,
but functions such as chomp and chop will fail.

=item Array

You cannot add to the array (unshift, push), remove from the array (shift, pop),
nor change any values in the array.

=item Hash

You cannot change items in the hash, add new items to it, nor delete a key.

=back

=head2 The C<const()> function

When the C<const()> function is imported,
so are the helper functions C<SCALAR()>, C<ARRAY()>, and C<HASH()>.
These functions let C<const()> know what type of variable it's dealing with.
C<const()> returns the C<tied()> object of the variable.

=head1 Caveats

This implementation can be slow, by nature.
C<tie()>ing variables to a class is going to be slow.
If you need the same functionality, and much less of a speed hit, take a look at this:
L<http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-05/msg00777.html>

The fastest method of declaring readonly variables with this pakcage
is to C<tie()> your variables.  After that, using the C<const()>
function.  And lastly, using C<import()> at compile time.

To demonstrate the speed differences:

  use Benchmark; 
  timethese 500000, {
    constvars => sub {
                      tie my $x, 'ex::constant::vars', 'test';
                      my $y = $x;
                     },
    standard  => sub {
                      my $x = 'test';
                      my $y = $x;
                     },
  };

Produces:

 constvars: 24 wallclock secs (22.55 usr +  0.05 sys = 22.60 CPU) @ 22123.89/s (n=500000)
  standard:  2 wallclock secs ( 1.12 usr +  0.00 sys =  1.12 CPU) @ 447761.19/s (n=500000)

=head1 REPOSITORY

L<https://github.com/neilb/ex-constant-vars>

=head1 AUTHOR

This module was written by Casey R. Tweten.

It's now in maintence mode.

=head1 SEE ALSO

For immutable variables you should use L<Const::Fast>.

=head1 COPYRIGHT

Copyright (c) 1995-2000 Casey R. Tweten. All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut