"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20210717/lib/Perl/Tidy/IOScalar.pm" (14 Jul 2021, 3504 Bytes) of package /linux/misc/Perl-Tidy-20210717.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "IOScalar.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 20210402_vs_20210717.

    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