lib/Perl/Tidy/IOScalar.pm

   1 #####################################################################
   2 #
   3 # This is a stripped down version of IO::Scalar
   4 # Given a reference to a scalar, it supplies either:
   5 # a getline method which reads lines (mode='r'), or
   6 # a print method which reads lines (mode='w')
   7 #
   8 #####################################################################
   9 package Perl::Tidy::IOScalar;
  10 use strict;
  11 use warnings;
  12 use Carp;
  13 our $VERSION = '20220613';
  14
  15 use constant EMPTY_STRING => q{};
  16
  17 sub AUTOLOAD {
  18
  19     # Catch any undefined sub calls so that we are sure to get
  20     # some diagnostic information.  This sub should never be called
  21     # except for a programming error.
  22     our $AUTOLOAD;
  23     return if ( $AUTOLOAD =~ /\bDESTROY$/ );
  24     my ( $pkg, $fname, $lno ) = caller();
  25     my $my_package = __PACKAGE__;
  26     print STDERR <<EOM;
  27 ======================================================================
  28 Error detected in package '$my_package', version $VERSION
  29 Received unexpected AUTOLOAD call for sub '$AUTOLOAD'
  30 Called from package: '$pkg'
  31 Called from File '$fname'  at line '$lno'
  32 This error is probably due to a recent programming change
  33 ======================================================================
  34 EOM
  35     exit 1;
  36 }
  37
  38 sub DESTROY {
  39
  40     # required to avoid call to AUTOLOAD in some versions of perl
  41 }
  42
  43 sub new {
  44     my ( $package, $rscalar, $mode ) = @_;
  45     my $ref = ref $rscalar;
  46     if ( $ref ne 'SCALAR' ) {
  47         confess <<EOM;
  48 ------------------------------------------------------------------------
  49 expecting ref to SCALAR but got ref to ($ref); trace follows:
  50 ------------------------------------------------------------------------
  51 EOM
  52
  53     }
  54     if ( $mode eq 'w' ) {
  55         ${$rscalar} = EMPTY_STRING;
  56         return bless [ $rscalar, $mode ], $package;
  57     }
  58     elsif ( $mode eq 'r' ) {
  59
  60         # Convert a scalar to an array.
  61         # This avoids looking for "\n" on each call to getline
  62         #
  63         # NOTES: The -1 count is needed to avoid loss of trailing blank lines
  64         # (which might be important in a DATA section).
  65         my @array;
  66         if ( $rscalar && ${$rscalar} ) {
  67
  68             #@array = map { $_ .= "\n" } split /\n/, ${$rscalar}, -1;
  69             @array = map { $_ . "\n" } split /\n/, ${$rscalar}, -1;
  70
  71             # remove possible extra blank line introduced with split
  72             if ( @array && $array[-1] eq "\n" ) { pop @array }
  73         }
  74         my $i_next = 0;
  75         return bless [ \@array, $mode, $i_next ], $package;
  76     }
  77     else {
  78         confess <<EOM;
  79 ------------------------------------------------------------------------
  80 expecting mode = 'r' or 'w' but got mode ($mode); trace follows:
  81 ------------------------------------------------------------------------
  82 EOM
  83     }
  84 }
  85
  86 sub getline {
  87     my $self = shift;
  88     my $mode = $self->[1];
  89     if ( $mode ne 'r' ) {
  90         confess <<EOM;
  91 ------------------------------------------------------------------------
  92 getline call requires mode = 'r' but mode = ($mode); trace follows:
  93 ------------------------------------------------------------------------
  94 EOM
  95     }
  96     my $i = $self->[2]++;
  97     return $self->[0]->[$i];
  98 }
  99
 100 sub print {
 101     my ( $self, $msg ) = @_;
 102     my $mode = $self->[1];
 103     if ( $mode ne 'w' ) {
 104         confess <<EOM;
 105 ------------------------------------------------------------------------
 106 print call requires mode = 'w' but mode = ($mode); trace follows:
 107 ------------------------------------------------------------------------
 108 EOM
 109     }
 110     ${ $self->[0] } .= $msg;
 111     return;
 112 }
 113 sub close { return }
 114 1;
 115