WebSVN – DevTools – Diff – /core_devl/trunk/TOOLS/create_dpkg.pl

 ########################################################################
-# Copyright (C) 2008 ERG Limited, All rights reserved
+# Copyright (c) VIX TECHNOLOGY (AUST) LTD
+#
-# Module name   : create_dpkg.pl
+# Module name   : create_dpkg2.pl
-# Module type   : JATS Utility
+# Module type   : Makefile system
 # Compiler(s)   : Perl
-# Environment(s): JATS
+# Environment(s): jats
+#
 # Description   : This script is used to create a dpkg_archive.
+#                 Based on create_dpkg with following changes
+#                   * No user interaction
+#                   * Generates files list for ReleaseNote integration
+#
-# Usage         : See POD
+# Usage:        : See POD
+#
 #......................................................................#
 require 5.008_002;
 # Include Standard Perl Functions
+#
 use strict;
 use File::Find;
 use File::Path;
 use File::Copy;
 use Pod::Usage;
 use Digest::MD5;
+use XML::Simple;
 use JatsError;
 use JatsEnv;
 use DescPkg;
 use FileUtils;
+#
 my $Win32 = eval "require Win32::FileSecurity";
 # define Global variables
+#
-my $VERSION = "2.4.1";
+my $VERSION = "3.0.0";
 my $PROGNAME = "create_dpkg.pl";
 # Globals imported from environment
+#
 our $GBE_MACHTYPE;
 my $CWD_DIR       = cwd;
 my $SRC_ROOT;
 my $DPKG_DIR;
 my $DPKG_ROOT;
 my $PKG_BASE;
-my $e_repository = "";
 my $bad_merge_count = 0;
 my @bad_symlinks;
+my @fileList;
+my $descPkgCount = 0;
+#
 #   Option variables
+#
 my $opt_help = 0;
 my $opt_manual = 0;
 my $opt_verbose = 0;
 my $opt_quiet = 0;
+my $opt_delete = 0;
 my $opt_override = 0;
 my $opt_merge = 0;
 my $opt_archive;
 my $opt_generic;
 my $opt_pname;
 my $opt_pversion;
 my $opt_test;
 my $opt_md5 = 1;
+my $opt_outfile;
+my $opt_info;
+#
 #   Structure to translate -archive=xxx option to archive variable
 #   These are the various dpkg_archives known to JATS
     $file =~ s/$DPKG_ROOT/DPKG/;
     Information (sprintf( "%-15s [%s]", $opr, $file));
+}
+#-------------------------------------------------------------------------------
+# Function        : addFile
+#
+# Description     : Add a file to the list of transferred files
+#
+# Inputs          : $type           - File type
+#                   $source         - Source file - full path
+#                                     Use local copy, not network copy for file ops
+#                   $target         - Target file name
+#                   $md5sum         - Precalculated MD5 sum
+#
+# Returns         :
+#
+sub addFile
+{
+    my ($type, $source, $target, $md5sum) = @_;
+    my %data;
+    if ((not defined $md5sum) && ($type eq 'file'))
+    {
+        Verbose("Calculate MD5 Digest: $source");
+        open(my $fh , $source) or Error ("Can't open '$source': $!");
+        binmode $fh, ':crlf';
+        $md5sum = Digest::MD5->new->addfile($fh)->hexdigest;
+        close $fh;
+    }
+    $target =~ s~$DPKG_DIR~~;
+    $target =~ s~^/~~;
+    $target =~ s~/$~~;
+    if ($type eq 'dir')
+    {
+        $data{path} = $target;
+    }
+    else
+    {
+        $data{path} = StripFileExt($target);
+        $data{name} = StripDir($target);
+        if ($type eq 'file')
+        {
+            $data{size} = (stat($source))[7];
+            $data{md5sum} = $md5sum;
+        }
+    }
+    $data{fullname} = $target;
+    $data{type} = $type;
+    $data{machtype} = $GBE_MACHTYPE;
+    $data{host} = $GBE_HOSTNAME;
+    # Put a nice '/' on the end of the patch elements
+    $data{path} .= '/'
+        if ( exists ($data{path}) && length($data{path}) > 0);
+    push @fileList, \%data;
+}
+#-------------------------------------------------------------------------------
+# Function        : writeFileInfo
+#
+# Description     : Write out an XML file that contains this processes
+#                   contribution to the output package
+#
+# Inputs          :
+#
+# Returns         :
+#
+sub writeFileInfo
+{
+    my $data;
+    $data->{file} = \@fileList;
+    #
+    #   Write out sections of XML
+    #       Want control over the output order
+    #       Use lots of attributes and only elements for arrays
+    #       Save as one attribute per line - for readability
+    #
+    $opt_outfile = $opt_generic ? "$DPKG_DIR/built.files.generic.xml" : "$DPKG_DIR/built.files.$GBE_HOSTNAME.xml";
+    LogFileOp ('Meta File', $opt_outfile);
+    my $xs = XML::Simple->new( NoAttr =>0, AttrIndent => 1 );
+    open (my $XML, '>', $opt_outfile) || Error ("Cannot create output file: $opt_outfile", $!);
+    $xs->XMLout($data,
+                'RootName' => 'files',
+                'XMLDecl'  => '<?xml version="1.0" encoding="UTF-8"?>',
+                'OutputFile' => $XML);
+    close $XML;
+}
 #------------------------------------------------------------------------------
 sub Init
+#
 # Description:
 #     This function is used to process any command line arguements
     # Process any command line arguements...
     my $result = GetOptions (
                 "help:+"        => \$opt_help,              # flag, multiple use allowed
                 "manual:3"      => \$opt_help,              # flag
                 "verbose:+"     => \$opt_verbose,           # flag, multiple use allowed
+                "override!"     => \$opt_override,          # [no]flag (No longer used. Backward compat with build tool)
-                "override!"     => \$opt_override,          # [no]flag
+                "delete!"       => \$opt_delete,            # [no]flag
                 "merge|m!"      => \$opt_merge,             # [no]flag.
                 "archive=s"     => \$opt_archive,           # string
                 "quiet+"        => \$opt_quiet,             # Flag
                 "generic!"      => \$opt_generic,           # [no]Flag
                 "pname=s"       => \$opt_pname,             # string
                 "pversion=s"    => \$opt_pversion,          # string
                 "test!"         => \$opt_test,              # [no]flag
                 "md5!"          => \$opt_md5,               # [no]flag
+                "info!"         => \$opt_info,              # [no]flag
                 );
+    #
     #   Process help and manual options
         unless $DPKG_ROOT;
     Error("Failed to find Repository: $DPKG_ROOT")
         unless ( -d $DPKG_ROOT );
-    $e_repository = ("      *Non Standard archive")
-        unless ( $opt_archive eq 'main' );
     #   Locate the package
     #   Packages are located by looking for a file called descpkg within the
     #   main package directory.
+    #
     #   This installation process only handles one such file
+    #
+    $descPkgCount = 0;
     File::Find::find( \&pkgFind, $PKG_BASE);
+    if ($descPkgCount > 1 )
+    {
+        Warning ("Package contains multiple ($descPkgCount) descpkg files");
+    }
+}
 #-------------------------------------------------------------------------------
 # Function        : CheckDescPkg
+#
     Information ("Version: $VERSION");
     Information ("");
     Information ("Information:");
     Information ("Working dir   = [$CWD_DIR]");
     Information ("Package Root  = [$SRC_ROOT]");
-    Information ("Repository    = [$DPKG_ROOT]$e_repository");
+    Information ("Repository    = [$DPKG_ROOT]");
+    Information ("                *Non Standard archive") unless $opt_archive eq 'main';
     Information ("Target dir    = [$DPKG_DIR]");
     Information1("DPKG_NAME     = [$DPKG_NAME]");
     Information1("DPKG_VERSION  = [$DPKG_VERSION]");
     Information1("GBE_MACHTYPE  = [$GBE_MACHTYPE]");
     Information1("GBE_HOSTNAME  = [$GBE_HOSTNAME]");
     Information1("GBE_ABT       = [$GBE_ABT]");
     Information1("USER          = [$USER]");
-    Information ("")                                if ( $opt_merge || $opt_override );
+    Information ("")                                if ( $opt_merge || $opt_delete || $opt_info);
-    Information ("Opt:Override  = Enabled")         if ( $opt_override );
+    Information ("Opt:Delete    = Enabled")         if ( $opt_delete );
     Information ("Opt:Merge     = Enabled")         if ( $opt_merge );
     Information ("Opt:TestMode  = Enabled. No Package Transferred") if ( $opt_test );
+    Information ("Opt:Info      = Enabled. No Package Transferred") if ( $opt_info );
     Warning     ("Sandbox Build = Yes") if ($ENV{GBE_DPKG_SBOX}) ;
     Information ("---------------------------------------------------------------");
+    #
     #   If the environment variable GBE_DPKG_SBOX is defined then the package
     # so our start dir.
     # we need to determine which file we are dealing with
     if ( ! -d $item && $file =~ /^descpkg$/ )
+    {
+        $descPkgCount++;
+        #
         #   Only grab the first one
+        #
         if ( $DESCPKG_FILE )
+        {
+            $item =~ s~$PKG_BASE/~~;
-            Warning ("Package contains multiple descpkg files");
+            Verbose ("Multiple descpkg files:", $item );
             return;
+        }
         $DESCPKG_FILE = $item;
         my($dir)= File::Basename::dirname($item);
     # first we need to ensure we have the top level directory
+    #
     if ( -d $DPKG_DIR )
+    {
         Warning("Detected previous dpkg_archive [$DPKG_DIR]");
-        unless ( $opt_override )
-        {
-            Error ("Package already exists") if ( $opt_quiet );
+        Error ("Package already exists and Package merging not selected")
-            if ( !GetYesNo("Do you wish to continue?") )
+            unless ( $opt_delete || $opt_merge );
-            {
-                Error("Script terminated by user.");
-            }
-        }
+        #
         #   Target exists
         #   Unless we are merging, we need to blow the entire tree away
+        #
+        #
         if ( ! -d "$target" )
+        {
             LogFileOp("Creating Dir", $target);
             mkpath("$target", 0, 0775);
+            addFile('dir', $item , $target);
+        }
+    }
     else
+    {
+        #
         unless ( $opt_merge && -f $target )
+        {
             if ( $item =~ m~/descpkg$~ )
+            {
                 LogFileOp("Rewrite File",$target);
-                TransferDescpkg( "$item", $target );
+                TransferDescpkg( $item, $target );
                 CORE::chmod oct("0664"), $target;
+                addFile('file', $item, $target);
+            }
             else
+            {
+                #
                 #   Copy file to destination
                         symlink ($link, $target );
                         unless ( $link && -l $target )
+                        {
                             Error("Failed to copy link [$item] to [$target]: $!");
+                        }
+                        addFile('link', $item , $target);
+                    }
                     else
+                    {
                         # Don't copy broken Symlinks
                         # Perhaps this should be an error - but is will break escrow builds
+                    }
                     else
+                    {
                         CORE::chmod oct("0775"), $target;
+                    }
+                    addFile('file', $item, $target);
+                }
                 else
+                {
                     Error("Failed to copy file [$item] to [$target]: $!");
+                }
+            #
             if ( $item =~ m~/descpkg$~ )
+            {
                 LogFileOp("Touch File",$target);
                 TouchFile( $target ) && Error ( "Failed to touch: $target" );
+                addFile('merge', $item, $target);
+            }
             else
+            {
+                #
                 #   MD5 digest the files that are being merged
                     unless ( $source_md5 eq $target_md5 )
+                    {
                         $msg = "DIFF: Merge Test File";
                         $bad_merge_count ++;
+                    }
+                    addFile('merge', $item, $target, $target_md5);
+                }
                 LogFileOp($msg,$target);
+            }
+        }
+    }
+}
-# -------------------------------------------------------------------------
-sub GetYesNo
-#
-# -------------------------------------------------------------------------
-{
-    my ($question) = @_;
-    my ($u_tmp) = "";
-    Question ("$question, (default: y) [y,n]: ");
-    while ( <STDIN> )
-    {
-        $u_tmp = $_;
-        chomp($u_tmp);
-        return 1
-            if ( "$u_tmp" eq "" );
-        if( $u_tmp =~ /[yn]{1}/i )
-        {
-            return ( "$u_tmp" eq "y" );
-        }
-        else
-        {
-            Question("Please re-enter response? (default: y) [y,n]: ");
-        }
-    }
-}
 #-------------------------------------------------------------------------------
 # Function        : TestDpkgArchive
+#
 # Description     : Test the structure of the source achive
 #                   Ensure that it has some files
 # Initialise our world
+#
 Init();
 CheckDescPkg();
 ShowInfo();
-# Check with the user they want to proceed
-#
-unless ( $opt_test )
+unless ($opt_info)
+{
-    Information("Creating dpkg_archive package:", $DPKG_DIR);
-    unless( $opt_override || $opt_quiet )
+    unless ( $opt_test )
+    {
-        if ( !GetYesNo( "Do you wish to continue?" ) )
+        Information("Creating dpkg_archive package:", $DPKG_DIR);
+        CreateDpkgArchive();
+        writeFileInfo();
+    }
+    else
-        {
+    {
-            Error ("Script terminated by user.");
+        Information("Testing user package.");
-        }
+        TestDpkgArchive();
+    }
-    # Create the archive and copy the files
-    #
-    CreateDpkgArchive();
-}
-else
-{
-    TestDpkgArchive();
+}
 # Done
+#
 Information ("Done.");
     -help              - Brief help message
     -help -help        - Detailed help message
     -man               - Full documentation
     -quiet             - Suppress progress messages, then warning messages
     -verbose           - Display additional progress messages
+    -override          - Deprecated option
-    -override          - Override any previous version of the package
+    -delete            - Delete any previous version of the package
     -[no]merge         - merge with existing version of the package
     -archive=name      - Specify archive (cache, local, main, store, sandbox, deploy)
     -pname=name        - Ensure package is named correctly
     -pversion=version  - Ensure package version is correct
     -generic           - Create a built.generic file
-    -[no]test          - Test package. Do not transfer.
     -[no]md5           - Use MD5 comparison of merged files(enabled)
+    -[no]test          - Test package. Do not transfer.
+    -[no]info          - Display packaging info. Do not transfer.
 =head1 OPTIONS
 =over 8
 copy message. It is intended to be used when the program is called from another
 script.
 =item B<-override>
+If this option has been deprecated. It has no effect.
+It is still present to preserve backward compatability with the automated
+build system.
+=item B<-delete>
 If this option is enabled then any previous version of the target package will
-be deleted, without any user intervention.
+be deleted.
 =item B<-merge>
 If this option is enabled then the package will be merged with any existing
-package, without any user intervention. This option is used by the auto build
+package. This option is used by the auto build tool to assemble multi-machine
-tool to assemble multi-machine packages in dpkg_archive.
+packages in dpkg_archive.
 =item B<-archive=name>
 This option specifies the destination archive to be used. The following names
 are supported:
 =item B<-pversion=version>
 If this option is provided, the utility will ensure that the package version is
 that expected.
-=item B<-test>
+=item B<-generic>
-If this option is enabled the utility will perform initial sanity testing, but
+This option will create a built.generic file, instead of one based on the machine
-it will not perform the copy.
+that actually built the package. This is used by the AutoBuilder toolchain.
 =item B<-[no]md5>
 If package builds are being merged then a validity check is performed using
 an MD5 digest over the current and the existing file.
 By default, it is an error for the user file to differ from the merged file.
 This option disabled the error. The test is still done and the results are
 reported.
-=item B<-generic>
+=item B<-test>
+If this option is enabled the utility will perform initial sanity testing, but
+it will not perform the copy.
+=item B<-[no]info>
-This option will create a built.generic file, instead of one based on the machine
+This option will cause the program to display information about the packaging
+process and then exit.
-that actually built the package. This is used by the AutoBuilder toolchain.
+No data will be transferred to the archive.
 =back
 =head1 DESCRIPTION
 This utility program is used to transfer a package that has been built into
 dpkg_archive. The package is then available for general consumption.
+The utility will perform several operations in the transfer process. These incude:
+=over 4
+=item *
+Create a tag file to indicate the machine that has performed the transfer
+=item *
+Create an XML file of files that have been transferred. This file contains information
+used by the build system when it releases the package, including: name, size and MD5SUM.
+=item *
+Detect file conflicts when different builds are merged into a single package. Header files are
+allowed to differ in line ending style, but other files must not conflict. The package will not be
+reproducible if file conflicts exist.
+=item *
+Suppress dead symbolic links. A valid symlink will be preserved, but invalid links will be
+removed from the transferred image.
+=back
 =head2 PACKAGE LOCATION
 The utility will locate a package by examining the following directores for
 the package description file(descpkg).

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/create_dpkg.pl – Rev 4424 → 4549