1#!/usr/bin/perl 2 3use strict; 4use warnings; 5use Fatal qw(open read); 6use Symbol; 7use Data::Dumper; 8use Scalar::Util; 9use IO::File; 10use English qw( -no_match_vars ); 11use Carp; 12 13## no critic (Miscellanea::ProhibitTies) 14 15package MyTiedFileHandle; 16 17use English qw( -no_match_vars ); 18use Carp; 19 20my $leaky_file_handle; 21 22sub TIEHANDLE { 23 my ($class) = @_; 24 my $i; 25 my $tied_object = bless \$i, $class; 26 $leaky_file_handle = $tied_object; 27 return $tied_object; 28} ## end sub TIEHANDLE 29 30sub PRINT { 31 my ( $r, @rest ) = @_; 32 ${$r}++; 33 print join( $OFS, map { uc $_ } @rest ), $ORS 34 or Carp::croak("Cannot print to STDOUT: $ERRNO"); 35 return; 36} ## end sub PRINT 37 38## no critic (Subroutines::RequireArgUnpacking) 39sub READ { 40 my $bufref = \$_[1]; 41 42## use critic 43## no critic (Miscellanea::ProhibitTies) 44 45 my ( $self, undef, $len, $offset ) = @_; 46 defined $offset or $offset = 0; 47 ${$bufref} .= 'a'; 48 return 1; 49} ## end sub READ 50 51package MyTie; 52 53my $leaky; 54 55sub TIESCALAR { 56 my ($class) = @_; 57 my $tobj = bless {}, $class; 58 $leaky = $tobj; 59 return $tobj; 60} ## end sub TIESCALAR 61 62sub TIEHASH { 63 goto \&TIESCALAR; 64} 65 66sub FIRSTKEY { 67 return; # no keys 68} 69 70sub TIEARRAY { 71 goto \&TIESCALAR; 72} 73 74sub FETCH {return} 75 76sub FETCHSIZE { 77 return 0; # no array elements 78} 79 80sub TIEHANDLE { 81 goto \&TIESCALAR; 82} 83 84package main; 85 86my $scalar = 42; 87my $scalar_ref = \$scalar; 88my $ref_ref = \$scalar_ref; 89my $regexp_ref = qr/./xms; 90 91## no critic (Subroutines::ProhibitCallsToUndeclaredSubs) 92my $vstring = v1.2.3.4; 93## use critic 94my $vstring_ref = \$vstring; 95 96our $GLOB_HANDLE_NAME; 97our $IO_HANDLE_NAME; 98our $AUTOVIV_HANDLE_NAME; 99our $FH_HANDLE_NAME; 100 101my $glob_ref = *GLOB_HANDLE_NAME{'GLOB'}; 102my $io_ref = *IO_HANDLE_NAME{'IO'}; 103my $fh_ref = do { 104 no warnings qw(deprecated); 105 *FH_HANDLE_NAME{'FILEHANDLE'}; 106}; 107 108## no critic (InputOutput::RequireBriefOpen) 109open my $autoviv_ref, q{<}, '/dev/null'; 110## use critic 111 112my $string = 'abc' x 40; 113my $lvalue_ref = \( pos $string ); 114${$lvalue_ref} = 7; 115 116my %data = ( 117 'scalar' => $scalar_ref, 118 'ref' => $ref_ref, 119 'regexp' => $regexp_ref, 120 'vstring' => $vstring_ref, 121 'lvalue' => $lvalue_ref, 122 'glob' => $glob_ref, 123 'autoviv' => $autoviv_ref, 124); 125 126my %star_deref = map { ( $_, 1 ) } qw(glob autoviv); 127 128REF: 129while ( my ( $name, $ref ) = each %data ) { 130 print "$name: ", ( ref $ref ), q{,}, ( Scalar::Util::reftype $ref), q{: } 131 or Carp::croak("Cannot print to STDOUT: $ERRNO"); 132 my $return; 133 if ( $star_deref{$name} ) { 134 ## no critic (Miscellanea::ProhibitTies) 135 $return = eval { tie *{$ref}, 'MyTiedFileHandle'; 1 }; 136 ## use critic 137 } 138 else { 139 ## no critic (Miscellanea::ProhibitTies) 140 $return = eval { tie ${$ref}, 'MyTie'; 1 }; 141 ## use critic 142 } 143 print $return ? "ok\n" : "tie failed: $EVAL_ERROR" 144 or Carp::croak("Cannot print to STDOUT: $ERRNO"); 145 my $underlying = q{}; 146 if ( $star_deref{$name} ) { 147 $underlying = tied *{$ref}; 148 } 149 else { 150 $underlying = tied ${$ref}; 151 } 152 print Data::Dumper->Dump( [$underlying], ['underlying'] ) 153 or Carp::croak("Cannot print to STDOUT: $ERRNO"); 154} ## end while ( my ( $name, $ref ) = each %data ) 155 156exit 0; 157