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;