xref: /aoo4110/main/solenv/bin/build_release.pl (revision b1cdbd2c)
1#!/usr/bin/perl
2#**************************************************************
3#
4#  Licensed to the Apache Software Foundation (ASF) under one
5#  or more contributor license agreements.  See the NOTICE file
6#  distributed with this work for additional information
7#  regarding copyright ownership.  The ASF licenses this file
8#  to you under the Apache License, Version 2.0 (the
9#  "License"); you may not use this file except in compliance
10#  with the License.  You may obtain a copy of the License at
11#
12#    http://www.apache.org/licenses/LICENSE-2.0
13#
14#  Unless required by applicable law or agreed to in writing,
15#  software distributed under the License is distributed on an
16#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
17#  KIND, either express or implied.  See the License for the
18#  specific language governing permissions and limitations
19#  under the License.
20#
21#**************************************************************
22
23use strict;
24use warnings;
25use XML::LibXML;
26use open OUT => ":utf8";
27use LWP::Simple;
28use Digest;
29use Digest::MD5;
30use Digest::SHA;
31use File::Temp;
32use File::Path;
33
34use Carp::always;
35
36=head1 NAME
37
38    build_release.pl - Tool for batch release builds and uploads and the creation of wiki pages that list install sets.
39
40=head1 SYNOPSIS
41
42    build_release.pl <command> {option} <release-description.xml>
43
44    comands:
45        build      builds all install sets as requested by the XML file and supported by the platform.
46        build-missing
47                   build only those install sets that have not been built earlier.
48        upload     upload install sets to a local or remote (via ssh with public/private key)
49                   directory structure.  Uploads install sets that where build on other platforms.
50        wiki       create a wiki (MediaWiki syntax) snippet that references all install sets at the upload
51                   location.  Includes install sets that where built and/or uploaded from other
52                   platforms and machines.
53    options:
54        -j <count>    maximum number of build processes
55        -k            keep going if there are recoverable errors
56        -u <path>     upload destination
57        -l            check links on wiki page, write broken links as plain text
58        -ld           check links on wiki page, mark broken links
59        -o <filename> filename of the output (wiki: wiki page, build: makefile)
60        -n <number>   maximal number of upload tries, defaults to 5.
61        -d            dry-run
62
63    Typical calls are:
64       build_release.pl build -j4 instsetoo_native/util/aoo-410-release.xml
65           for building the installation sets, language packs and patches for the 4.1 release.
66
67       build_release.pl upload -u me@server:path -n 3 instsetoo_native/util/aoo-410-release.xml
68           to upload the previously built installation sets etc.
69
70       build_release.pl wiki -o /tmp/wiki.txt instsetoo_native/util/aoo-410-release.xml
71           to create an updated wiki page with installation sets etc built at several
72           places and uploaded to several locations.
73
74
75=head1 XML file format
76
77The release description could look like this:
78
79<release
80    name="snapshot"
81    version="4.1.0">
82
83    <language
84        id="ast"                            # As specified by 'configure --with-lang'
85        english-name="Asturian"
86        local-name="Asturianu"
87        />
88    ... more languages
89
90    <platform
91        id="wntmsci12.pro"
92        display-name="Windows"
93        archive-platform="Win_x86"
94        word-size="32"
95        package-types="msi"
96        extension="exe"
97        />
98    ... more platforms
99
100    <download
101        platform-id="wntmsci12.pro"
102        base-url="http://people.apache.org/~somebody/developer-snapshots/snapshot/win32"
103        />
104
105    <package
106        id="openoffice"
107        target="openoffice"
108        display-name="Full Install"
109        archive-name="Apache_OpenOffice_%V_%P_install%T_%L.%E"
110        />
111
112    <build
113        package-id="openoffice"
114        platform-list="all"
115        language-list="all"
116        />
117    ... more build entries
118
119  <wiki>
120    <package-ref
121        package-id="openoffice"
122        language-list="all"
123        platform-list="all"
124        table="main"
125        />
126    ... more packages
127  </wiki>
128
129</release>
130
131A single <release> tag contains any number of
132
133<language>  id
134                The language id used internally by the build process, eg de, en-US
135            english-name
136                The english name of the language, eg german
137            local-name
138                The language name in that language, eg Deutsch
139
140    Each listed language is expected to have been passed to configure via --with-lang
141    The set of languages defines for which languages to
142          build installation sets, language packs etc. (build command)
143          upload installation sets, etc (upload command)
144          add rows in the wiki page (wiki command)
145
146<platform>  id
147                The platform id that is used internally by the build process, eg wntmsci12.pro
148                Note that <p>.pro and <p> are treated as two different platforms.
149            display-name
150                Name which is printed in the wiki table.
151            archive-platform
152                Platform name as used in the name of the installation set, eg Win_x86
153            word-size
154                Bit size of the installation sets, etc, typically either 32 or 64
155            package-types
156                Semicolon separated list of package types, eg "msi" or "deb;rpm"
157            add-package-type-to-archive-name
158                For deb and rpm archives it is necessary to add the package type to the archive name.
159            extension
160                Extension of the archive name, eg "exe" or "tar.gz"
161
162    For the build command only those <platform> elements are used that match the platform on which this
163    script is run.
164
165<download>
166            platform-id
167                Reference to one of the <platform> elements and has to match the id attribute of that platform.
168            base-url
169                URL head to which the name of the downloadable installation set etc. is appended.
170                Eg. http://people.apache.org/~somebody/developer-snapshots/snapshot/win32
171
172    Defines one download source that is referenced in the wiki page.  Multiple <download> elements
173    per platform are possible.  Earlier entires are preferred over later ones.
174
175<package>
176            id
177                Internal name that is used to reference the package.
178            target
179                Target name recognized by instsetoo_native/util/makefile.mk, eg openoffice or oolanguagepack.
180            display-name
181                Name of the package that is shown in the wiki page, eg "Full Install" or "Langpack".
182            archive-name
183                Template of the archive name.
184                %V version
185                %P archive package name
186                %T package type
187                %L language
188                %E extension.
189
190    Defines a downloadable and distributable package, eg openoffice for the binary OpenOffice installation set.
191
192<build>     target
193            platform-list
194                Semicolon separated list of platforms for which to build the target.
195                Ignores all platforms that don't match the  platform on which this script is executed.
196                The special value 'all' is a shortcut for all platforms listed by <platform> elements.
197            language-list
198                Semicolon separated list of languages for which the build the target.
199                The special value 'all' is a shortcut for all languages listed by <language> elements.
200
201    Defines the sets of targets, plaforms and languages which are to be built.
202
203<wiki>
204    <package-ref>
205            package-id
206                The id of the referenced package.
207            platform-list
208                See <build> tag for explanation.
209            language-list
210                See <build> tag for explanation.
211            table
212                Specifies the wiki table into which to add the package lines.  Can be "main" or "secondary".
213
214=cut
215
216
217
218my %EnUSBasedLanguages = (
219    'ast' => 1
220    );
221
222
223sub ProcessCommandline (@);
224sub PrintUsageAndExit ();
225sub Trim ($);
226sub ReadReleaseDescription ($$);
227sub ProcessBuildDescription ($$$);
228sub ProcessPlatformDescription ($$);
229sub ProcessDownloadDescription ($$);
230sub ProcessPackageDescription ($$);
231sub ProcessWikiPackageDescription ($$$);
232sub ProcessLanguageDescription ($$);
233sub PostprocessLanguageList ($$);
234sub PostprocessPlatformList ($$);
235sub CheckLanguageSet ($@);
236sub WriteMakefile ($$);
237sub Upload ($$);
238sub PrepareUploadArea ($@);
239sub UploadFilesViaRsync ($$@);
240sub CollectDownloadSets ($);
241sub ProvideChecksums ($@);
242sub IsOlderThan ($$);
243sub GetInstallationPackageName ($$$$);
244sub ResolveTemplate ($$$$$);
245sub GetCurrentPlatformDescriptor ($);
246sub Wiki ($$);
247sub GetTableList ($);
248sub GetPackagesForTable ($$);
249sub GetLanguagesForTable ($@);
250sub GetPlatformsForTable ($@);
251sub WriteDownloadLinks ($$$$$$$);
252sub FindDownload ($$$$$);
253sub CreateLink ($$$);
254sub CheckLink ($);
255sub SignFile ($$);
256
257sub ProcessCommandline (@)
258{
259    my @arguments = @_;
260
261    my $command = undef;
262    my $description_filename = undef;
263    my $max_process_count = 1;
264    my $keep_going = 0;
265    my $upload_destination = undef;
266    my $check_links = 0;
267    my $mark_broken_links = 0;
268    my $output_filename = undef;
269    my $max_upload_count = 5;
270    my $build_only_missing = 0;
271    my $dry_run = 0;
272
273    my $error = 0;
274    while (scalar @arguments > 0)
275    {
276        my $argument = shift @arguments;
277        if ($argument =~ /^-/)
278        {
279            if ($argument eq "-j")
280            {
281                $max_process_count = shift @arguments;
282            }
283            elsif ($argument eq "-u")
284            {
285                $upload_destination = shift @arguments;
286                $upload_destination =~ s/(\\|\/)$//;
287            }
288            elsif ($argument eq "-k")
289            {
290                $keep_going = 1;
291            }
292            elsif ($argument eq "-l")
293            {
294                $check_links = 1;
295            }
296            elsif ($argument eq "-ld")
297            {
298                $check_links = 1;
299                $mark_broken_links = 1;
300            }
301            elsif ($argument eq "-o")
302            {
303                $output_filename = shift @arguments;
304            }
305            elsif ($argument eq "-n")
306            {
307                $max_upload_count = shift @arguments;
308            }
309            elsif ($argument eq "-d")
310            {
311                $dry_run = 1;
312            }
313            else
314            {
315                printf STDERR "unknown option $argument %s\n", $argument;
316                $error = 1;
317            }
318        }
319        elsif ( ! defined $command)
320        {
321            $command = $argument;
322            if ($command eq "build-missing")
323            {
324                $command = "build";
325                $build_only_missing = 1;
326            }
327            elsif ($command !~ /^(build|build-missing|upload|wiki)$/)
328            {
329                printf STDERR "unknown command '%s'\n", $command;
330                $error = 1;
331            }
332        }
333        else
334        {
335            $description_filename = $argument;
336            if ( ! -f $description_filename)
337            {
338                print STDERR "can not open release description '%s'\n", $description_filename;
339                $error = 1;
340            }
341        }
342    }
343
344    if ( ! defined $description_filename)
345    {
346        $error = 1;
347    }
348    if (! defined $command)
349    {
350        printf STDERR "ERROR: no command\n";
351        $error = 1;
352    }
353    elsif ($command =~ /^(wiki)$/)
354    {
355        if ( ! defined $output_filename)
356        {
357            printf STDERR "ERROR: no output filename\n",
358            $error = 1;
359        }
360    }
361
362    if ($error)
363    {
364        PrintUsageAndExit();
365    }
366
367    return {
368        'command' => $command,
369        'filename' => $description_filename,
370        'max-process-count' => $max_process_count,
371        'keep-going' => $keep_going,
372        'upload-destination' => $upload_destination,
373        'check-links' => $check_links,
374        'mark-broken-links' => $mark_broken_links,
375        'output-filename' => $output_filename,
376        'max-upload-count' => $max_upload_count,
377        'build-only-missing' => $build_only_missing,
378        'dry-run' => $dry_run
379    };
380}
381
382
383
384
385sub PrintUsageAndExit ()
386{
387    print STDERR "usage: $0 <command> {option} <release-description.xml>\n";
388    print STDERR "    comands:\n";
389    print STDERR "        build\n";
390    print STDERR "        build-missing\n";
391    print STDERR "        upload\n";
392    print STDERR "        wiki     create a download page in MediaWiki syntax\n";
393    print STDERR "    options:\n";
394    print STDERR "    -j <count>    maximum number of build processes\n";
395    print STDERR "    -k            keep going if there are recoverable errors\n";
396    print STDERR "    -u <path>     upload destination\n";
397    print STDERR "    -l            check links on wiki page, write broken links as plain text\n";
398    print STDERR "    -ld           check links on wiki page, mark broken links\n";
399    print STDERR "    -o <filename> filename of the output (wiki: wiki page, build: makefile)\n";
400    print STDERR "    -n <number>   maximal number of upload tries, defaults to 5.\n";
401    print STDERR "    -d            dry run\n";
402    exit(1);
403}
404
405
406
407
408=head2 Trim ($text)
409
410    Remove leading and trailing space from the given string.
411
412=cut
413sub Trim ($)
414{
415    my ($text) = @_;
416    $text =~ s/^\s+|\s+$//g;
417    return $text;
418}
419
420
421
422
423=head2 ReadReleaseDescription ($$)
424
425    Read the release description from $filename.
426
427=cut
428sub ReadReleaseDescription ($$)
429{
430    my ($filename, $context) = @_;
431
432    my $document = XML::LibXML->load_xml('location' => $filename);
433    my $root = $document->documentElement();
434
435    # Initialize the release description.
436    my $release = {
437        'name' => $root->getAttribute("name"),
438        'version' => $root->getAttribute("version"),
439        'previous-version' => $root->getAttribute("previous-version"),
440        'builds' => [],
441        'languages' => {},
442        'language-ids' => [],
443        'platforms' => {},
444        'downloads' => [],
445        'packages' => {},
446        'platform-ids' => [],
447        'wiki-packages' => []
448    };
449
450    # Process the language descriptions.
451    for my $language_element ($root->getChildrenByTagName("language"))
452    {
453        my $language_descriptor = ProcessLanguageDescription($language_element, $context);
454        $release->{'languages'}->{$language_descriptor->{'id'}} = $language_descriptor;
455        push @{$release->{'language-ids'}}, $language_descriptor->{'id'};
456    }
457    printf "%d languages\n", scalar keys %{$release->{'languages'}};
458
459    # Process the platform descriptions.
460    for my $platform_element ($root->getChildrenByTagName("platform"))
461    {
462        my $platform_descriptor = ProcessPlatformDescription($platform_element, $context);
463        $release->{'platforms'}->{$platform_descriptor->{'id'}} = $platform_descriptor;
464        push @{$release->{'platform-ids'}}, $platform_descriptor->{'id'};
465    }
466    printf "%d platforms\n", scalar keys %{$release->{'platforms'}};
467
468    # Process the package descriptions.
469    for my $package_element ($root->getChildrenByTagName("package"))
470    {
471        my $package_descriptor = ProcessPackageDescription($package_element, $context);
472        $release->{'packages'}->{$package_descriptor->{'id'}} = $package_descriptor;
473    }
474    printf "%d packages\n", scalar keys %{$release->{'packages'}};
475
476    # Platform specific the package descriptions.
477    for my $package_element ($root->getChildrenByTagName("platform-package"))
478    {
479        my $package_descriptor = ProcessPlatformPackageDescription($package_element, $context);
480        my $key = $package_descriptor->{'platform-id'} . "/" . $package_descriptor->{'package-id'};
481        $release->{'platform-packages'}->{$key} = $package_descriptor;
482    }
483    printf "%d platform packages\n", scalar keys %{$release->{'platform-packages'}};
484
485    # Process the download descriptions.
486    for my $download_element ($root->getChildrenByTagName("download"))
487    {
488        my $download_descriptor = ProcessDownloadDescription($download_element, $context);
489        push @{$release->{'downloads'}}, $download_descriptor;
490    }
491    printf "%d downloads\n", scalar @{$release->{'downloads'}};
492
493    if ($context->{'command'} =~ /^(build|upload)$/)
494    {
495        # Process the build descriptions.
496        for my $build_element ($root->getChildrenByTagName("build"))
497        {
498            push @{$release->{'builds'}}, ProcessBuildDescription($build_element, $context, $release);
499        }
500        printf "%d build targets\n", scalar @{$release->{'builds'}};
501    }
502
503    if ($context->{'command'} eq "wiki")
504    {
505        for my $wiki_element ($root->getChildrenByTagName("wiki"))
506        {
507            for my $wiki_package_element ($wiki_element->getChildrenByTagName("package-ref"))
508            {
509                my $wiki_package = ProcessWikiPackageDescription(
510                    $wiki_package_element,
511                    $context,
512                    $release);
513                push @{$release->{'wiki-packages'}}, $wiki_package;
514            }
515        }
516        printf "%d wiki packages\n", scalar @{$release->{'wiki-packages'}};
517    }
518
519    return $release;
520}
521
522
523
524
525=head ProcessBuildDescription ($build_element, $context, $release_descriptor)
526
527    Process one <build> element.
528
529    If its platform-list does not match the current platform then the <build> element is ignored.
530
531=cut
532sub ProcessBuildDescription ($$$)
533{
534    my ($build_element, $context, $release_descriptor) = @_;
535
536    my $package_id = $build_element->getAttribute("package-id");
537    my $languages = PostprocessLanguageList($build_element->getAttribute("language-list"), $release_descriptor);
538    my $platforms = PostprocessPlatformList($build_element->getAttribute("platform-list"), $release_descriptor);
539
540    # Check if the platform matches any for which the product shall be built.
541    my $current_platform = $ENV{'INPATH'};
542    my $is_platform_match = 0;
543    foreach my $platform_id (@$platforms)
544    {
545        if ($platform_id eq $current_platform)
546        {
547            $is_platform_match=1;
548            last;
549        }
550    }
551    if ($is_platform_match)
552    {
553        printf "including build %s\n", $package_id;
554    }
555    else
556    {
557        printf "skipping build %s: no platform match\n", $package_id;
558        printf "none of the platforms %s matches %s\n",
559        join(", ", keys %{$release_descriptor->{'platforms'}}),
560        $current_platform;
561        return;
562    }
563
564    my @languages = CheckLanguageSet($context, @$languages);
565
566    return {
567        'package-id' => $package_id,
568        'platform-list' => $platforms,
569        'language-list' => \@languages
570    };
571}
572
573
574
575
576
577=head2 ProcessPlatformDescription ($element, $context)
578
579    Process one <platform> element.
580
581    The corresponding platform descriptor is returned as a hash.
582
583=cut
584sub ProcessPlatformDescription ($$)
585{
586    my ($element, $context) = @_;
587
588    my $descriptor = {};
589    # Mandatory tags.
590    foreach my $id ("id", "display-name", "archive-platform", "word-size", "package-types")
591    {
592        $descriptor->{$id} = $element->getAttribute($id);
593        die "release/platform has no attribute $id" unless defined $descriptor->{$id};
594    }
595    # Optional tags.
596    foreach my $id ("extension", "add-package-type-to-archive-name")
597    {
598        my $value = $element->getAttribute($id);
599        $descriptor->{$id} = $value if defined $value;
600    }
601
602    $descriptor->{'add-package-type-to-archive-name'} = 0
603        unless defined $descriptor->{'add-package-type-to-archive-name'};
604    $descriptor->{'package-types'} = [split(/;/, $descriptor->{'package-types'})];
605
606    return $descriptor;
607}
608
609
610
611
612=head2 ProcessDownloadDescription ($element, $context)
613
614    Process one <download> element.
615
616    The corresponding download descriptor is returned as a hash.
617
618=cut
619sub ProcessDownloadDescription ($$)
620{
621    my ($element, $context) = @_;
622
623    my $descriptor = {};
624
625    # Mandatory tags.
626    foreach my $id ("platform-id", "base-url")
627    {
628        $descriptor->{$id} = $element->getAttribute($id);
629        die "release/download has no attribute $id" unless defined $descriptor->{$id};
630    }
631
632    return $descriptor;
633}
634
635
636
637
638=head2 ProcessPackageDescription ($element, $context)
639
640    Process one <package> element.
641
642    The corresponding package descriptor is returned as a hash.
643
644=cut
645sub ProcessPackageDescription ($$)
646{
647    my ($element, $context) = @_;
648
649    my $descriptor = {};
650
651    # Mandatory tags.
652    foreach my $id ("id", "target", "archive-path", "archive-name", "display-name")
653    {
654        $descriptor->{$id} = $element->getAttribute($id);
655        die "release/package has no attribute $id" unless defined $descriptor->{$id};
656        die "release/package attribute $id is empty" unless $descriptor->{$id} !~ /^\s*$/;
657    }
658    # Optional tags.
659    foreach my $id ("link-tooltip", "link-URL", "download-extension")
660    {
661        my $value = $element->getAttribute($id);
662        $descriptor->{$id} = $value if defined $value;
663    }
664
665    return $descriptor;
666}
667
668
669
670
671=head2 ProcessPlatformPackageDescription ($element, $context)
672
673    Process one <platform-package> element.
674
675    The corresponding package descriptor is returned as a hash.
676
677=cut
678sub ProcessPlatformPackageDescription ($$)
679{
680    my ($element, $context) = @_;
681
682    my $descriptor = {};
683
684    # Mandatory tags.
685    foreach my $id ("platform-id", "package-id")
686    {
687        $descriptor->{$id} = $element->getAttribute($id);
688        die "release/package has no attribute $id" unless defined $descriptor->{$id};
689        die "release/package attribute $id is empty" unless $descriptor->{$id} !~ /^\s*$/;
690    }
691    # Optional tags.
692    foreach my $id ("extension", "package-types")
693    {
694        my $value = $element->getAttribute($id);
695        $descriptor->{$id} = $value if defined $value;
696    }
697    if (defined $descriptor->{'package-types'})
698    {
699        $descriptor->{'package-types'} = [split(/;/, $descriptor->{'package-types'})];
700    }
701
702    return $descriptor;
703}
704
705
706
707
708=head2 ProcessWikiPackageDescription ($element, $context)
709
710    Process one <wiki><package-ref> element.
711
712    The corresponding descriptor is returned as a hash.
713
714=cut
715sub ProcessWikiPackageDescription ($$$)
716{
717    my ($element, $context, $release_descriptor) = @_;
718
719    my $descriptor = {};
720    # Mandatory tags.
721    foreach my $id ("package-id", "table")
722    {
723        $descriptor->{$id} = $element->getAttribute($id);
724        die "wiki/package-ref has no attribute $id" unless defined $descriptor->{$id};
725        die "wiki/package-ref attribute $id is empty" unless $descriptor->{$id} !~ /^\s*$/;
726    }
727
728    $descriptor->{'language-list'} = PostprocessLanguageList(
729        $element->getAttribute("language-list"),
730        $release_descriptor);
731    $descriptor->{'platform-list'} = PostprocessPlatformList(
732        $element->getAttribute("platform-list"),
733        $release_descriptor);
734
735    $descriptor->{'languages'} = {map{$_=>1} @{$descriptor->{'language-list'}}};
736    $descriptor->{'platforms'} = {map{$_=>1} @{$descriptor->{'platform-list'}}};
737
738    return $descriptor;
739}
740
741
742
743
744=head2 ProcessLanguageDescription ($element, $context)
745
746    Process one <language> element.
747
748    The corresponding language descriptor is returned as a hash.
749
750=cut
751sub ProcessLanguageDescription ($$)
752{
753    my ($element, $context) = @_;
754
755    my $descriptor = {};
756    foreach my $id ("id", "english-name", "local-name")
757    {
758        $descriptor->{$id} = $element->getAttribute($id);
759        die "wiki/language has no attribute $id" unless defined $descriptor->{$id};
760    }
761
762    return $descriptor;
763}
764
765
766
767
768=head2 PostprocessLanguageList ($language_list, $release_descriptor)
769
770    Process a language list that is given as 'language-list' attribute to some tags.
771
772    If the attribute is missing, ie $language_list is undef, or its value is "all",
773    then the returned list of languages is set to all languages defined via <language> elements.
774
775=cut
776sub PostprocessLanguageList ($$)
777{
778    my ($language_list, $release_descriptor) = @_;
779
780    my @matching_languages = ();
781    if ( ! defined $language_list
782        || $language_list eq "all")
783    {
784        @matching_languages = sort keys %{$release_descriptor->{'languages'}};
785    }
786    else
787    {
788        @matching_languages = split(/;/, $language_list);
789    }
790
791    return \@matching_languages;
792}
793
794
795
796
797=head2 PostprocessPlatformList ($platform_list, $release_descriptor)
798
799    Process a platform list that is given as 'platform-list' attribute to some tags.
800
801    If the attribute is missing, ie $platform_list is undef, or its value is "all",
802    then the returned list of platforms is set to all platforms defined via <platform> elements.
803
804=cut
805sub PostprocessPlatformList ($$)
806{
807    my ($platform_list, $release_descriptor) = @_;
808
809    my @matching_platforms = ();
810    if ( ! defined $platform_list
811        || $platform_list eq "all")
812    {
813        @matching_platforms = sort keys %{$release_descriptor->{'platforms'}};
814    }
815    else
816    {
817        @matching_platforms = split(/;/, $platform_list);
818    }
819
820    return \@matching_platforms;
821}
822
823
824
825
826=head2 CheckLanguageSet ($context, @languages)
827
828    Compare the given list of languages with the one defined by the 'WITH_LANG' environment variable.
829
830    This is to ensure that configure --with-lang was called with the same set of languages that are
831    listed by the <language> elements.
832
833=cut
834sub CheckLanguageSet ($@)
835{
836    my ($context, @languages) = @_;
837    my %configured_languages = map{$_=>1} split(/\s+/, $ENV{'WITH_LANG'});
838
839    my @missing_languages = ();
840    my @present_languages = ();
841    for my $language (@languages)
842    {
843        if (defined $configured_languages{$language})
844        {
845            push @present_languages, $language;
846        }
847        else
848        {
849            push @missing_languages, $language;
850        }
851    }
852
853    if (scalar @missing_languages > 0)
854    {
855        my $message_head = $context->{'keep-going'} ? "WARNING" : "ERROR";
856        printf STDERR "%s: there are languages that where not configured via --with-lang:\n", $message_head;
857        printf STDERR "%s:     %s\n", $message_head, join(", ", @missing_languages);
858        if ($context->{'keep-going'})
859        {
860            printf "    available languages:\n";
861            printf "        %s\n", join(", ", @present_languages);
862        }
863        else
864        {
865            printf STDERR "ERROR: please rerun configure with --with-lang=\"%s\"\n", join(" ", @languages);
866            exit(1);
867        }
868    }
869
870    return @present_languages;
871}
872
873
874
875
876=head2 WriteMakefile ($release_descriptor, $context)
877
878    Write a makefile with all targets that match the <build> elements.
879
880    The use of a makefile allows us to use make to handle concurrent building.
881
882    When an output file was specified on the command line (option -o) then the
883    makefile is written to that file but make is not run.
884
885    When no output file was specified then the makefile is written to a temporary
886    file.  Then make is run for this makefile.
887
888=cut
889sub WriteMakefile ($$)
890{
891    my ($release_descriptor, $context) = @_;
892
893    my $filename = $context->{'output-filename'};
894    if ( ! defined $filename)
895    {
896        $filename = File::Temp->new();
897    }
898
899    # Collect the targets to make.
900    my @targets = ();
901    foreach my $build (@{$release_descriptor->{'builds'}})
902    {
903        my $platform_descriptor = GetCurrentPlatformDescriptor($release_descriptor);
904        my $package_descriptor = $release_descriptor->{'packages'}->{$build->{'package-id'}};
905        my $platform_package_descriptor = GetPlatformPackage(
906            $release_descriptor,
907            $platform_descriptor,
908            $package_descriptor);
909
910        foreach my $language_id (@{$build->{'language-list'}})
911        {
912            foreach my $package_format (@{$platform_package_descriptor->{'package-types'}})
913            {
914                my $full_target = sprintf("%s_%s.%s",
915                    $package_descriptor->{'target'},
916                    $language_id,
917                    $package_format);
918                if ($context->{'build-only-missing'})
919                {
920                    my ($archive_path, $archive_name) = GetInstallationPackageName(
921                        $release_descriptor,
922                        $platform_package_descriptor,
923                        $package_format,
924                        $language_id);
925                    my $candidate = $archive_path . "/" . $archive_name;
926                    if (-f $candidate)
927                    {
928                        printf "download set for %s already exists, skipping\n", $full_target;
929                        next;
930                    }
931                    else
932                    {
933                        printf "%s  %s\n", $archive_path, $archive_name;
934                    }
935                }
936                push @targets, $full_target;
937            }
938        }
939    }
940
941    # Write the makefile.
942    open my $make, ">", $filename;
943
944    # Write dependencies of 'all' on the products in all languages.
945    print $make "all .PHONY : \\\n    ";
946    printf $make "%s\n", join(" \\\n    ", @targets);
947    printf $make "\n\n";
948
949    if ($context->{'dry-run'})
950    {
951        printf ("adding make fules for\n    %s\n", join("\n    ", @targets));
952    }
953
954    # Write rules that chain dmake in instsetoo_native/util.
955    foreach my $target (@targets)
956    {
957        printf $make "%s :\n", $target;
958        printf $make "\tdmake \$@ release=t\n";
959    }
960    close $make;
961
962
963    if ( ! defined $context->{'output-filename'})
964    {
965        # Caller wants us to run make.
966        my $path = $ENV{'SRC_ROOT'} . "/instsetoo_native/util";
967        my $command = sprintf("make -f \"%s\" -C \"%s\" -j%d",
968            $filename,
969            $path,
970            $context->{'max-process-count'});
971        if ($context->{'dry-run'})
972        {
973            printf "would run %s\n", $command;
974        }
975        else
976        {
977            printf "running %s\n", $command;
978            system($command);
979        }
980    }
981}
982
983
984
985
986sub Upload ($$)
987{
988    my ($release_descriptor, $context) = @_;
989
990    if ( ! defined $context->{'upload-destination'})
991    {
992        printf STDERR "ERROR: upload destination is missing\n";
993        PrintUsageAndExit();
994    }
995
996    my @download_sets = CollectDownloadSets($release_descriptor);
997
998    ProvideChecksums($context, @download_sets);
999    my $source_path = PrepareUploadArea($context, @download_sets);
1000    if ( ! defined $source_path)
1001    {
1002        exit(1);
1003    }
1004    if ( ! UploadFilesViaRsync($context, $source_path, @download_sets))
1005    {
1006        exit(1);
1007    }
1008}
1009
1010
1011
1012
1013=head2 PrepareUploadArea ($context, @download_sets)
1014
1015    Create a temporary directory with the same sub directory strcuture that is requested in the upload location.
1016    The files that are to be uploaded are not copied but linked into this temporary directory tree.
1017
1018    Returns the name of the temporary directory.
1019
1020=cut
1021sub PrepareUploadArea ($@)
1022{
1023    my ($context, @download_sets) = @_;
1024
1025    my $tmpdir = File::Temp->newdir();
1026    foreach my $download_set (@download_sets)
1027    {
1028        foreach my $extension ("", ".md5", ".sha256", ".asc")
1029        {
1030            my $basename = sprintf("%s%s", $download_set->{'archive-name'}, $extension);
1031            my $source_path = $download_set->{'source-path'};
1032            my $source = sprintf("%s/%s", $source_path, $basename);
1033            my $target_path = sprintf("%s/%s", $tmpdir, $download_set->{'destination-path'});
1034            my $target = sprintf("%s/%s", $target_path, $basename);
1035            if ($context->{'dry-run'})
1036            {
1037                printf "would create link for %s\n", $basename;
1038                printf "    %s\n", $source_path;
1039                printf " to %s\n", $target_path;
1040            }
1041            else
1042            {
1043                mkpath($target_path);
1044                unlink $target if ( -f $target);
1045                my $result = symlink($source, $target);
1046                if ($result != 1)
1047                {
1048                    printf "ERROR: can not created symbolic link to %s\n", $basename;
1049                    printf "       %s\n", $source;
1050                    printf "    -> %s\n", $target;
1051                    return undef;
1052                }
1053            }
1054        }
1055    }
1056
1057    return $tmpdir;
1058}
1059
1060
1061
1062
1063sub UploadFilesViaRsync ($$@)
1064{
1065    my ($context, $source_path, @download_sets) = @_;
1066
1067
1068    # Collect the rsync flags.
1069    my @rsync_options = (
1070        "-L",         # Copy linked files
1071        "-a",         # Transfer the local attributes and modification times.
1072        "-c",         # Use checksums to compare source and destination files.
1073        "--progress", # Show a progress indicator
1074        "--partial",  # Try to resume a previously failed upload
1075        );
1076
1077    # (Optional) Add flags for upload to ssh server
1078    my $upload_destination = $context->{'upload-destination'};
1079    if ($upload_destination =~ /@/)
1080    {
1081        push @rsync_options, ("-e", "ssh");
1082    }
1083
1084    # Set up the rsync command.
1085    my $command = sprintf("rsync %s \"%s/\" \"%s\"",
1086        join(" ", @rsync_options),
1087        $source_path,
1088        $upload_destination);
1089    printf "%s\n", $command;
1090
1091    if ($context->{'dry-run'})
1092    {
1093        printf "would run %s up to %d times\n", $command, $context->{'max-upload-count'};
1094    }
1095    else
1096    {
1097        # Run the command.  If it fails, repeat a number of times.
1098        my $max_run_count = $context->{'max-upload-count'};
1099        for (my $run_index=1; $run_index<=$max_run_count && scalar @download_sets>0; ++$run_index)
1100        {
1101            my $result = system($command);
1102            printf "%d %d\n", $result, $?;
1103            return 1 if $result == 0;
1104        }
1105        printf "ERROR: could not upload all files without error in %d runs\n", $max_run_count;
1106        return 0;
1107    }
1108}
1109
1110
1111
1112
1113sub CollectDownloadSets ($)
1114{
1115    my ($release_descriptor) = @_;
1116
1117    my @download_sets = ();
1118
1119    foreach my $platform_descriptor (values %{$release_descriptor->{'platforms'}})
1120    {
1121        my $platform_path = sprintf("%s/instsetoo_native/%s",
1122            $ENV{'SOLARSRC'},
1123            $platform_descriptor->{'id'});
1124        if ( ! -d $platform_path)
1125        {
1126            printf "ignoring missing %s\n", $platform_path;
1127            next;
1128        }
1129        for my $package_descriptor (values %{$release_descriptor->{'packages'}})
1130        {
1131            my $platform_package_descriptor = GetPlatformPackage(
1132                $release_descriptor,
1133                $platform_descriptor,
1134                $package_descriptor);
1135            my @package_formats = @{$platform_descriptor->{'package-types'}};
1136            for my $package_format (@package_formats)
1137            {
1138                for my $language_id (@{$release_descriptor->{'language-ids'}})
1139                {
1140                    my ($archive_path, $archive_name) = GetInstallationPackageName(
1141                        $release_descriptor,
1142                        $platform_package_descriptor,
1143                        $package_format,
1144                        $language_id);
1145                    my $candidate = $archive_path."/".$archive_name;
1146                    if ( ! -f $candidate)
1147                    {
1148#                        printf STDERR "ERROR: can not find download set '%s'\n", $candidate;
1149                        next;
1150                    }
1151                    printf "adding %s\n", $archive_name;
1152                    my $download_set = {
1153                        'source-path' => $archive_path,
1154                        'archive-name' => $archive_name,
1155                        'platform' => $platform_descriptor->{'archive-platform'},
1156                        'destination-path' => sprintf("developer-snapshots/%s/%s",
1157                            $release_descriptor->{'name'},
1158                            $platform_descriptor->{'archive-platform'})
1159                    };
1160                    printf "    %s\n", $download_set->{'destination-path'};
1161                    push @download_sets, $download_set;
1162                }
1163            }
1164        }
1165    }
1166
1167    return @download_sets;
1168}
1169
1170
1171
1172
1173=head2 ProvideChecksums ($context, @download_sets)
1174
1175    Create checksums in MD5 and SHA256 format and a gpg signature for the given download set.
1176    The checksums are not created when they already exists and are not older than the download set.
1177
1178=cut
1179sub ProvideChecksums ($@)
1180{
1181    my ($context, @download_sets) = @_;
1182
1183    my @asc_requests = ();
1184    foreach my $download_set (@download_sets)
1185    {
1186        printf "%s\n", $download_set->{'archive-name'};
1187        my $full_archive_name = $download_set->{'source-path'} . "/" . $download_set->{'archive-name'};
1188        $full_archive_name = Trim(qx(cygpath -u "$full_archive_name"));
1189
1190        my $md5_filename = $full_archive_name . ".md5";
1191        if ( ! -f $md5_filename || IsOlderThan($md5_filename, $full_archive_name))
1192        {
1193            if ($context->{'dry-run'})
1194            {
1195                printf "    would create MD5\n";
1196            }
1197            else
1198            {
1199                my $digest = Digest::MD5->new();
1200                open my ($in), $full_archive_name;
1201                $digest->addfile($in);
1202                my $checksum = $digest->hexdigest();
1203                close $in;
1204
1205                open my ($out), ">", $md5_filename;
1206                printf $out "%s *%s", $checksum, $download_set->{'archive-name'};
1207                close $out;
1208
1209                printf "    created MD5\n";
1210            }
1211        }
1212        else
1213        {
1214            printf "    MD5 already exists\n";
1215        }
1216
1217        my $sha256_filename = $full_archive_name . ".sha256";
1218        if ( ! -f $sha256_filename || IsOlderThan($sha256_filename, $full_archive_name))
1219        {
1220            if ($context->{'dry-run'})
1221            {
1222                printf "    would create SHA256\n";
1223            }
1224            else
1225            {
1226                my $digest = Digest::SHA->new("sha256");
1227                open my ($in), $full_archive_name;
1228                $digest->addfile($in);
1229                my $checksum = $digest->hexdigest();
1230                close $in;
1231
1232                open my ($out), ">", $sha256_filename;
1233                printf $out "%s *%s", $checksum, $download_set->{'archive-name'};
1234                close $out;
1235
1236                printf "    created SHA256\n";
1237            }
1238        }
1239        else
1240        {
1241            printf "    SHA256 already exists\n";
1242        }
1243
1244        my $asc_filename = $full_archive_name . ".asc";
1245        if ( ! -f $asc_filename || IsOlderThan($asc_filename, $full_archive_name))
1246        {
1247            if ($context->{'dry-run'})
1248            {
1249                printf "    would create ASC\n";
1250            }
1251            else
1252            {
1253                # gpg seems not to be able to sign more than one file at a time.
1254                # Password has to be provided every time.
1255                my $command = sprintf("gpg --armor --detach-sig \"%s\"", $full_archive_name);
1256                print $command;
1257                my $result = system($command);
1258                printf "    created ASC\n";
1259            }
1260        }
1261        else
1262        {
1263            printf "    ASC already exists\n";
1264        }
1265    }
1266}
1267
1268
1269
1270
1271=head2 IsOlderThan ($filename1, $filename2)
1272
1273    Return true (1) if the last modification date of $filename1 is older than (<) that of $filename2.
1274
1275=cut
1276sub IsOlderThan ($$)
1277{
1278    my ($filename1, $filename2) = @_;
1279
1280    my @stat1 = stat $filename1;
1281    my @stat2 = stat $filename2;
1282
1283    return $stat1[9] < $stat2[9];
1284}
1285
1286
1287
1288
1289sub GetInstallationPackageName ($$$$)
1290{
1291    my ($release_descriptor, $platform_package_descriptor, $package_format, $language) = @_;
1292
1293    my $path = ResolveTemplate(
1294        $platform_package_descriptor->{'archive-path'},
1295        $release_descriptor,
1296        $platform_package_descriptor,
1297        $package_format,
1298        $language);
1299    my $name = ResolveTemplate(
1300        $platform_package_descriptor->{'archive-name'},
1301        $release_descriptor,
1302        $platform_package_descriptor,
1303        $package_format,
1304        $language);
1305
1306    return ($path, $name);
1307}
1308
1309
1310
1311
1312sub ResolveTemplate ($$$$$)
1313{
1314    my ($template, $release_descriptor, $platform_package_descriptor, $package_format, $language) = @_;
1315
1316    my $archive_package_type = "";
1317    if ($platform_package_descriptor->{'add-package-type-to-archive-name'} =~ /^(1|true|yes)$/i)
1318    {
1319        $archive_package_type = "-".$package_format;
1320    }
1321    my $full_language = $language;
1322    if ($EnUSBasedLanguages{$language})
1323    {
1324        $full_language = "en-US_".$language;
1325    }
1326    my $extension = $platform_package_descriptor->{'download-extension'};
1327    if ( ! defined $extension)
1328    {
1329        $extension = $platform_package_descriptor->{'extension'};
1330    }
1331
1332    my $old_to_new_version_dash = sprintf(
1333        "v-%s_v-%s",
1334        $release_descriptor->{'previous-version'},
1335        $release_descriptor->{'version'});
1336    $old_to_new_version_dash =~ s/\./-/g;
1337    my $old_to_new_version_dots = sprintf(
1338        "%s-%s",
1339        $release_descriptor->{'previous-version'},
1340        $release_descriptor->{'version'});
1341
1342
1343    my $name = $template;
1344
1345    # Resolve %? template paramters.
1346    $name =~ s/%V/$release_descriptor->{'version'}/g;
1347    $name =~ s/%W/$old_to_new_version_dash/g;
1348    $name =~ s/%w/$old_to_new_version_dots/g;
1349    $name =~ s/%P/$platform_package_descriptor->{'archive-platform'}/g;
1350    $name =~ s/%t/$archive_package_type/g;
1351    $name =~ s/%T/$package_format/g;
1352    $name =~ s/%l/$full_language/g;
1353    $name =~ s/%L/$language/g;
1354    $name =~ s/%E/$extension/g;
1355
1356    # Resolve $name environment references.
1357    while ($name =~ /^(.*?)\$([a-zA-Z0-9_]+)(.*)$/)
1358    {
1359        $name = $1 . $ENV{$2} . $3;
1360    }
1361
1362    return $name;
1363}
1364
1365
1366
1367
1368sub GetCurrentPlatformDescriptor ($)
1369{
1370    my ($release_descriptor) = @_;
1371
1372    my $platform_descriptor = $release_descriptor->{'platforms'}->{$ENV{'INPATH'}};
1373    if ( ! defined $platform_descriptor)
1374    {
1375        printf STDERR "ERROR: platform '%s' is not supported\n", $ENV{'INPATH'};
1376    }
1377    return $platform_descriptor;
1378}
1379
1380
1381
1382
1383sub GetPlatformPackage ($$$)
1384{
1385    my ($release_descriptor, $platform_descriptor, $package_descriptor) = @_;
1386    my $key = sprintf("%s/%s", $platform_descriptor->{'id'}, $package_descriptor->{'id'});
1387
1388    my $platform_package = $release_descriptor->{'platform-packages'}->{$key};
1389    $platform_package = {}
1390        unless defined $platform_package;
1391
1392    my $joined_descriptor = {
1393        %$platform_descriptor,
1394        %$package_descriptor,
1395        %$platform_package,
1396        'id' => $key,
1397        'platform-id' => $platform_descriptor->{'id'},
1398        'package-id' => $package_descriptor->{'id'}
1399    };
1400    return $joined_descriptor;
1401}
1402
1403
1404
1405
1406sub Wiki ($$)
1407{
1408    my ($release_descriptor, $context) = @_;
1409
1410    open my $out, ">", $context->{'output-filename'};
1411
1412    my @table_list = GetTableList($release_descriptor);
1413    foreach my $table_name (@table_list)
1414    {
1415        my @table_packages = GetPackagesForTable($release_descriptor, $table_name);
1416        my @table_languages = GetLanguagesForTable($release_descriptor, @table_packages);
1417        my @table_platforms = GetPlatformsForTable($release_descriptor, @table_packages);
1418
1419        printf "packages: %s\n", join(", ", map {$_->{'package'}->{'display-name'}} @table_packages);
1420        printf "languages: %s\n", join(", ", map {$_->{'english-name'}} @table_languages);
1421        printf "platforms: %s\n", join(", ", map {$_->{'id'}} @table_platforms);
1422
1423        print $out "{| class=\"wikitable\"\n";
1424
1425        # Write the table head.
1426        print $out "|-\n";
1427        print $out "! colspan=\"2\" | Language<br>The names do not refer to countries\n";
1428        print $out "! Type\n";
1429        foreach my $platform_descriptor (@table_platforms)
1430        {
1431            foreach my $package_type (@{$platform_descriptor->{'package-types'}})
1432            {
1433                printf $out "! %s<br>%s bit<br>%s\n",
1434                $platform_descriptor->{'display-name'},
1435                $platform_descriptor->{'word-size'},
1436                uc($package_type);
1437            }
1438        }
1439
1440        foreach my $language_descriptor (@table_languages)
1441        {
1442            if ($context->{'check-links'})
1443            {
1444                $| = 1;
1445                printf "%-5s: ", $language_descriptor->{'id'};
1446            }
1447
1448            print $out "|-\n";
1449            printf $out "| rowspan=\"%d\" | %s\n", scalar @table_packages, $language_descriptor->{'english-name'};
1450            printf $out "| rowspan=\"%d\" | %s\n", scalar @table_packages, $language_descriptor->{'local-name'};
1451
1452            my $is_first = 1;
1453            foreach my $wiki_package_descriptor (@table_packages)
1454            {
1455                my $package_descriptor = $wiki_package_descriptor->{'package'};
1456
1457                if ($is_first)
1458                {
1459                    $is_first = 0;
1460                }
1461                else
1462                {
1463                    printf $out "|-\n";
1464                }
1465
1466                # Write the name of the package, e.g. Full Install or Langpack.
1467                if (defined $package_descriptor->{'link-URL'})
1468                {
1469                    printf $out "| [%s %s]\n",
1470                    $package_descriptor->{'link-URL'},
1471                    $package_descriptor->{'display-name'};
1472                }
1473                else
1474                {
1475                    printf $out "| %s\n", $package_descriptor->{'display-name'};
1476                }
1477
1478                foreach my $platform_descriptor (@table_platforms)
1479                {
1480                    my $platform_package_descriptor = GetPlatformPackage(
1481                        $release_descriptor,
1482                        $platform_descriptor,
1483                        $package_descriptor);
1484
1485                    foreach my $package_type (@{$platform_package_descriptor->{'package-types'}})
1486                    {
1487                        WriteDownloadLinks(
1488                            $out,
1489                            $release_descriptor,
1490                            $context,
1491                            $language_descriptor,
1492                            $wiki_package_descriptor,
1493                            $platform_package_descriptor,
1494                            $package_type);
1495                    }
1496                }
1497            }
1498
1499            if ($context->{'check-links'})
1500            {
1501                printf "\n";
1502            }
1503        }
1504
1505        print $out "|}\n";
1506    }
1507    close $out;
1508}
1509
1510
1511
1512
1513sub GetTableList ($)
1514{
1515    my ($release_descriptor) = @_;
1516
1517    my %seen_table_names = ();
1518    my @table_names = ();
1519    foreach my $wiki_package_descriptor (@{$release_descriptor->{'wiki-packages'}})
1520    {
1521        my $table_name = $wiki_package_descriptor->{'table'};
1522        if ( ! $seen_table_names{$table_name})
1523        {
1524            push @table_names, $table_name;
1525            $seen_table_names{$table_name} = 1;
1526        }
1527    }
1528    return @table_names;
1529}
1530
1531
1532
1533
1534sub GetPackagesForTable ($$)
1535{
1536    my ($release_descriptor, $table_name) = @_;
1537
1538    my @packages = ();
1539    foreach my $wiki_package_descriptor (@{$release_descriptor->{'wiki-packages'}})
1540    {
1541        if ($wiki_package_descriptor->{'table'} eq $table_name)
1542        {
1543            my $package_descriptor = $release_descriptor->{'packages'}->{
1544                $wiki_package_descriptor->{'package-id'}};
1545            $wiki_package_descriptor->{'package'} = $package_descriptor;
1546            push @packages, $wiki_package_descriptor;
1547        }
1548    }
1549    return @packages;
1550}
1551
1552
1553
1554
1555sub GetLanguagesForTable ($@)
1556{
1557    my ($release_descriptor, @packages) = @_;
1558
1559    # Find the languages that are reference by at least one package.
1560    my %matching_languages = ();
1561    foreach my $package_descriptor (@packages)
1562    {
1563        foreach my $language_id (@{$package_descriptor->{'language-list'}})
1564        {
1565            $matching_languages{$language_id} = 1;
1566        }
1567    }
1568
1569    # Retrieve the language descriptors for the language ids.
1570    my @matching_language_descriptors = ();
1571    foreach my $language_id (@{$release_descriptor->{'language-ids'}})
1572    {
1573        if (defined $matching_languages{$language_id})
1574        {
1575            my $language_descriptor = $release_descriptor->{'languages'}->{$language_id};
1576            if (defined $language_descriptor)
1577            {
1578                push @matching_language_descriptors, $language_descriptor;
1579            }
1580        }
1581    }
1582
1583    return @matching_language_descriptors;
1584}
1585
1586
1587
1588
1589sub GetPlatformsForTable ($@)
1590{
1591    my ($release_descriptor, @packages) = @_;
1592
1593    # Find the platforms that are reference by at least one package.
1594    my %matching_platform_ids = ();
1595    foreach my $package_descriptor (@packages)
1596    {
1597        foreach my $platform_id (@{$package_descriptor->{'platform-list'}})
1598        {
1599            $matching_platform_ids{$platform_id} = 1;
1600        }
1601    }
1602
1603    # Retrieve the platform descriptors for the plaform ids.
1604    my @matching_platform_descriptors = ();
1605    foreach my $platform_id (@{$release_descriptor->{'platform-ids'}})
1606    {
1607        if ($matching_platform_ids{$platform_id})
1608        {
1609	    print $platform_id."\n";
1610            push @matching_platform_descriptors, $release_descriptor->{'platforms'}->{$platform_id};
1611        }
1612    }
1613
1614    return @matching_platform_descriptors;
1615}
1616
1617
1618
1619
1620my $bold_text_start = "<b>";
1621my $bold_text_end = "</b>";
1622my $small_text_start = "<span style=\"font-size:80%\">";
1623my $small_text_end = "</span>";
1624my $broken_link_start = "<span style=\"color:#FF0000\">";
1625my $broken_link_end = "</span>";
1626
1627
1628sub WriteDownloadLinks ($$$$$$$)
1629{
1630    my ($out,
1631        $release_descriptor,
1632        $context,
1633        $language_descriptor,
1634        $wiki_package_descriptor,
1635        $platform_package_descriptor,
1636        $package_type) = @_;
1637
1638    # Check if the current language and platform match the package.
1639    my $platform_id = $platform_package_descriptor->{'platform-id'};
1640    if (defined $wiki_package_descriptor->{'platforms'}->{$platform_id}
1641        && defined $wiki_package_descriptor->{'languages'}->{$language_descriptor->{'id'}})
1642    {
1643        my $archive_package_name = "";
1644        my $extension = $package_type;
1645        if (defined $platform_package_descriptor->{'extension'})
1646        {
1647            $extension = $platform_package_descriptor->{'extension'};
1648        }
1649        if (defined $platform_package_descriptor->{'download-extension'})
1650        {
1651            $extension = $platform_package_descriptor->{'download-extension'};
1652        }
1653        $archive_package_name = "-".$package_type if ($package_type =~ /deb|rpm/);
1654
1655        my ($archive_path, $archive_name) = GetInstallationPackageName(
1656            $release_descriptor,
1657            $platform_package_descriptor,
1658            $package_type,
1659            $language_descriptor->{'id'});
1660
1661        printf $out "| align=\"center\" | ";
1662        my $download = FindDownload(
1663            $context,
1664            $release_descriptor,
1665            $platform_package_descriptor,
1666            $package_type,
1667            $archive_name);
1668        if (defined $download)
1669        {
1670            my $url = $download->{'base-url'} . "/". $archive_name;
1671            printf $out "%s%s%s<br><br>%s%s %s<br>%s%s",
1672            $bold_text_start,
1673            CreateLink($url, $extension, $context),
1674            $bold_text_end,
1675            $small_text_start,
1676            CreateLink($url.".asc", "ASC", $context),
1677            CreateLink($url.".md5", "MD5", $context),
1678            CreateLink($url.".sha256", "SHA256", $context),
1679            $small_text_end;
1680        }
1681        printf $out "\n";
1682    }
1683    else
1684    {
1685        printf $out "|\n";
1686    }
1687}
1688
1689
1690
1691
1692sub FindDownload ($$$$$)
1693{
1694    my ($context,
1695        $release_descriptor,
1696        $platform_package_descriptor,
1697        $package_type,
1698        $archive_name) = @_;
1699
1700    foreach my $download (@{$release_descriptor->{'downloads'}})
1701    {
1702        if ($download->{'platform-id'} eq $platform_package_descriptor->{'platform-id'})
1703        {
1704            my $url = $download->{'base-url'} . "/". $archive_name;
1705            if ($context->{'check-links'})
1706            {
1707                if (CheckLink($url))
1708                {
1709                    # URL points to an existing file.
1710                    printf "+";
1711                    return $download;
1712                }
1713                else
1714                {
1715                    # URL is broken.
1716                    # Try the next download area for the platform.
1717                    next;
1718                }
1719            }
1720            else
1721            {
1722                # Use the URL unchecked.  If there is more than one download area for the platform then only
1723                # the first is ever used.
1724                printf ".";
1725                return $download;
1726            }
1727        }
1728    }
1729
1730    if ($context->{'check-links'})
1731    {
1732        printf "-";
1733    }
1734
1735    return undef;
1736}
1737
1738
1739
1740
1741sub CreateLink ($$$)
1742{
1743    my ($url, $text, $context) = @_;
1744
1745    my $is_link_broken = 0;
1746    if ($context->{'check-links'})
1747    {
1748        if (CheckLink($url))
1749        {
1750            $is_link_broken = 0;
1751            printf "+";
1752        }
1753        else
1754        {
1755            $is_link_broken = 1;
1756            printf "-";
1757        }
1758    }
1759    else
1760    {
1761        printf ".";
1762    }
1763
1764    if ( ! $is_link_broken)
1765    {
1766        return sprintf ("[%s %s]", $url, $text);
1767    }
1768    elsif ($context->{'mark-broken-links'})
1769    {
1770        return sprintf ("%sbroken%s[%s %s]", $broken_link_start, $broken_link_end, $url, $text);
1771    }
1772    else
1773    {
1774        return sprintf ("%s", $text);
1775    }
1776}
1777
1778
1779
1780
1781=head2 CheckLink ($url)
1782
1783    Check if the file referenced by $url can be downloaded.
1784    This is determined by downloading only the header.
1785
1786=cut
1787my $LastCheckedURL = "";
1788my $LastCheckedResult = undef;
1789sub CheckLink ($)
1790{
1791    my ($url) = @_;
1792
1793    if ($url ne $LastCheckedURL)
1794    {
1795        my $head = LWP::Simple::head($url);
1796        $LastCheckedURL = $url;
1797        $LastCheckedResult = !!$head;
1798    }
1799
1800    return $LastCheckedResult;
1801}
1802
1803
1804
1805
1806sub SignFile ($$)
1807{
1808    my ($signature, $filename) = @_;
1809
1810    my $command = sprintf(
1811        "gpg --armor --output %s.asc --detach-sig %s",
1812        $filename,
1813        $filename);
1814}
1815
1816
1817
1818
1819my $context = ProcessCommandline(@ARGV);
1820my $release_descriptor = ReadReleaseDescription($context->{'filename'}, $context);
1821if ($context->{'command'} eq "build")
1822{
1823    WriteMakefile($release_descriptor, $context);
1824}
1825elsif ($context->{'command'} eq "upload")
1826{
1827    Upload($release_descriptor, $context);
1828}
1829elsif ($context->{'command'} eq "wiki")
1830{
1831    Wiki($release_descriptor, $context);
1832}
1833