1:
2eval 'exec perl -wS $0 ${1+"$@"}'
3    if 0;
4#**************************************************************
5#
6#  Licensed to the Apache Software Foundation (ASF) under one
7#  or more contributor license agreements.  See the NOTICE file
8#  distributed with this work for additional information
9#  regarding copyright ownership.  The ASF licenses this file
10#  to you under the Apache License, Version 2.0 (the
11#  "License"); you may not use this file except in compliance
12#  with the License.  You may obtain a copy of the License at
13#
14#    http://www.apache.org/licenses/LICENSE-2.0
15#
16#  Unless required by applicable law or agreed to in writing,
17#  software distributed under the License is distributed on an
18#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
19#  KIND, either express or implied.  See the License for the
20#  specific language governing permissions and limitations
21#  under the License.
22#
23#**************************************************************
24
25
26#
27#
28# checkdeliver.pl - compare delivered files on solver with those on SRC_ROOT
29#
30
31use strict;
32use Getopt::Long;
33use File::stat;
34use IO::Handle;
35
36use lib ("$ENV{SOLARENV}/bin/modules");
37
38#### globals #####
39
40my $err              = 0;
41my $srcrootdir       = '';
42my $solverdir        = '';
43my $platform         = '';
44my $logfile          = '';
45my $milestoneext     = '';
46my $local_env        = 0;
47my @exceptionmodlist = (
48                        "postprocess",
49                        "instset.*native",
50                        "smoketest.*native",
51                        "testautomation",
52                        "testgraphical"
53                       ); # modules not yet delivered
54
55#### main #####
56
57print_logged("checkdeliver.pl - checking delivered binaries\n");
58
59get_globals();                                  # get global variables
60my $deliverlists_ref = get_deliver_lists();     # get deliver log files
61foreach my $listfile ( @$deliverlists_ref ) {
62    $err += check( $listfile );                 # check delivered files
63}
64print_logged("OK\n") if ( ! $err );
65exit $err;
66
67#### subroutines ####
68
69sub get_globals
70# set global variables using environment variables and command line options
71{
72    my $help;
73
74    # set global variables according to environnment
75    $platform      = $ENV{INPATH};
76    $srcrootdir    = $ENV{SOURCE_ROOT_DIR};
77    $solverdir     = $ENV{SOLARVERSION};
78    $milestoneext  = $ENV{UPDMINOREXT};
79
80    # override environment with command line options
81    GetOptions('help' => \$help,
82               'l=s'  => \$logfile,
83               'p=s'  => \$platform
84    ) or usage (1);
85
86    if ( $help ) {
87        usage(0);
88    }
89
90    #do some sanity checks
91    if ( ! ( $platform && $srcrootdir && $solverdir ) ) {
92        die "Error: please set environment\n";
93    }
94    if ( ! -d $solverdir ) {
95        die "Error: cannot find solver directory '$solverdir'\n";
96    }
97
98    # Check for local env., taken from solenv/bin/modules/installer/control.pm
99    # In this case the content of SOLARENV starts with the content of SOL_TMP
100    my $solarenv = "";
101    my $sol_tmp;
102    if ( $ENV{'SOLARENV'} ) {
103        $solarenv = $ENV{'SOLARENV'};
104    }
105    if ( $ENV{'SOL_TMP'} ) {
106        $sol_tmp = $ENV{'SOL_TMP'};
107    }
108    if ( defined $sol_tmp && ( $solarenv =~ /^\s*\Q$sol_tmp\E/ )) {
109        # Content of SOLARENV starts with the content of SOL_TMP: Local environment
110        $local_env = 1;
111    }
112}
113
114sub get_deliver_lists
115# find deliver log files on solver
116{
117    my @files;
118    my $pattern = "$solverdir/$platform/inc";
119    $pattern .= "$milestoneext" if ( $milestoneext );
120    $pattern .= "/*/deliver.log";
121
122    @files = glob( $pattern );
123    # do not check modules not yet built
124    foreach my $exceptionpattern ( @exceptionmodlist ) {
125        @files = grep ! /\/$exceptionpattern\//, @files;
126    }
127    if ( ! @files ) {
128        print_logged( "Error: cannot find deliver log files\n" );
129        exit 1;
130    }
131    return \@files;
132}
133
134sub check
135# reads deliver log file given as parameter and compares pairs of files listed there.
136{
137    my $listname = shift;
138    my $error = 0;
139    my %delivered;
140    my $module;
141    my $repository;
142    STDOUT->autoflush(1);
143    # which module are we checking?
144    if ( $listname =~ /\/([\w-]+?)\/deliver\.log$/o) {
145        $module = $1;
146    } else {
147        print_logged( "Error: cannot determine module name from \'$listname\'\n" );
148        return 1;
149    }
150
151    if ( -z $listname ) {
152        print_logged( "Warning: empty deliver log file \'$listname\'. Module '$module' not delivered correctly?\n\n" );
153        return 0;
154    }
155
156    # read deliver log file
157    if ( ! open( DELIVERLOG, "< $listname" ) ) {
158        print_logged( "Error: cannot open file \'$listname\'\n$!" );
159        exit 2;
160    }
161    while ( <DELIVERLOG> ) {
162        next if ( /^LINK / );
163        # What's this modules' repository?
164        if ( /COPY\s+(.+?)\/$module\/prj\/build.lst/ ) {
165#        if ( /COPY (\w[\w\s-]*?)\/$module\/prj\/build.lst/ ) {
166            $repository = $1;
167        }
168        # For now we concentrate on binaries, located in 'bin' or 'lib' and 'misc/build/<...>/[bin|lib]'.
169        next if ( (! /\/$module\/$platform\/[bl]i[nb]\//) && (! /\/$module\/$platform\/misc\/build\//));
170        next if (! /[bl]i[nb]/);
171        next if ( /\.html$/ );
172        chomp;
173        if ( /^\w+? (\S+) (\S+)\s*$/o ) {
174            my $origin = $1;
175            $delivered{$origin} = $2;
176        } else {
177            print_logged( "Warning: cannot parse \'$listname\' line\n\'$_\'\n" );
178        }
179    }
180    close( DELIVERLOG );
181
182    if ( ! $repository ) {
183        print_logged( "Error parsing \'$listname\': cannot determine repository. Module '$module' not delivered correctly?\n\n" );
184        $error ++;
185        return $error;
186    }
187
188    my $path = "$srcrootdir/$repository/$module";
189    # is module physically accessible?
190    # there are valid use cases where we build against a prebuild solver whithout having
191    # all modules at disk
192    my $canread = is_moduledirectory( $path );
193    if ( ! $canread ) {
194        # do not bother about non existing modules in local environment
195        # or on childworkspaces
196        if (( $local_env ) || ( $ENV{CWS_WORK_STAMP} )) {
197            return $error;
198        }
199        # in a master build it is considered an error to have deliver leftovers
200        # from non exising (removed) modules
201        print_logged( "Error: module '$module' not found.\n" );
202        $error++;
203        return $error;
204    }
205    if ( $canread == 2 ) {
206        # module is linked and not built, no need for checking
207        # should not happen any more nowadays ...
208        return $error;
209    }
210
211    # compare all delivered files with their origin
212    # no strict 'diff' allowed here, as deliver may alter files (hedabu, strip, ...)
213    foreach my $file ( sort keys %delivered ) {
214        my $ofile = "$srcrootdir/$file";
215        my $sfile = "$solverdir/$delivered{$file}";
216        if ( $milestoneext ) {
217            # deliver log files do not contain milestone extension on solver
218            $sfile =~ s/\/$platform\/(...)\//\/$platform\/$1$milestoneext\//;
219        }
220        my $orgfile_stats = stat($ofile);
221        next if ( -d _ );  # compare files, not directories
222        my $delivered_stats = lstat($sfile);
223        next if ( -d _ );  # compare files, not directories
224        if ( $^O !~ /^MSWin/ ) {
225            # windows does not know about links.
226            # Therefore lstat() is not a lstat, and the following check would break
227            next if ( -l _ );  # compare files, not links
228        }
229
230        if ( $orgfile_stats && $delivered_stats ) {
231            # Stripping (on unix like platforms) and signing (for windows)
232            # changes file size. Therefore we have to compare for file dates.
233            # File modification time also can change after deliver, f.e. by
234            # rebasing, but only increase. It must not happen that a file on
235            # solver is older than it's source.
236            if ( ( $orgfile_stats->mtime - $delivered_stats->mtime ) gt 1 ) {
237                print_logged( "Error: " );
238                print_logged( "delivered file is older than it's source '$ofile' '$sfile'\n" );
239                $error ++;
240            }
241        } elsif ( !$orgfile_stats && $delivered_stats ) {
242            # This is not an error if we have a solver and did not build the
243            # module!
244        } elsif ( !$orgfile_stats && !$delivered_stats ) {
245            # This is not necessarily an error.
246            # Instead, this seems to be an error of the deliver.log file.
247        } else {
248            print_logged( "Error: no such file '$ofile'\n" ) if ( ! $orgfile_stats );
249            print_logged( "Error: no such file '$sfile'\n" ) if ( ! $delivered_stats );
250            $error ++;
251        }
252    }
253    if ( $error ) {
254        print_logged( "$error errors found: Module '$module' not delivered correctly?\n\n" );
255    }
256    STDOUT->autoflush(0);
257    return $error;
258}
259
260sub is_moduledirectory
261# Test whether we find a module having a d.lst file at a given path.
262# Return value: 1: path is valid directory
263#               2: path.link is a valid link
264#               0: module not found
265{
266    my $dirname = shift;
267    if ( -e "$dirname/prj/d.lst" ) {
268        return 1;
269    } elsif ( -e "$dirname.link/prj/d.lst" ) {
270        return 2
271    } else {
272        return 0;
273    }
274}
275
276sub print_logged
277# Print routine.
278# If a log file name is specified with '-l' option, print_logged() prints to that file
279# as well as to STDOUT. If '-l' option is not set, print_logged() just writes to STDOUT
280{
281    my $message = shift;
282    print "$message";
283    if ( $logfile ) {
284        open ( LOGFILE, ">> $logfile" ) or die "Can't open logfile '$logfile'\n";
285        print LOGFILE "$message";
286        close ( LOGFILE) ;
287    }
288}
289
290
291sub usage
292# print usage message and exit
293{
294    my $retval = shift;
295    print STDERR "Usage: checkdeliver.pl [-h] [-p <platform>]\n";
296    print STDERR "Compares delivered files on solver with original ones in build tree\n";
297    print STDERR "Options:\n";
298    print STDERR "    -h              print this usage message\n";
299    print STDERR "    -p platform     specify platform\n";
300
301    exit $retval;
302}
303
304