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