MMAgic/Output.pm

Go to the documentation of this file.

package MMAgic::Output;
#
# /MMAgic/Output.pm
#
#   Generalized indented output stream.
#
#   Provides formatting for output so generated files are readable.
#
#   It is possible to set up with both an output handle of some type
#   and a string.  The string will be used until flush() is called for
#   the first time, at which point the string will be sent to the handle
#   and further output will go to the handle directly.
#

# use   warnings;

use     Fcntl qw(:flock);
use     File::Basename;
use     Symbol;
use     UNIVERSAL qw(can isa);

sub SEEK_SET    { 0 }

###########################################################################
BEGIN
    {
    eval "require Win32::Pipe" if $windows = $^O eq 'MSWin32';
    }

###########################################################################
sub numberFor   # $path, $digits
#
    {
    my  $path = shift;
    my  $dgts = shift;
    my  $nbr  = 0;
    my  $err  = "file:\n      $path\n  in "
              . __PACKAGE__ . "::numberFor:\n   ";
    
    $path .= '.nbr';
    
    if (-e $path)
        {
        # Number file already exists:
        open NBR, "+<$path"
            or die "Unable to open $err $!";
        
        flock NBR, LOCK_EX
            or die "Unable to lock $err $!";
        
        $nbr = <NBR>;
        $nbr = int($nbr);
        $nbr = 0 if length(++$nbr) > $dgts;
        
        seek NBR, 0, SEEK_SET
            or die "Unable to reset $err $!";
        }
    
    else
        {
        # Need to create new file:
        open NBR, ">$path"
            or die "Unable to create $err $!";
        
        #   (could be a race condition the first time through,
        #    but once this exists it should be fairly stable)
        
        flock NBR, LOCK_EX
            or die "Unable to lock $err $!";
        }
    
    print NBR  $nbr, "\n";
    flock NBR, LOCK_UN;
    close NBR;
    
    $nbr
    }

###########################################################################
###########################################################################
sub new ($;%)   # $class, ...
#
    {
    my ($class, %parms) = @_;
    my  $self =
        {
        indent  => 0,
        indents => [],
        blankLn => 1,
        newLn   => 1,
        };
    
    # Loop until one of the parameters sets up a good handle
    #   or until the code breaks out of the loop:
    
    while (! $self->{handle})
        {
        if (defined $parms{string})
            {
            $self->{useStr} = 1;
            $self->{string} = $parms{string};
            delete $parms{string};      # only try once
            # but also allows us to keep looking for a handle
            #   in subsequent loops
            }

        elsif (my $pathname = $parms{pathname})
            {
            delete $parms{pathname};    # only try once
            
            my ($name, $path, $suffix) = fileparse($pathname, qr/\.[^\.]*/);
            
            if ($parms{backup})
                {
                # If file exists, rename to backup,
                #   destroying old backup as necessary.
                #   Specify suffix as parm, or use integer
                #   to get default backup suffix ('.bak').
                my  $backup  = $parms{backup};
                
                $backup   = '.bak'     if     int($backup);
                $backup   = ".$backup" unless $backup =~ /^\./;
                $suffix   = '.log'     unless $suffix;
                $pathname = "$path$name$suffix";
                $backup   = "$path$name$backup";
                
                unlink $backup            if -e $backup;
                rename $pathname, $backup if -e $pathname;
                #   (this will only work properly if used in
                #    a single-threaded/single-process context)
                }
            
            elsif ($parms{number})
                {
                # Create unique numbered suffixes for file:
                my  $digits = int($parms{number});
                my  $number = numberFor($pathname = "$path$name", $digits);
                
                $pathname .= '.';
                $pathname .= '0' x ($digits - length($number));
                $pathname .= $number;
                }
            
            else
                {
                $pathname = "$path$name$suffix"
                }
            
            # Twisted, read carefully:
            if    (-e $pathname && ! -w $pathname)
                {
                print STDERR
                    ("Output path $path exists and is not writable");
                }
                
            elsif (! ($self->{handle} = gensym))
                {
                print STDERR
                    ("Unable to use gensym() to create file handle\n  ", $!);
                }
                
            elsif (! open($self->{handle}, ">$pathname"))
                {
                # failed, cleanup:
                print STDERR
                    ("Unable to write to file\n    ", $pathname, "\n  ", $!);
                
                delete $self->{handle};
                }
            
            else
                {
                $self->{pathname} = $pathname;
                last;                   # done
                }
            }

        elsif (my $pipe = $parms{nmpipe})
            {
            my  $name = $parms{nmpipe};
            
            delete $parms{nmpipe};      # only try once
            
            next unless $windows;       # don't have UNIX code yet
            last                        # done
                # Not working now???(04/16/01)???
                # How to make this also work on UNIX???
                if $self->{nmpipe} =
                    new Win32::Pipe("\\\\.\\pipe\\$name");
            }
        
        elsif ($parms{handle})
            {
            $self->{handle} = $parms{handle};
            delete $parms{handle}       # only try once
            }
        
        elsif ($self->{useStr})
            {
            # We apparently just have a string defined,
            #   so bomb out because we'll never have a handle:
            last
            }
        
        else
            {
            # Nothing else has worked, so just do something and quit:
            $self->{handle} = $parms{output} || \*STDOUT;
            
            if (defined($parms{flush}) && $parms{flush} eq 'auto')
                {
                # Set auto-flush:
                my  $old = select($self->{handle});
                
                $| = 1;
                select($old);
                }
            }
        };

    return bless $self, $class;
    }

###########################################################################
###########################################################################
sub bypass  # $self
# Return a new output stream that bypasses any string buffering.
#   If no string buffering, return this object.
#
    {
    my  $self = shift;
    
    return $self
        unless $self->{useStr};
    
    return new MMAgic::Output(handle => $self->{handle})
        if $self->{handle};
    
    # Don't have code for pipes yet:
    $self
    }

###########################################################################
sub clear   # $self
# Clear any pending buffered output data.
#
    {
    my  $self = shift;
    
    delete $self->{string}
        if defined $self->{string}
        && length  $self->{string};
    }

###########################################################################
sub close   # $self
# Flush pending output and close stream.
#   Only close handle if it was opened from a pathname,
#   otherwise the handle was passed in already open
#   and it is someone else's responsibility to close it.
#
    {
    my  $self = shift;
    
    $self->flush;
    
    if ($self->{pathname})
        {
        close  $self->{handle};
        delete $self->{handle};
        delete $self->{pathname};
        }
    
    delete $self->{handle} if defined $self->{handle};
    delete $self->{nmpipe} if defined $self->{nmpipe};
    delete $self->{string} if defined $self->{string};
    }

###########################################################################
sub default     # $self
# Return true if default output was used.
#
        {
        $_[0]->{handle} == \*STDOUT ? 'STDOUT' :
        $_[0]->{handle} == \*STDERR ? 'STDERR' : undef
        }

###########################################################################
sub flush   # $self
# Flush pending output.
#   Perl doesn't directly support any flushing functionality,
#   it makes do with autoflush, but we have string buffering to flush:
#
    {
    my  $self = shift;

    if ($self->{useStr})
        {
        # After this data will go directly to the output handle or pipe:
        delete $self->{useStr};

        # Process any existing string data:
        $self->process($self->{string})
            if defined $self->{string}
            && length  $self->{string};

        # OK, we can jettison this now:
        delete $self->{string};
        }
    }

###########################################################################
sub process # $self, @list
# Print or store the specified items.
#
    {
    my  $self = shift;

#   lock($self);

    # Look for string first to handle buffering cases:
    
    if ($self->{useStr})
        {
        $self->{string} .= join '', @_;
        }
    
    elsif (ref($self->{nmpipe}) eq 'Win32::Pipe')
        {
        $self->{nmpipe}->Write(@_);
        }
    
    elsif ($self->{handle})
        {
        CORE::print ${$self->{handle}} (@_);
        }
    
    return $self;
    }

###########################################################################
sub string  # $self, $clear
# Return the string storage for internal buffer streams.
#
    {
    my  $self = shift;
    my  $str  = $self->{string};
    
    $self->{string} = ''
        if shift() && $self->{string};

    $str
    }

###########################################################################
###########################################################################
sub indent          # $self
# Generate beginning-of-line sequence.
#  Can assume beginning of line, use to add markers.
#
    {
    my  $self = shift;
    
    return $self unless $self->{indent};
    
    $self->process(' ' x $self->{indent});
    }
    
###########################################################################
sub clearIndent ($)
# Push "no" indent onto stack:
#
    {
    my $self = shift;

    push @{$self{indents}}, $self->{indent};
    $self->{indent} = 0;
    
    return $self;
    }

###########################################################################
sub pushIndent ($;$)
# Push indentation level.
#
    {
    my $self = shift;
    my $incr = shift || 2;
    
#   lock($self);

    push @{$self{indents}}, $self->{indent};
    $self->{indent} += $incr;

    return $self;
    }

###########################################################################
sub pushLine ($$;$) #   $self, $open, $incr
# Push indentation level, print open sequence, then newline.
#
    {
    my $self = shift;
    my $open = shift;
    my $incr = shift || 2;
    
    $self->pushIndent($incr);
    $self->print($open) if $open;
    
    return $self->newLine(1);   # don't want blank lines after pushLine
    }

###########################################################################
sub popIndent ($)   # $self
# Pop indentation level.
#
    {
    my $self = shift;
    
#   lock($self);

    $self->{indent} = pop @{$self{indents}};

    return $self;
    }

###########################################################################
sub popLine ($$$)   # $self, $close, $comma
# Print close sequence, pop indentation level, then newline.
#
    {
    my ($self, $close, $comma) = @_;
    
    $self->print($close) if $close;
    $self->print($comma) if $comma;

    return $self->newLine()->popIndent();
    }

###########################################################################
sub starter         # $self
# Provide tag at beginning of line.
#
    {
    # This version does nothing.
    return shift;
    }

###########################################################################
###########################################################################
sub blankLine ($)   # $self
# Ensure that the next output will be after a blank line.
#
    {
    my $self = shift;
    
#   lock($self);

    $self->newLine;

    unless ($self->{"blankLn"})
        {
        $self->process("\n");
        $self->{blankLn} = 1;
        }

    return $self;
    }

###########################################################################
sub newLine ($$)    # $self, $noBlank
# Ensure that the next output will be on a new line.
#
    {
    my $self = shift;
    
#   lock($self);

    unless ($self->{newLn})
        {
        $self->process("\n");
        $self->{newLn}   = 1;
        $self->{blankLn} = 1 if shift;
        }

    return $self;
    }

###########################################################################
sub print ($@)      # $self, ...
# Print to file handle associated with output object.
#
    {
    my $self = shift;
    
#   lock($self);

    map {
        my  $arg = $_;  # using foreach would alias $arg to actual arguments,
                        #   making it impossible to reassign below
        
        # Individual arguments (as opposed to interpolations) are checked and
        #   handled specially if appropriate, which is really good for using
        #   this class for tracing and so forth:

        if (! defined($arg))
            {
#           print STDERR "{UNDEF}\n";
            $arg = '{undef}';
            }
        
        elsif (isa($arg, 'Win32::OLE'))
            {
            $arg = sprintf "{OLE %s %s}", Win32::OLE->QueryObjectType($arg);
            }
        
        elsif (can($arg, 'image'))
            {
            $arg = $arg->image;
            }
        
        #  (note that things embedded within double-quotes will still
        #   have been interpreted in a more normal manner)
        
        for my $item (split /(\n)/, $arg)
            {
            if ($item eq "\n")
                {
                $self->{blankLn} = 1 if $self->{newLn};
                $self->{newLn  } = 1;
                }

            else
                {
                $self->starter->indent
                    if $self->{newLn};
                    
                $self->{blankLn} = 0;
                $self->{newLn  } = 0;
                }

            $self->process($item);
            }
        } @_;

    $self
    }

###########################################################################
sub printf ($$;@)   # $self, $format, ...
# Print to file handle associated with TriState object.
#
    {
    my $self = shift;
    my $form = shift;

    $self->process(sprintf($form, @_));

    return $self;
    }

###########################################################################
sub display     # $self, $item, %param
    {
    my ($self, $item, %param) = @_;
    my  $depth  = $param{depth}    ||  0;
    my  $maxDep = $param{maxDepth} ||  3;
    my  $prefix = $param{prefix}   || '';
    
    $item = ${$item}
        if   isa($item, 'SCALAR')
        && ! isa($item, 'Regexp');
    
    if (! defined $item)
        {
        $self->print($prefix, '<undef>')->newLine;
        }
    
    elsif (isa($item, 'ARRAY'))
        {
        $prefix = '###'
            unless $prefix;
        
        $prefix .= ' ' . ref $item
            unless 'ARRAY' eq ref $item;
        
        $self->newLine()->print($prefix)->newLine;
        $self->pushLine('[');
        
        for my $item (@$item)
            {
            if ($depth < $maxDep)
                {
                $self->display
                    ($item,
                     depth    => $depth + 1,
                     maxDepth => $maxDep);
                }
            
            else
                {
                $self->print($item, ',')->newLine;
                }
            }

        $self->popLine('],');
        }
    
    elsif (isa($item, 'HASH'))
        {
        $prefix = '###'
            unless $prefix;
        
        $prefix .= ' ' . ref $item
            unless 'HASH' eq ref $item;
        
        $self->newLine();
        
        if (ref($item) eq 'HASH')
            {
            $self->print($prefix);
            }
        
        else
            {
            $self->print($prefix) if $prefix;
            $self->print('# ', ref($item));
            }
        
        $self->newLine()->pushLine('{');

        for my $key (keys %$item)
            {
            my  $keyPrefix = $key =~ /^[^A-Za-z]/ ||
                             $key =~ /[^A-Za-z0-9_\-]/
                           ? "'$key' => "
                           : "$key => ";
            
            if ($depth < $maxDep)
                {
                $self->display
                    ($item->{$key},
                     prefix   => $keyPrefix,
                     depth    => $depth + 1,
                     maxDepth => $maxDep);
                }
            
            else
                {
                $self->print($keyPrefix, $item, ',')->newLine;
                }
            }

        $self->popLine('},');
        }
    
    elsif (isa($item, 'Regexp'))
        {
        # Found a regular expression:
        my  $pattern = undef;
        
        $pattern = $1 if $item =~ m|\(\?-xism:(.*)\)$|;
        $pattern = "$item" unless $pattern;
        
        $self->print($prefix, '/', $pattern, '/,')->newLine;
        }
    
    elsif (ref($item) || $item =~ /^\d*.?\d+$/)
        {
        # Found a number or an object:
        $self->print($prefix, $item, ',')->newLine;
        }
    
    elsif ($item =~ /\n./)
        {
        # Split long text into multiple lines:
        $self->print($prefix, '<<TEXT,')
             ->clearIndent->newLine;
        
        map {
            $self->print($_)->newLine;
            } split(/\n/, $item);
        
        $self->print('TEXT')
             ->popIndent->newLine;
        }
    
    else
        {
        # Treat it as a string:
        $self->print($prefix, "'", $item, "',")->newLine;
        }
    }

###########################################################################
###########################################################################
my  $deprecated;

sub dumpref     # $self, $target, %param
#
    {
    my ($self, $target, %param) = @_;
    my  $depth  = $param{depth}    ||  0;
    my  $maxDep = $param{maxDepth} ||  3;
    my  $prefix = $param{prefix}   || '';
    
    $self->warning(__PACKAGE__, '::dumpref() deprecated in favor of ',
                   __PACKAGE__, '::display()')
        unless $deprecated++;
    
    $target = ${$target}
        if   isa($target, 'SCALAR')
        && ! isa($target, 'Regexp');
    
    if (isa($target, 'ARRAY'))
        {
        $self->newLine()->print($prefix ? $prefix : '###')->newLine;
        $self->pushLine('[');
        
        for my $item (@$target)
            {
            if ($depth < $maxDep)
                {
                $self->dumpref
                    ($item,
                     depth    => $depth + 1,
                     maxDepth => $maxDep);
                }
            
            else
                {
                $self->print($item, ',')->newLine;
                }
            }

        $self->popLine('],');
        }
    
    elsif (isa($target, 'HASH'))
        {
        $self->newLine();
        
        if (ref($target) eq 'HASH')
            {
            $self->print($prefix ? $prefix : '###');
            }
        
        else
            {
            $self->print($prefix) if $prefix;
            $self->print('# ', ref($target));
            }
        
        $self->newLine()->pushLine('{');

        for my $key (keys %$target)
            {
            my  $keyPrefix = $key =~ /^[^A-Za-z]/ ||
                             $key =~ /[^A-Za-z0-9_\-]/
                           ? "'$key' => "
                           : "$key => ";
            
            if ($depth < $maxDep)
                {
                $self->dumpref
                    ($target->{$key},
                     prefix   => $keyPrefix,
                     depth    => $depth + 1,
                     maxDepth => $maxDep);
                }
            
            else
                {
                $self->print($keyPrefix, $target, ',')->newLine;
                }
            }

        $self->popLine('},');
        }
    
    elsif (isa($target, 'Regexp'))
        {
        # Found a regular expression:
        my  $pattern = undef;
        
        $pattern = $1 if $target =~ m|\(\?-xism:(.*)\)$|;
        $pattern = "$target" unless $pattern;
        
        $self->print($prefix, '/', $pattern, '/,')->newLine;
        }
    
    elsif (ref($target) || $target =~ /^\d*.?\d+$/)
        {
        # Found a number or an object:
        $self->print($prefix, $target, ',')->newLine;
        }
    
    elsif ($target =~ /\n./)
        {
        # Split long text into multiple lines:
        $self->print($prefix, '<<TEXT,')
             ->clearIndent->newLine;
        
        map {
            $self->print($_)->newLine;
            } split(/\n/, $target);
        
        $self->print('TEXT')
             ->popIndent->newLine;
        
#       my  @lines = split(/\n/, $target);
#       
#       $self->dumpref
#           (\@lines,
#            prefix   => $prefix,
#            depth    => $depth + 1,
#            maxDepth => $maxDep);
        }
    
    elsif (defined $target)
        {
        # Treat it as a string:
        $self->print($prefix, "'", $target, "',")->newLine;
        }
    }

###########################################################################
###########################################################################
sub TIEHANDLE   # $classname, @list
#
    {
    my  $clss = shift;
    
    $clss->new(@_)
    }

###########################################################################
sub WRITE       # $self, @list
#
    {
    print STDERR "WRITE not implemented by ", __PACKAGE__, "\n";
    }

###########################################################################
sub PRINT       # $self, @list
#
    {
    my  $self = shift;
    
    $self->print(@_)
    }

###########################################################################
sub PRINTF      # $self, $fmt, @list
#
    {
    my  $self = shift;
    
    $self->printf(@_)
    }

###########################################################################
sub CLOSE       # $self
#
    {
    $_[0]->close;
    }

###########################################################################
sub DESTROY     # $self
#
    {
    $_[0]->close;
    }

###########################################################################
sub UNTIE       # $self
#
    {
    $_[0]->close;
    }

1