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