local-lib5/lib/perl5/Tie/ToObject.pm

   1 #!/usr/bin/perl
   2
   3 package Tie::ToObject;
   4
   5 use strict;
   6 #use warnings;
   7
   8 use vars qw($VERSION $AUTOLOAD);
   9
  10 use Carp qw(croak);
  11 use Scalar::Util qw(blessed);
  12
  13 $VERSION = "0.03";
  14
  15 sub AUTOLOAD {
  16         my ( $self, $tied ) = @_;
  17         my ( $method ) = ( $AUTOLOAD =~ /([^:]+)$/ );
  18
  19         if ( $method =~ /^TIE/ ) {
  20                 if ( blessed($tied) ) {
  21                         return $tied;
  22                 } else {
  23                         croak "You must supply an object as the argument to tie()";
  24                 }
  25         } else {
  26                 croak "Unsupported method for $method, this module is only for tying to existing objects";
  27         }
  28 }
  29
  30 __PACKAGE__
  31
  32 __END__
  33
  34 =pod
  35
  36 =head1 NAME
  37
  38 Tie::ToObject - Tie to an existing object.
  39
  40 =head1 SYNOPSIS
  41
  42         use Tie::ToObject;
  43
  44         my $stolen = tied(%something);
  45
  46         tie %something_else, 'Tie::ToObject', $stolen;
  47
  48 =head1 DESCRIPTION
  49
  50 While L<perldoc/tie> allows tying to an arbitrary object, the class in question
  51 must support this in it's implementation of C<TIEHASH>, C<TIEARRAY> or
  52 whatever.
  53
  54 This class provides a very tie constructor that simply returns the object it
  55 was given as it's first argument.
  56
  57 This way side effects of calling C<< $object->TIEHASH >> are avoided.
  58
  59 This is used in L<Data::Visitor> in order to tie a variable to an already
  60 existing object. This is also useful for cloning, when you want to clone the
  61 internal state object instead of going through the tie interface for that
  62 variable.
  63
  64 =head1 VERSION CONTROL
  65
  66 This module is maintained using Darcs. You can get the latest version from
  67 L<http://nothingmuch.woobling.org/code>, and use C<darcs send> to commit
  68 changes.
  69
  70 =head1 AUTHOR
  71
  72 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
  73
  74 =head1 COPYRIGHT
  75
  76         Copyright (c) 2008 Yuval Kogman. All rights reserved
  77         This program is free software; you can redistribute
  78         it and/or modify it under the same terms as Perl itself.
  79
  80 =cut