| 1 | package Tie::Scalar; |
| 2 | |
| 3 | our $VERSION = '1.00'; |
| 4 | |
| 5 | =head1 NAME |
| 6 | |
| 7 | Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars |
| 8 | |
| 9 | =head1 SYNOPSIS |
| 10 | |
| 11 | package NewScalar; |
| 12 | require Tie::Scalar; |
| 13 | |
| 14 | @ISA = (Tie::Scalar); |
| 15 | |
| 16 | sub FETCH { ... } # Provide a needed method |
| 17 | sub TIESCALAR { ... } # Overrides inherited method |
| 18 | |
| 19 | |
| 20 | package NewStdScalar; |
| 21 | require Tie::Scalar; |
| 22 | |
| 23 | @ISA = (Tie::StdScalar); |
| 24 | |
| 25 | # All methods provided by default, so define only what needs be overridden |
| 26 | sub FETCH { ... } |
| 27 | |
| 28 | |
| 29 | package main; |
| 30 | |
| 31 | tie $new_scalar, 'NewScalar'; |
| 32 | tie $new_std_scalar, 'NewStdScalar'; |
| 33 | |
| 34 | =head1 DESCRIPTION |
| 35 | |
| 36 | This module provides some skeletal methods for scalar-tying classes. See |
| 37 | L<perltie> for a list of the functions required in tying a scalar to a |
| 38 | package. The basic B<Tie::Scalar> package provides a C<new> method, as well |
| 39 | as methods C<TIESCALAR>, C<FETCH> and C<STORE>. The B<Tie::StdScalar> |
| 40 | package provides all the methods specified in L<perltie>. It inherits from |
| 41 | B<Tie::Scalar> and causes scalars tied to it to behave exactly like the |
| 42 | built-in scalars, allowing for selective overloading of methods. The C<new> |
| 43 | method is provided as a means of grandfathering, for classes that forget to |
| 44 | provide their own C<TIESCALAR> method. |
| 45 | |
| 46 | For developers wishing to write their own tied-scalar classes, the methods |
| 47 | are summarized below. The L<perltie> section not only documents these, but |
| 48 | has sample code as well: |
| 49 | |
| 50 | =over 4 |
| 51 | |
| 52 | =item TIESCALAR classname, LIST |
| 53 | |
| 54 | The method invoked by the command C<tie $scalar, classname>. Associates a new |
| 55 | scalar instance with the specified class. C<LIST> would represent additional |
| 56 | arguments (along the lines of L<AnyDBM_File> and compatriots) needed to |
| 57 | complete the association. |
| 58 | |
| 59 | =item FETCH this |
| 60 | |
| 61 | Retrieve the value of the tied scalar referenced by I<this>. |
| 62 | |
| 63 | =item STORE this, value |
| 64 | |
| 65 | Store data I<value> in the tied scalar referenced by I<this>. |
| 66 | |
| 67 | =item DESTROY this |
| 68 | |
| 69 | Free the storage associated with the tied scalar referenced by I<this>. |
| 70 | This is rarely needed, as Perl manages its memory quite well. But the |
| 71 | option exists, should a class wish to perform specific actions upon the |
| 72 | destruction of an instance. |
| 73 | |
| 74 | =back |
| 75 | |
| 76 | =head1 MORE INFORMATION |
| 77 | |
| 78 | The L<perltie> section uses a good example of tying scalars by associating |
| 79 | process IDs with priority. |
| 80 | |
| 81 | =cut |
| 82 | |
| 83 | use Carp; |
| 84 | use warnings::register; |
| 85 | |
| 86 | sub new { |
| 87 | my $pkg = shift; |
| 88 | $pkg->TIESCALAR(@_); |
| 89 | } |
| 90 | |
| 91 | # "Grandfather" the new, a la Tie::Hash |
| 92 | |
| 93 | sub TIESCALAR { |
| 94 | my $pkg = shift; |
| 95 | if ($pkg->can('new') and $pkg ne __PACKAGE__) { |
| 96 | warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing"); |
| 97 | $pkg->new(@_); |
| 98 | } |
| 99 | else { |
| 100 | croak "$pkg doesn't define a TIESCALAR method"; |
| 101 | } |
| 102 | } |
| 103 | |
| 104 | sub FETCH { |
| 105 | my $pkg = ref $_[0]; |
| 106 | croak "$pkg doesn't define a FETCH method"; |
| 107 | } |
| 108 | |
| 109 | sub STORE { |
| 110 | my $pkg = ref $_[0]; |
| 111 | croak "$pkg doesn't define a STORE method"; |
| 112 | } |
| 113 | |
| 114 | # |
| 115 | # The Tie::StdScalar package provides scalars that behave exactly like |
| 116 | # Perl's built-in scalars. Good base to inherit from, if you're only going to |
| 117 | # tweak a small bit. |
| 118 | # |
| 119 | package Tie::StdScalar; |
| 120 | @ISA = (Tie::Scalar); |
| 121 | |
| 122 | sub TIESCALAR { |
| 123 | my $class = shift; |
| 124 | my $instance = shift || undef; |
| 125 | return bless \$instance => $class; |
| 126 | } |
| 127 | |
| 128 | sub FETCH { |
| 129 | return ${$_[0]}; |
| 130 | } |
| 131 | |
| 132 | sub STORE { |
| 133 | ${$_[0]} = $_[1]; |
| 134 | } |
| 135 | |
| 136 | sub DESTROY { |
| 137 | undef ${$_[0]}; |
| 138 | } |
| 139 | |
| 140 | 1; |