Subversion Repositories DevTools

#! perl
########################################################################
# Copyright ( C ) 2004-2010 ERG Limited, All rights reserved
#
# Module name   : jats.sh
# Module type   : Jats Perl Module
# Environment(s): jats
#
# Description:  Class to simply the process of creating and writing
#               a new configuration file
#
#               Used to create files used by JATS in the build process
#
# Usage:       $fh = ConfigurationFile::New( 'SomeName' );
#              $fh->HeaderSimple();
#              $fh->Header();
#              $fh->Write();
#              $fh->WriteLn();
#              $fh->Comment()
#              $fh->Dump()
#              $fh->DumpData()
#              $fh->Close();
#               
#......................................................................#

require 5.006_001;
use strict;
use warnings;

################################################################################
#
#   Package to manage the creation of configuration files
#
#
package ConfigurationFile;

#-------------------------------------------------------------------------------
# Function        : ConfigurationFile::New
#
# Description     : Create and open a configuration file
#
# Inputs          : $name   - Name of the file to create.
#                   @opts   - List of options
#                               --NoEof     - Supress EOF at the end of the file
#                               --Type=xxx  - Control the comment markers
#                               --NoTime    - Supress the time stamp
#
# Returns         : Package handle
#
sub New
{
    my ($name, @opts) = @_;

    #
    #   Package variables
    #
    my ($self) = {
            FH          => *CONFIG,                 # File Handle
            NAME        => $name,                   # Name of the file
            EOF         => 1,                       # Print EOF on closure
            FTYPE       => 'perl',                  # vi style file type
            CMT         => '#',                     # Line comments begin with
            TIME        => '',                      # Inserted timestamp
            DO_TIME     => 1,                       # Insert timestamp in header
       };

    #
    #   Parse arguments
    #
    foreach ( @opts )
    {
        if ( /--NoEof/ ) {
            $self->{'EOF'} = 0;

        } elsif ( /--Type=(.*)/ ) {
            $self->{'FTYPE'} = $1;
            $self->{'CMT'} = 'REM' if ( $1 eq 'bat' );
            $self->{'CMT'} = '//'  if ( $1 eq 'CSharp' );
            $self->{'CMT'} = '//'  if ( $1 eq 'C++' );
            $self->{'CMT'} = '//'  if ( $1 eq 'Delphi' );
            $self->{'CMT'} = '\''  if ( $1 eq 'Basic' );

        } elsif ( /^--NoTime/ ) {
            $self->{'DO_TIME'} = 0;
            
        } else {
            ::Error("ConfigurationFile::New: Bad option: $_");
        }
    }

    #
    #   Insert a timestamp
    #
    $self->{TIME} = $::CurrentTime ?  $::CurrentTime : localtime;

    #
    #   Create the file
    #   Save the file handle
    #
    open( $self->{'FH'}, ">", $name ) || ::Error( "Cannot create '$name'");
    binmode ( $self->{'FH'} )
        if ( $self->{'FTYPE'} eq 'sh' );

    #
    #   Bless my self and return a handle
    #
    return bless $self, __PACKAGE__;
}

#-------------------------------------------------------------------------------
# Function        : Write
#                   WriteLn
#                   Comment
#
# Description     : print a line to the file
#                   Called write to avoid massivce confusion with print
#
# Inputs          : $self   - package handle
#                   $*      - print arguments
#                             WriteLn will write each one with a newline
#                             Arrays are allowed
#
# Returns         :
#
sub Write
{
    my $self = shift;
    print {$self->{FH}} ( @_ );
}

sub WriteLn
{
    my $self = shift;

    foreach my $entry ( @_ ) {
        if ( ref ($entry ) eq 'ARRAY'  ) {
            print {$self->{FH}}  $_ . "\n" foreach  ( @$entry );
        } else {
            print {$self->{FH}}  $entry . "\n"
        }
    }
}

sub Comment
{
    my $self = shift;
    print {$self->{FH}} ( $self->{'CMT'}, ' ', @_ );
}


#-------------------------------------------------------------------------------
# Function        : Dump
#
# Description     : Write out a data structure to the configuration file.
#                   Raw version. No header, no frills
#
# Inputs          : $varref     - Array of stuff to dump
#                   $name       - Array of names to use
#
# Returns         :
#
sub Dump
{
    my( $self, $varref, $name ) = @_;

    $Data::Dumper::Indent  = 1;         # Use 2 for readability, 1 or 0 for production
    $Data::Dumper::Sortkeys = 1;        # Sort the output for readability
#    $Data::Dumper::Purity  = 1;
    $Data::Dumper::Deepcopy = 1;        # Need to get @LIBS, @MLIBS into .cfg

    $self->Write (Data::Dumper->Dump ($varref, $name));
}

#-------------------------------------------------------------------------------
# Function        : DumpData
#
# Description     : Write out a data structure with header
#
# Inputs          :
#
# Returns         :
#
sub DumpData             # Will also work with a hash
{
    my ($self, $desc, $name, $array) = @_;
    my ($sep) = "";

    $self->Write($desc) if ($desc);
    $self->Dump( [$array], ["*$name"] );
    $self->Write("\n\n");
}

#-------------------------------------------------------------------------------
# Function        : Header
#
# Description:    : Generate a "standard" configuration file.
#..

sub Header
{
    my ($self, $by, $desc, $trailing) = @_;

    $desc = "" if ( !defined( $desc ) );
    $trailing = "" if ( !defined( $trailing ) );

    my ($diff);
    $diff = 0 if (($diff = ((80-6) - length($self->{'CMT'}) - length($desc))) < 0);
    $desc .= " " . ("-" x $diff);

    #
    #   Process HERE document to remove leading write space
    #   Simply to make the source look nice
    #

    my $ts = '';
    if ( $self->{'DO_TIME'} )
    {
        $ts = <<HERE_TARGET;
        $self->{'CMT'}         on $self->{'TIME'}
HERE_TARGET
    }

    my $var;
    ($var = <<HERE_TARGET) =~ s/^\s+//gm;

    $self->{'CMT'} -- $desc
    $self->{'CMT'}
    $self->{'CMT'}                   -- Please do not edit this file. --
    $self->{'CMT'}
    $self->{'CMT'} WARNING:
    $self->{'CMT'}       This file is used internally by JATS to maintain information
    $self->{'CMT'}       about the current sandbox.  You not must modify, nor move or
    $self->{'CMT'}       delete this file.  To do so may result in a system failure,
    $self->{'CMT'}       in additional to any changes made shall be overwritten.
    $self->{'CMT'}
    $self->{'CMT'} Created by $by
    $ts
    $self->{'CMT'}
    $trailing

HERE_TARGET

    $self->Write ($var);
}

#-------------------------------------------------------------------------------
# Function        : HeaderSimple
#
# Description:    : Generate a "simple" configuration file.
#..

sub HeaderSimple
{
    my ($self, $by, $desc, $trailing) = @_;

    $desc = "" if ( !defined( $desc ) );
    $trailing = "" if ( !defined( $trailing ) );

    my ($diff);
    $diff = 0 if (($diff = ((80-6) - length($self->{'CMT'}) - length($desc))) < 0);
    $desc .= " " . ("-" x $diff);

    #
    #   Process HERE document to remove leading write space
    #   Simply to make the source look nice
    #
    my $ts = '';
    if ( $self->{'DO_TIME'} )
    {
        $ts = <<HERE_TARGET;
        $self->{'CMT'}         on $self->{'TIME'}
HERE_TARGET
    }

    my $var;
    ($var = <<HERE_TARGET) =~ s/^\s+//gm;

    $self->{'CMT'} -- $desc
    $self->{'CMT'}
    $self->{'CMT'} -- Do not edit this file. --
    $self->{'CMT'}
    $self->{'CMT'} Created by $by
    $ts
    $self->{'CMT'}
    $trailing

HERE_TARGET

    $self->Write ($var);
}


#-------------------------------------------------------------------------------
# Function        : Close
#
# Description     : Generate EOF markers and close the file
#
# Inputs          : $file       - File handle
#                   $noeof      - TRUE: Don't generate an EOF
#
# Returns         :
#
sub Close
{
    my ($self, $noeof ) = @_;
    $self->{'EOF'} = 0 if ( $noeof );

    if ( $self->{'EOF'} )
    {
        if ( $self->{'FTYPE'} eq 'perl' )
        {
            my $var;
            ($var = <<HERE_TARGET) =~ s/^\s+//gm;

            #-EOF-
            1;
HERE_TARGET
        $self->Write( $var);
        }
        else
        {
            $self->Comment("End of File\n" );
        }
    }

    close $self->{FH};
    $self->{FH} = '';
}

#-------------------------------------------------------------------------------
# Function        : DESTROY
#
# Description     : Object destructor
#                   Sanity test. Generate an error if the object is destroyed
#                   without being closed.
#
# Inputs          : $self
#
# Returns         :
#

sub DESTROY
{
    my $self = shift;
    
    ::Error("ConfigurationFile not closed: $self->{NAME}")
        if ( $self->{FH} );
}
################################################################################

1;