#!/usr/bin/perl
#**************************************************************
#  
#  Licensed to the Apache Software Foundation (ASF) under one
#  or more contributor license agreements.  See the NOTICE file
#  distributed with this work for additional information
#  regarding copyright ownership.  The ASF licenses this file
#  to you under the Apache License, Version 2.0 (the
#  "License"); you may not use this file except in compliance
#  with the License.  You may obtain a copy of the License at
#  
#    http://www.apache.org/licenses/LICENSE-2.0
#  
#  Unless required by applicable law or agreed to in writing,
#  software distributed under the License is distributed on an
#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
#  KIND, either express or implied.  See the License for the
#  specific language governing permissions and limitations
#  under the License.
#  
#**************************************************************

use strict;
use warnings;
use XML::LibXML;
use open OUT => ":utf8";
use LWP::Simple;
use Digest;
use Digest::MD5;
use Digest::SHA;
use File::Temp;
use File::Path;

use Carp::always;

=head1 NAME

    build_release.pl - Tool for batch release builds and uploads and the creation of wiki pages that list install sets.

=head1 SYNOPSIS

    build_release.pl <command> {option} <release-description.xml>
    
    comands:
        build      builds all install sets as requested by the XML file and supported by the platform.
        build-missing
                   build only those install sets that have not been built earlier.
        upload     upload install sets to a local or remote (via ssh with public/private key)
                   directory structure.  Uploads install sets that where build on other platforms.
        wiki       create a wiki (MediaWiki syntax) snippet that references all install sets at the upload
                   location.  Includes install sets that where built and/or uploaded from other
                   platforms and machines.
    options:
        -j <count>    maximum number of build processes
        -k            keep going if there are recoverable errors
        -u <path>     upload destination
        -l            check links on wiki page, write broken links as plain text
        -ld           check links on wiki page, mark broken links
        -o <filename> filename of the output (wiki: wiki page, build: makefile)
        -n <number>   maximal number of upload tries, defaults to 5.
        -d            dry-run

    Typical calls are:
       build_release.pl build -j4 instsetoo_native/util/aoo-410-release.xml
           for building the installation sets, language packs and patches for the 4.1 release.
    
       build_release.pl upload -u me@server:path -n 3 instsetoo_native/util/aoo-410-release.xml
           to upload the previously built installation sets etc.

       build_release.pl wiki -o /tmp/wiki.txt instsetoo_native/util/aoo-410-release.xml
           to create an updated wiki page with installation sets etc built at several
           places and uploaded to several locations.

    
=head1 XML file format

The release description could look like this:

<release 
    name="snapshot"
    version="4.1.0">

    <language
        id="ast"                            # As specified by 'configure --with-lang'
        english-name="Asturian"
        local-name="Asturianu"
        />
    ... more languages
    
    <platform
        id="wntmsci12.pro"
        display-name="Windows"
        archive-platform="Win_x86"
        word-size="32"
        package-types="msi"
        extension="exe"
        />
    ... more platforms

    <download
        platform-id="wntmsci12.pro"
        base-url="http://people.apache.org/~somebody/developer-snapshots/snapshot/win32"
        />

    <package
        id="openoffice"
        target="openoffice"
        display-name="Full Install"
        archive-name="Apache_OpenOffice_%V_%P_install%T_%L.%E"
        />

    <build
        package-id="openoffice"
        platform-list="all"
        language-list="all"
        />
    ... more build entries

  <wiki>
    <package-ref
        package-id="openoffice"
        language-list="all"
        platform-list="all"
        table="main"
        />
    ... more packages
  </wiki>
   
</release>

A single <release> tag contains any number of

<language>  id
                The language id used internally by the build process, eg de, en-US
            english-name
                The english name of the language, eg german
            local-name 
                The language name in that language, eg Deutsch

    Each listed language is expected to have been passed to configure via --with-lang
    The set of languages defines for which languages to
          build installation sets, language packs etc. (build command) 
          upload installation sets, etc (upload command)
          add rows in the wiki page (wiki command)

<platform>  id
                The platform id that is used internally by the build process, eg wntmsci12.pro
                Note that <p>.pro and <p> are treated as two different platforms.
            display-name
                Name which is printed in the wiki table.
            archive-platform
                Platform name as used in the name of the installation set, eg Win_x86
            word-size
                Bit size of the installation sets, etc, typically either 32 or 64
            package-types
                Semicolon separated list of package types, eg "msi" or "deb;rpm"
            add-package-type-to-archive-name
                For deb and rpm archives it is necessary to add the package type to the archive name.
            extension
                Extension of the archive name, eg "exe" or "tar.gz"

    For the build command only those <platform> elements are used that match the platform on which this
    script is run.

<download>
            platform-id
                Reference to one of the <platform> elements and has to match the id attribute of that platform.
            base-url
                URL head to which the name of the downloadable installation set etc. is appended.
                Eg. http://people.apache.org/~somebody/developer-snapshots/snapshot/win32

    Defines one download source that is referenced in the wiki page.  Multiple <download> elements
    per platform are possible.  Earlier entires are preferred over later ones.

<package>
            id
                Internal name that is used to reference the package.
            target
                Target name recognized by instsetoo_native/util/makefile.mk, eg openoffice or oolanguagepack.
            display-name
                Name of the package that is shown in the wiki page, eg "Full Install" or "Langpack".
            archive-name
                Template of the archive name.
                %V version
                %P archive package name
                %T package type
                %L language
                %E extension.

    Defines a downloadable and distributable package, eg openoffice for the binary OpenOffice installation set.
    
<build>     target
            platform-list
                Semicolon separated list of platforms for which to build the target.
                Ignores all platforms that don't match the  platform on which this script is executed.
                The special value 'all' is a shortcut for all platforms listed by <platform> elements.
            language-list
                Semicolon separated list of languages for which the build the target.
                The special value 'all' is a shortcut for all languages listed by <language> elements.

    Defines the sets of targets, plaforms and languages which are to be built.

<wiki>
    <package-ref>
            package-id
                The id of the referenced package.
            platform-list
                See <build> tag for explanation.
            language-list
                See <build> tag for explanation.
            table
                Specifies the wiki table into which to add the package lines.  Can be "main" or "secondary".
                
=cut
    

my %EnUSBasedLanguages = (
    'ast' => 1
    );


sub ProcessCommandline (@);
sub PrintUsageAndExit ();
sub Trim ($);
sub ReadReleaseDescription ($$);
sub ProcessBuildDescription ($$$);
sub ProcessPlatformDescription ($$);
sub ProcessDownloadDescription ($$);
sub ProcessPackageDescription ($$);
sub ProcessWikiPackageDescription ($$$);
sub ProcessLanguageDescription ($$);
sub PostprocessLanguageList ($$);
sub PostprocessPlatformList ($$);
sub CheckLanguageSet ($@);
sub WriteMakefile ($$);
sub Upload ($$);
sub PrepareUploadArea ($@);
sub UploadFilesViaRsync ($$@);
sub CollectDownloadSets ($);
sub ProvideChecksums ($@);
sub IsOlderThan ($$);
sub GetInstallationPackageName ($$$$);
sub ResolveTemplate ($$$$$);
sub GetCurrentPlatformDescriptor ($);
sub Wiki ($$);
sub GetTableList ($);
sub GetPackagesForTable ($$);
sub GetLanguagesForTable ($@);
sub GetPlatformsForTable ($@);
sub WriteDownloadLinks ($$$$$$$);
sub FindDownload ($$$$$);
sub CreateLink ($$$);
sub CheckLink ($);
sub SignFile ($$);

sub ProcessCommandline (@)
{
    my @arguments = @_;

    my $command = undef;
    my $description_filename = undef;
    my $max_process_count = 1;
    my $keep_going = 0;
    my $upload_destination = undef;
    my $check_links = 0;
    my $mark_broken_links = 0;
    my $output_filename = undef;
    my $max_upload_count = 5;
    my $build_only_missing = 0;
    my $dry_run = 0;

    my $error = 0;
    while (scalar @arguments > 0)
    {
        my $argument = shift @arguments;
        if ($argument =~ /^-/)
        {
            if ($argument eq "-j")
            {
                $max_process_count = shift @arguments;
            }
            elsif ($argument eq "-u")
            {
                $upload_destination = shift @arguments;
                $upload_destination =~ s/(\\|\/)$//;
            }
            elsif ($argument eq "-k")
            {
                $keep_going = 1;
            }
            elsif ($argument eq "-l")
            {
                $check_links = 1;
            }
            elsif ($argument eq "-ld")
            {
                $check_links = 1;
                $mark_broken_links = 1;
            }
            elsif ($argument eq "-o")
            {
                $output_filename = shift @arguments;
            }
            elsif ($argument eq "-n")
            {
                $max_upload_count = shift @arguments;
            }
            elsif ($argument eq "-d")
            {
                $dry_run = 1;
            }
            else
            {
                printf STDERR "unknown option $argument %s\n", $argument;
                $error = 1;
            }
        }
        elsif ( ! defined $command)
        {
            $command = $argument;
            if ($command eq "build-missing")
            {
                $command = "build";
                $build_only_missing = 1;
            }
            elsif ($command !~ /^(build|build-missing|upload|wiki)$/)
            {
                printf STDERR "unknown command '%s'\n", $command;
                $error = 1;
            }
        }
        else
        {
            $description_filename = $argument;
            if ( ! -f $description_filename)
            {
                print STDERR "can not open release description '%s'\n", $description_filename;
                $error = 1;
            }
        }
    }

    if ( ! defined $description_filename)
    {
        $error = 1;
    }
    if (! defined $command)
    {
        printf STDERR "ERROR: no command\n";
        $error = 1;
    }
    elsif ($command =~ /^(wiki)$/)
    {
        if ( ! defined $output_filename)
        {
            printf STDERR "ERROR: no output filename\n",
            $error = 1;
        }
    }
    
    if ($error)
    {
        PrintUsageAndExit();
    }

    return {
        'command' => $command,
        'filename' => $description_filename,
        'max-process-count' => $max_process_count,
        'keep-going' => $keep_going,
        'upload-destination' => $upload_destination,
        'check-links' => $check_links,
        'mark-broken-links' => $mark_broken_links,
        'output-filename' => $output_filename,
        'max-upload-count' => $max_upload_count,
        'build-only-missing' => $build_only_missing,
        'dry-run' => $dry_run
    };
}


sub PrintUsageAndExit ()
{
    print STDERR "usage: $0 <command> {option} <release-description.xml>\n";
    print STDERR "    comands:\n";
    print STDERR "        build\n";
    print STDERR "        build-missing\n";
    print STDERR "        upload\n";
    print STDERR "        wiki     create a download page in MediaWiki syntax\n";
    print STDERR "    options:\n";
    print STDERR "    -j <count>    maximum number of build processes\n";
    print STDERR "    -k            keep going if there are recoverable errors\n";
    print STDERR "    -u <path>     upload destination\n";
    print STDERR "    -l            check links on wiki page, write broken links as plain text\n";
    print STDERR "    -ld           check links on wiki page, mark broken links\n";
    print STDERR "    -o <filename> filename of the output (wiki: wiki page, build: makefile)\n";
    print STDERR "    -n <number>   maximal number of upload tries, defaults to 5.\n";
    print STDERR "    -d            dry run\n";
    exit(1);
}


=head2 Trim ($text)

    Remove leading and trailing space from the given string.

=cut
sub Trim ($)
{
    my ($text) = @_;
    $text =~ s/^\s+|\s+$//g;
    return $text;
}


=head2 ReadReleaseDescription ($$)

    Read the release description from $filename.
    
=cut
sub ReadReleaseDescription ($$)
{
    my ($filename, $context) = @_;

    my $document = XML::LibXML->load_xml('location' => $filename);
    my $root = $document->documentElement();

    # Initialize the release description.
    my $release = {
        'name' => $root->getAttribute("name"),
        'version' => $root->getAttribute("version"),
        'previous-version' => $root->getAttribute("previous-version"),
        'builds' => [],
        'languages' => {},
        'language-ids' => [],
        'platforms' => {},
        'downloads' => [],
        'packages' => {},
        'platform-ids' => [],
        'wiki-packages' => []
    };
    
    # Process the language descriptions.
    for my $language_element ($root->getChildrenByTagName("language"))
    {
        my $language_descriptor = ProcessLanguageDescription($language_element, $context);
        $release->{'languages'}->{$language_descriptor->{'id'}} = $language_descriptor;
        push @{$release->{'language-ids'}}, $language_descriptor->{'id'};
    }
    printf "%d languages\n", scalar keys %{$release->{'languages'}};

    # Process the platform descriptions.
    for my $platform_element ($root->getChildrenByTagName("platform"))
    {
        my $platform_descriptor = ProcessPlatformDescription($platform_element, $context);
        $release->{'platforms'}->{$platform_descriptor->{'id'}} = $platform_descriptor;
        push @{$release->{'platform-ids'}}, $platform_descriptor->{'id'};
    }
    printf "%d platforms\n", scalar keys %{$release->{'platforms'}};

    # Process the package descriptions.
    for my $package_element ($root->getChildrenByTagName("package"))
    {
        my $package_descriptor = ProcessPackageDescription($package_element, $context);
        $release->{'packages'}->{$package_descriptor->{'id'}} = $package_descriptor;
    }
    printf "%d packages\n", scalar keys %{$release->{'packages'}};

    # Platform specific the package descriptions.
    for my $package_element ($root->getChildrenByTagName("platform-package"))
    {
        my $package_descriptor = ProcessPlatformPackageDescription($package_element, $context);
        my $key = $package_descriptor->{'platform-id'} . "/" . $package_descriptor->{'package-id'};
        $release->{'platform-packages'}->{$key} = $package_descriptor;
    }
    printf "%d platform packages\n", scalar keys %{$release->{'platform-packages'}};

    # Process the download descriptions.
    for my $download_element ($root->getChildrenByTagName("download"))
    {
        my $download_descriptor = ProcessDownloadDescription($download_element, $context);
        push @{$release->{'downloads'}}, $download_descriptor;
    }
    printf "%d downloads\n", scalar @{$release->{'downloads'}};

    if ($context->{'command'} =~ /^(build|upload)$/)
    {
        # Process the build descriptions.
        for my $build_element ($root->getChildrenByTagName("build"))
        {
            push @{$release->{'builds'}}, ProcessBuildDescription($build_element, $context, $release);
        }
        printf "%d build targets\n", scalar @{$release->{'builds'}};
    }    

    if ($context->{'command'} eq "wiki")
    {
        for my $wiki_element ($root->getChildrenByTagName("wiki"))
        {
            for my $wiki_package_element ($wiki_element->getChildrenByTagName("package-ref"))
            {
                my $wiki_package = ProcessWikiPackageDescription(
                    $wiki_package_element,
                    $context,
                    $release);
                push @{$release->{'wiki-packages'}}, $wiki_package;
            }
        }
        printf "%d wiki packages\n", scalar @{$release->{'wiki-packages'}};
    }

    return $release;
}


=head ProcessBuildDescription ($build_element, $context, $release_descriptor)

    Process one <build> element.

    If its platform-list does not match the current platform then the <build> element is ignored.

=cut
sub ProcessBuildDescription ($$$)
{
    my ($build_element, $context, $release_descriptor) = @_;

    my $package_id = $build_element->getAttribute("package-id");
    my $languages = PostprocessLanguageList($build_element->getAttribute("language-list"), $release_descriptor);
    my $platforms = PostprocessPlatformList($build_element->getAttribute("platform-list"), $release_descriptor);

    # Check if the platform matches any for which the product shall be built.
    my $current_platform = $ENV{'INPATH'};
    my $is_platform_match = 0;
    foreach my $platform_id (@$platforms)
    {
        if ($platform_id eq $current_platform)
        {
            $is_platform_match=1;
            last;
        }
    }
    if ($is_platform_match)
    {
        printf "including build %s\n", $package_id;
    }
    else
    {
        printf "skipping build %s: no platform match\n", $package_id;
        printf "none of the platforms %s matches %s\n",
        join(", ", keys %{$release_descriptor->{'platforms'}}),
        $current_platform;
        return;
    }

    my @languages = CheckLanguageSet($context, @$languages);
    
    return {
        'package-id' => $package_id,
        'platform-list' => $platforms,
        'language-list' => \@languages
    };
}


=head2 ProcessPlatformDescription ($element, $context)

    Process one <platform> element.

    The corresponding platform descriptor is returned as a hash.
    
=cut
sub ProcessPlatformDescription ($$)
{
    my ($element, $context) = @_;

    my $descriptor = {};
    # Mandatory tags.
    foreach my $id ("id", "display-name", "archive-platform", "word-size", "package-types")
    {
        $descriptor->{$id} = $element->getAttribute($id);
        die "release/platform has no attribute $id" unless defined $descriptor->{$id};
    }
    # Optional tags.
    foreach my $id ("extension", "add-package-type-to-archive-name")
    {
        my $value = $element->getAttribute($id);
        $descriptor->{$id} = $value if defined $value;
    }

    $descriptor->{'add-package-type-to-archive-name'} = 0
        unless defined $descriptor->{'add-package-type-to-archive-name'};
    $descriptor->{'package-types'} = [split(/;/, $descriptor->{'package-types'})];

    return $descriptor;
}


=head2 ProcessDownloadDescription ($element, $context)

    Process one <download> element.

    The corresponding download descriptor is returned as a hash.
    
=cut
sub ProcessDownloadDescription ($$)
{
    my ($element, $context) = @_;

    my $descriptor = {};
    
    # Mandatory tags.
    foreach my $id ("platform-id", "base-url")
    {
        $descriptor->{$id} = $element->getAttribute($id);
        die "release/download has no attribute $id" unless defined $descriptor->{$id};
    }

    return $descriptor;
}


=head2 ProcessPackageDescription ($element, $context)

    Process one <package> element.

    The corresponding package descriptor is returned as a hash.
    
=cut
sub ProcessPackageDescription ($$)
{
    my ($element, $context) = @_;

    my $descriptor = {};
    
    # Mandatory tags.
    foreach my $id ("id", "target", "archive-path", "archive-name", "display-name")
    {
        $descriptor->{$id} = $element->getAttribute($id);
        die "release/package has no attribute $id" unless defined $descriptor->{$id};
        die "release/package attribute $id is empty" unless $descriptor->{$id} !~ /^\s*$/;
    }
    # Optional tags.
    foreach my $id ("link-tooltip", "link-URL", "download-extension")
    {
        my $value = $element->getAttribute($id);
        $descriptor->{$id} = $value if defined $value;
    }

    return $descriptor;
}


=head2 ProcessPlatformPackageDescription ($element, $context)

    Process one <platform-package> element.

    The corresponding package descriptor is returned as a hash.
    
=cut
sub ProcessPlatformPackageDescription ($$)
{
    my ($element, $context) = @_;

    my $descriptor = {};
    
    # Mandatory tags.
    foreach my $id ("platform-id", "package-id")
    {
        $descriptor->{$id} = $element->getAttribute($id);
        die "release/package has no attribute $id" unless defined $descriptor->{$id};
        die "release/package attribute $id is empty" unless $descriptor->{$id} !~ /^\s*$/;
    }
    # Optional tags.
    foreach my $id ("extension", "package-types")
    {
        my $value = $element->getAttribute($id);
        $descriptor->{$id} = $value if defined $value;
    }
    if (defined $descriptor->{'package-types'})
    {
        $descriptor->{'package-types'} = [split(/;/, $descriptor->{'package-types'})];
    }

    return $descriptor;
}


=head2 ProcessWikiPackageDescription ($element, $context)

    Process one <wiki><package-ref> element.

    The corresponding descriptor is returned as a hash.
    
=cut
sub ProcessWikiPackageDescription ($$$)
{
    my ($element, $context, $release_descriptor) = @_;

    my $descriptor = {};
    # Mandatory tags.
    foreach my $id ("package-id", "table")
    {
        $descriptor->{$id} = $element->getAttribute($id);
        die "wiki/package-ref has no attribute $id" unless defined $descriptor->{$id};
        die "wiki/package-ref attribute $id is empty" unless $descriptor->{$id} !~ /^\s*$/;
    }

    $descriptor->{'language-list'} = PostprocessLanguageList(
        $element->getAttribute("language-list"),
        $release_descriptor);
    $descriptor->{'platform-list'} = PostprocessPlatformList(
        $element->getAttribute("platform-list"),
        $release_descriptor);

    $descriptor->{'languages'} = {map{$_=>1} @{$descriptor->{'language-list'}}};
    $descriptor->{'platforms'} = {map{$_=>1} @{$descriptor->{'platform-list'}}};

    return $descriptor;
}


=head2 ProcessLanguageDescription ($element, $context)

    Process one <language> element.

    The corresponding language descriptor is returned as a hash.
    
=cut
sub ProcessLanguageDescription ($$)
{
    my ($element, $context) = @_;

    my $descriptor = {};
    foreach my $id ("id", "english-name", "local-name")
    {
        $descriptor->{$id} = $element->getAttribute($id);
        die "wiki/language has no attribute $id" unless defined $descriptor->{$id};
    }

    return $descriptor;
}


=head2 PostprocessLanguageList ($language_list, $release_descriptor)

    Process a language list that is given as 'language-list' attribute to some tags.

    If the attribute is missing, ie $language_list is undef, or its value is "all",
    then the returned list of languages is set to all languages defined via <language> elements.
    
=cut
sub PostprocessLanguageList ($$)
{
    my ($language_list, $release_descriptor) = @_;

    my @matching_languages = ();
    if ( ! defined $language_list
        || $language_list eq "all")
    {
        @matching_languages = sort keys %{$release_descriptor->{'languages'}};
    }
    else
    {
        @matching_languages = split(/;/, $language_list);
    }

    return \@matching_languages;
}


=head2 PostprocessPlatformList ($platform_list, $release_descriptor)

    Process a platform list that is given as 'platform-list' attribute to some tags.

    If the attribute is missing, ie $platform_list is undef, or its value is "all",
    then the returned list of platforms is set to all platforms defined via <platform> elements.
    
=cut
sub PostprocessPlatformList ($$)
{
    my ($platform_list, $release_descriptor) = @_;

    my @matching_platforms = ();
    if ( ! defined $platform_list
        || $platform_list eq "all")
    {
        @matching_platforms = sort keys %{$release_descriptor->{'platforms'}};
    }
    else
    {
        @matching_platforms = split(/;/, $platform_list);
    }
    
    return \@matching_platforms;
}


=head2 CheckLanguageSet ($context, @languages)

    Compare the given list of languages with the one defined by the 'WITH_LANG' environment variable.

    This is to ensure that configure --with-lang was called with the same set of languages that are
    listed by the <language> elements.
    
=cut
sub CheckLanguageSet ($@)
{
    my ($context, @languages) = @_;
    my %configured_languages = map{$_=>1} split(/\s+/, $ENV{'WITH_LANG'});

    my @missing_languages = ();
    my @present_languages = ();
    for my $language (@languages)
    {
        if (defined $configured_languages{$language})
        {
            push @present_languages, $language;
        }
        else
        {
            push @missing_languages, $language;
        }
    }

    if (scalar @missing_languages > 0)
    {
        my $message_head = $context->{'keep-going'} ? "WARNING" : "ERROR";
        printf STDERR "%s: there are languages that where not configured via --with-lang:\n", $message_head;
        printf STDERR "%s:     %s\n", $message_head, join(", ", @missing_languages);
        if ($context->{'keep-going'})
        {
            printf "    available languages:\n";
            printf "        %s\n", join(", ", @present_languages);
        }
        else
        {    
            printf STDERR "ERROR: please rerun configure with --with-lang=\"%s\"\n", join(" ", @languages);
            exit(1);
        }
    }

    return @present_languages;
}


=head2 WriteMakefile ($release_descriptor, $context)

    Write a makefile with all targets that match the <build> elements.

    The use of a makefile allows us to use make to handle concurrent building.

    When an output file was specified on the command line (option -o) then the
    makefile is written to that file but make is not run.

    When no output file was specified then the makefile is written to a temporary
    file.  Then make is run for this makefile.

=cut
sub WriteMakefile ($$)
{
    my ($release_descriptor, $context) = @_;

    my $filename = $context->{'output-filename'};
    if ( ! defined $filename)
    {
        $filename = File::Temp->new();
    }

    # Collect the targets to make.
    my @targets = ();
    foreach my $build (@{$release_descriptor->{'builds'}})
    {
        my $platform_descriptor = GetCurrentPlatformDescriptor($release_descriptor);
        my $package_descriptor = $release_descriptor->{'packages'}->{$build->{'package-id'}};
        my $platform_package_descriptor = GetPlatformPackage(
            $release_descriptor,
            $platform_descriptor,
            $package_descriptor);

        foreach my $language_id (@{$build->{'language-list'}})
        {
            foreach my $package_format (@{$platform_package_descriptor->{'package-types'}})
            {
                my $full_target = sprintf("%s_%s.%s",
                    $package_descriptor->{'target'},
                    $language_id,
                    $package_format);
                if ($context->{'build-only-missing'})
                {
                    my ($archive_path, $archive_name) = GetInstallationPackageName(
                        $release_descriptor,
                        $platform_package_descriptor,
                        $package_format,
                        $language_id);
                    my $candidate = $archive_path . "/" . $archive_name;
                    if (-f $candidate)
                    {
                        printf "download set for %s already exists, skipping\n", $full_target;
                        next;
                    }
                    else
                    {
                        printf "%s  %s\n", $archive_path, $archive_name;
                    }
                }
                push @targets, $full_target;
            }
        }
    }

    # Write the makefile.
    open my $make, ">", $filename;

    # Write dependencies of 'all' on the products in all languages.
    print $make "all .PHONY : \\\n    ";
    printf $make "%s\n", join(" \\\n    ", @targets);
    printf $make "\n\n";

    if ($context->{'dry-run'})
    {
        printf ("adding make fules for\n    %s\n", join("\n    ", @targets));
    }

    # Write rules that chain dmake in instsetoo_native/util.
    foreach my $target (@targets)
    {
        printf $make "%s :\n", $target;
        printf $make "\tdmake \$@ release=t\n";
    }
    close $make;

    
    if ( ! defined $context->{'output-filename'})
    {
        # Caller wants us to run make.
        my $path = $ENV{'SRC_ROOT'} . "/instsetoo_native/util";
        my $command = sprintf("make -f \"%s\" -C \"%s\" -j%d",
            $filename,
            $path,
            $context->{'max-process-count'});
        if ($context->{'dry-run'})
        {
            printf "would run %s\n", $command;
        }
        else
        {
            printf "running %s\n", $command;
            system($command);
        }
    }
}


sub Upload ($$)
{
    my ($release_descriptor, $context) = @_;

    if ( ! defined $context->{'upload-destination'})
    {
        printf STDERR "ERROR: upload destination is missing\n";
        PrintUsageAndExit();
    }

    my @download_sets = CollectDownloadSets($release_descriptor);

    ProvideChecksums($context, @download_sets);
    my $source_path = PrepareUploadArea($context, @download_sets);
    if ( ! defined $source_path)
    {
        exit(1);
    }
    if ( ! UploadFilesViaRsync($context, $source_path, @download_sets))
    {
        exit(1);
    }
}


=head2 PrepareUploadArea ($context, @download_sets)

    Create a temporary directory with the same sub directory strcuture that is requested in the upload location.
    The files that are to be uploaded are not copied but linked into this temporary directory tree.

    Returns the name of the temporary directory.
    
=cut
sub PrepareUploadArea ($@)
{
    my ($context, @download_sets) = @_;
    
    my $tmpdir = File::Temp->newdir();
    foreach my $download_set (@download_sets)
    {
        foreach my $extension ("", ".md5", ".sha256", ".asc")
        {
            my $basename = sprintf("%s%s", $download_set->{'archive-name'}, $extension);
            my $source_path = $download_set->{'source-path'};
            my $source = sprintf("%s/%s", $source_path, $basename);
            my $target_path = sprintf("%s/%s", $tmpdir, $download_set->{'destination-path'});
            my $target = sprintf("%s/%s", $target_path, $basename);
            if ($context->{'dry-run'})
            {
                printf "would create link for %s\n", $basename;
                printf "    %s\n", $source_path;
                printf " to %s\n", $target_path;
            }
            else
            {
                mkpath($target_path);
                unlink $target if ( -f $target);
                my $result = symlink($source, $target);
                if ($result != 1)
                {
                    printf "ERROR: can not created symbolic link to %s\n", $basename;
                    printf "       %s\n", $source;
                    printf "    -> %s\n", $target;
                    return undef;
                }
            }
        }
    }

    return $tmpdir;
}


sub UploadFilesViaRsync ($$@)
{
    my ($context, $source_path, @download_sets) = @_;


    # Collect the rsync flags.
    my @rsync_options = (
        "-L",         # Copy linked files
        "-a",         # Transfer the local attributes and modification times.
        "-c",         # Use checksums to compare source and destination files.
        "--progress", # Show a progress indicator
        "--partial",  # Try to resume a previously failed upload
        );

    # (Optional) Add flags for upload to ssh server 
    my $upload_destination = $context->{'upload-destination'};
    if ($upload_destination =~ /@/)
    {
        push @rsync_options, ("-e", "ssh");
    }

    # Set up the rsync command.
    my $command = sprintf("rsync %s \"%s/\" \"%s\"",
        join(" ", @rsync_options),
        $source_path,
        $upload_destination);
    printf "%s\n", $command;

    if ($context->{'dry-run'})
    {
        printf "would run %s up to %d times\n", $command, $context->{'max-upload-count'};
    }
    else
    {
        # Run the command.  If it fails, repeat a number of times.
        my $max_run_count = $context->{'max-upload-count'};
        for (my $run_index=1; $run_index<=$max_run_count && scalar @download_sets>0; ++$run_index)
        {
            my $result = system($command);
            printf "%d %d\n", $result, $?;
            return 1 if $result == 0;
        }
        printf "ERROR: could not upload all files without error in %d runs\n", $max_run_count;
        return 0;
    }
}


sub CollectDownloadSets ($)
{
    my ($release_descriptor) = @_;

    my @download_sets = ();
    
    foreach my $platform_descriptor (values %{$release_descriptor->{'platforms'}})
    {
        my $platform_path = sprintf("%s/instsetoo_native/%s",
            $ENV{'SOLARSRC'},
            $platform_descriptor->{'id'});
        if ( ! -d $platform_path)
        {
            printf "ignoring missing %s\n", $platform_path;
            next;
        }
        for my $package_descriptor (values %{$release_descriptor->{'packages'}})
        {
            my $platform_package_descriptor = GetPlatformPackage(
                $release_descriptor,
                $platform_descriptor,
                $package_descriptor);
            my @package_formats = @{$platform_descriptor->{'package-types'}};
            for my $package_format (@package_formats)
            {
                for my $language_id (@{$release_descriptor->{'language-ids'}})
                {
                    my ($archive_path, $archive_name) = GetInstallationPackageName(
                        $release_descriptor,
                        $platform_package_descriptor,
                        $package_format,
                        $language_id);
                    my $candidate = $archive_path."/".$archive_name;
                    if ( ! -f $candidate)
                    {
#                        printf STDERR "ERROR: can not find download set '%s'\n", $candidate;
                        next;
                    }
                    printf "adding %s\n", $archive_name;
                    my $download_set = {
                        'source-path' => $archive_path,
                        'archive-name' => $archive_name,
                        'platform' => $platform_descriptor->{'archive-platform'},
                        'destination-path' => sprintf("developer-snapshots/%s/%s",
                            $release_descriptor->{'name'},
                            $platform_descriptor->{'archive-platform'})
                    };
                    printf "    %s\n", $download_set->{'destination-path'};
                    push @download_sets, $download_set;
                }
            }
        }
    }

    return @download_sets;
}


=head2 ProvideChecksums ($context, @download_sets)

    Create checksums in MD5 and SHA256 format and a gpg signature for the given download set.
    The checksums are not created when they already exists and are not older than the download set.
    
=cut
sub ProvideChecksums ($@)
{
    my ($context, @download_sets) = @_;

    my @asc_requests = ();
    foreach my $download_set (@download_sets)
    {
        printf "%s\n", $download_set->{'archive-name'};
        my $full_archive_name = $download_set->{'source-path'} . "/" . $download_set->{'archive-name'};
        $full_archive_name = Trim(qx(cygpath -u "$full_archive_name"));

        my $md5_filename = $full_archive_name . ".md5";
        if ( ! -f $md5_filename || IsOlderThan($md5_filename, $full_archive_name))
        {
            if ($context->{'dry-run'})
            {
                printf "    would create MD5\n";
            }
            else
            {
                my $digest = Digest::MD5->new();
                open my ($in), $full_archive_name;
                $digest->addfile($in);
                my $checksum = $digest->hexdigest();
                close $in;

                open my ($out), ">", $md5_filename;
                printf $out "%s *%s", $checksum, $download_set->{'archive-name'};
                close $out;

                printf "    created MD5\n";
            }
        }
        else
        {
            printf "    MD5 already exists\n";
        }

        my $sha256_filename = $full_archive_name . ".sha256";
        if ( ! -f $sha256_filename || IsOlderThan($sha256_filename, $full_archive_name))
        {
            if ($context->{'dry-run'})
            {
                printf "    would create SHA256\n";
            }
            else
            {
                my $digest = Digest::SHA->new("sha256");
                open my ($in), $full_archive_name;
                $digest->addfile($in);
                my $checksum = $digest->hexdigest();
                close $in;

                open my ($out), ">", $sha256_filename;
                printf $out "%s *%s", $checksum, $download_set->{'archive-name'};
                close $out;

                printf "    created SHA256\n";
            }
        }
        else
        {
            printf "    SHA256 already exists\n";
        }

        my $asc_filename = $full_archive_name . ".asc";
        if ( ! -f $asc_filename || IsOlderThan($asc_filename, $full_archive_name))
        {
            if ($context->{'dry-run'})
            {
                printf "    would create ASC\n";
            }
            else
            {
                # gpg seems not to be able to sign more than one file at a time.
                # Password has to be provided every time.
                my $command = sprintf("gpg --armor --detach-sig \"%s\"", $full_archive_name);
                print $command;
                my $result = system($command);
                printf "    created ASC\n";
            }
        }
        else
        {
            printf "    ASC already exists\n";
        }
    }
}


=head2 IsOlderThan ($filename1, $filename2)

    Return true (1) if the last modification date of $filename1 is older than (<) that of $filename2.

=cut
sub IsOlderThan ($$)
{
    my ($filename1, $filename2) = @_;

    my @stat1 = stat $filename1;
    my @stat2 = stat $filename2;

    return $stat1[9] < $stat2[9];
}


sub GetInstallationPackageName ($$$$)
{
    my ($release_descriptor, $platform_package_descriptor, $package_format, $language) = @_;

    my $path = ResolveTemplate(
        $platform_package_descriptor->{'archive-path'},
        $release_descriptor,
        $platform_package_descriptor,
        $package_format,
        $language);
    my $name = ResolveTemplate(
        $platform_package_descriptor->{'archive-name'},
        $release_descriptor,
        $platform_package_descriptor,
        $package_format,
        $language);

    return ($path, $name);
}


sub ResolveTemplate ($$$$$)
{
    my ($template, $release_descriptor, $platform_package_descriptor, $package_format, $language) = @_;
    
    my $archive_package_type = "";
    if ($platform_package_descriptor->{'add-package-type-to-archive-name'} =~ /^(1|true|yes)$/i)
    {
        $archive_package_type = "-".$package_format;
    }
    my $full_language = $language;
    if ($EnUSBasedLanguages{$language})
    {
        $full_language = "en-US_".$language;
    }
    my $extension = $platform_package_descriptor->{'download-extension'};
    if ( ! defined $extension)
    {
        $extension = $platform_package_descriptor->{'extension'};
    }

    my $old_to_new_version_dash = sprintf(
        "v-%s_v-%s",
        $release_descriptor->{'previous-version'},
        $release_descriptor->{'version'});
    $old_to_new_version_dash =~ s/\./-/g;
    my $old_to_new_version_dots = sprintf(
        "%s-%s",
        $release_descriptor->{'previous-version'},
        $release_descriptor->{'version'});
    
    
    my $name = $template;
    
    # Resolve %? template parameters.
    $name =~ s/%V/$release_descriptor->{'version'}/g;
    $name =~ s/%W/$old_to_new_version_dash/g;
    $name =~ s/%w/$old_to_new_version_dots/g;
    $name =~ s/%P/$platform_package_descriptor->{'archive-platform'}/g;
    $name =~ s/%t/$archive_package_type/g;
    $name =~ s/%T/$package_format/g;
    $name =~ s/%l/$full_language/g;
    $name =~ s/%L/$language/g;
    $name =~ s/%E/$extension/g;

    # Resolve $name environment references.
    while ($name =~ /^(.*?)\$([a-zA-Z0-9_]+)(.*)$/)
    {
        $name = $1 . $ENV{$2} . $3;
    }

    return $name;
}


sub GetCurrentPlatformDescriptor ($)
{
    my ($release_descriptor) = @_;

    my $platform_descriptor = $release_descriptor->{'platforms'}->{$ENV{'INPATH'}};
    if ( ! defined $platform_descriptor)
    {
        printf STDERR "ERROR: platform '%s' is not supported\n", $ENV{'INPATH'};
    }
    return $platform_descriptor;
}


sub GetPlatformPackage ($$$)
{
    my ($release_descriptor, $platform_descriptor, $package_descriptor) = @_;
    my $key = sprintf("%s/%s", $platform_descriptor->{'id'}, $package_descriptor->{'id'});

    my $platform_package = $release_descriptor->{'platform-packages'}->{$key};
    $platform_package = {}
        unless defined $platform_package;
    
    my $joined_descriptor = {
        %$platform_descriptor,
        %$package_descriptor,
        %$platform_package,
        'id' => $key,
        'platform-id' => $platform_descriptor->{'id'},
        'package-id' => $package_descriptor->{'id'}
    };
    return $joined_descriptor;
}


sub Wiki ($$)
{
    my ($release_descriptor, $context) = @_;

    open my $out, ">", $context->{'output-filename'};

    my @table_list = GetTableList($release_descriptor);
    foreach my $table_name (@table_list)
    {
        my @table_packages = GetPackagesForTable($release_descriptor, $table_name);
        my @table_languages = GetLanguagesForTable($release_descriptor, @table_packages);
        my @table_platforms = GetPlatformsForTable($release_descriptor, @table_packages);

        printf "packages: %s\n", join(", ", map {$_->{'package'}->{'display-name'}} @table_packages);
        printf "languages: %s\n", join(", ", map {$_->{'english-name'}} @table_languages);
        printf "platforms: %s\n", join(", ", map {$_->{'id'}} @table_platforms);

        print $out "{| class=\"wikitable\"\n";

        # Write the table head.
        print $out "|-\n";
        print $out "! colspan=\"2\" | Language<br>The names do not refer to countries\n";
        print $out "! Type\n";
        foreach my $platform_descriptor (@table_platforms)
        {
            foreach my $package_type (@{$platform_descriptor->{'package-types'}})
            {
                printf $out "! %s<br>%s bit<br>%s\n",
                $platform_descriptor->{'display-name'},
                $platform_descriptor->{'word-size'},
                uc($package_type);
            }
        }

        foreach my $language_descriptor (@table_languages)
        {
            if ($context->{'check-links'})
            {
                $| = 1;
                printf "%-5s: ", $language_descriptor->{'id'};
            }

            print $out "|-\n";
            printf $out "| rowspan=\"%d\" | %s\n", scalar @table_packages, $language_descriptor->{'english-name'};
            printf $out "| rowspan=\"%d\" | %s\n", scalar @table_packages, $language_descriptor->{'local-name'};

            my $is_first = 1;
            foreach my $wiki_package_descriptor (@table_packages)
            {
                my $package_descriptor = $wiki_package_descriptor->{'package'};

                if ($is_first)
                {
                    $is_first = 0;
                }
                else
                {
                    printf $out "|-\n";
                }

                # Write the name of the package, e.g. Full Install or Langpack.
                if (defined $package_descriptor->{'link-URL'})
                {
                    printf $out "| [%s %s]\n",
                    $package_descriptor->{'link-URL'},
                    $package_descriptor->{'display-name'};
                }
                else
                {
                    printf $out "| %s\n", $package_descriptor->{'display-name'};
                }

                foreach my $platform_descriptor (@table_platforms)
                {
                    my $platform_package_descriptor = GetPlatformPackage(
                        $release_descriptor,
                        $platform_descriptor,
                        $package_descriptor);

                    foreach my $package_type (@{$platform_package_descriptor->{'package-types'}})
                    {
                        WriteDownloadLinks(
                            $out,
                            $release_descriptor,
                            $context,
                            $language_descriptor,
                            $wiki_package_descriptor,
                            $platform_package_descriptor,
                            $package_type);
                    }
                }
            }
            
            if ($context->{'check-links'})
            {
                printf "\n";
            }
        }

        print $out "|}\n";
    }
    close $out;
}


sub GetTableList ($)
{
    my ($release_descriptor) = @_;

    my %seen_table_names = ();
    my @table_names = ();
    foreach my $wiki_package_descriptor (@{$release_descriptor->{'wiki-packages'}})
    {
        my $table_name = $wiki_package_descriptor->{'table'};
        if ( ! $seen_table_names{$table_name})
        {
            push @table_names, $table_name;
            $seen_table_names{$table_name} = 1;
        }
    }
    return @table_names;
}


sub GetPackagesForTable ($$)
{
    my ($release_descriptor, $table_name) = @_;

    my @packages = ();
    foreach my $wiki_package_descriptor (@{$release_descriptor->{'wiki-packages'}})
    {
        if ($wiki_package_descriptor->{'table'} eq $table_name)
        {
            my $package_descriptor = $release_descriptor->{'packages'}->{
                $wiki_package_descriptor->{'package-id'}};
            $wiki_package_descriptor->{'package'} = $package_descriptor;
            push @packages, $wiki_package_descriptor;
        }
    }
    return @packages;
}


sub GetLanguagesForTable ($@)
{
    my ($release_descriptor, @packages) = @_;

    # Find the languages that are reference by at least one package.
    my %matching_languages = ();
    foreach my $package_descriptor (@packages)
    {
        foreach my $language_id (@{$package_descriptor->{'language-list'}})
        {
            $matching_languages{$language_id} = 1;
        }
    }

    # Retrieve the language descriptors for the language ids.
    my @matching_language_descriptors = ();
    foreach my $language_id (@{$release_descriptor->{'language-ids'}})
    {
        if (defined $matching_languages{$language_id})
        {
            my $language_descriptor = $release_descriptor->{'languages'}->{$language_id};
            if (defined $language_descriptor)
            {
                push @matching_language_descriptors, $language_descriptor;
            }
        }
    }

    return @matching_language_descriptors;
}


sub GetPlatformsForTable ($@)
{
    my ($release_descriptor, @packages) = @_;

    # Find the platforms that are reference by at least one package.
    my %matching_platform_ids = ();
    foreach my $package_descriptor (@packages)
    {
        foreach my $platform_id (@{$package_descriptor->{'platform-list'}})
        {
            $matching_platform_ids{$platform_id} = 1;
        }
    }

    # Retrieve the platform descriptors for the plaform ids.
    my @matching_platform_descriptors = ();
    foreach my $platform_id (@{$release_descriptor->{'platform-ids'}})
    {
        if ($matching_platform_ids{$platform_id})
        {
	    print $platform_id."\n";
            push @matching_platform_descriptors, $release_descriptor->{'platforms'}->{$platform_id};
        }
    }

    return @matching_platform_descriptors;
}


my $bold_text_start = "<b>";
my $bold_text_end = "</b>";
my $small_text_start = "<span style=\"font-size:80%\">";
my $small_text_end = "</span>";
my $broken_link_start = "<span style=\"color:#FF0000\">";
my $broken_link_end = "</span>";


sub WriteDownloadLinks ($$$$$$$)
{
    my ($out,
        $release_descriptor,
        $context,
        $language_descriptor,
        $wiki_package_descriptor,
        $platform_package_descriptor,
        $package_type) = @_;

    # Check if the current language and platform match the package.
    my $platform_id = $platform_package_descriptor->{'platform-id'};
    if (defined $wiki_package_descriptor->{'platforms'}->{$platform_id}
        && defined $wiki_package_descriptor->{'languages'}->{$language_descriptor->{'id'}})
    {
        my $archive_package_name = "";
        my $extension = $package_type;
        if (defined $platform_package_descriptor->{'extension'})
        {
            $extension = $platform_package_descriptor->{'extension'};
        }
        if (defined $platform_package_descriptor->{'download-extension'})
        {
            $extension = $platform_package_descriptor->{'download-extension'};
        }
        $archive_package_name = "-".$package_type if ($package_type =~ /deb|rpm/);

        my ($archive_path, $archive_name) = GetInstallationPackageName(
            $release_descriptor,
            $platform_package_descriptor,
            $package_type,
            $language_descriptor->{'id'});

        printf $out "| align=\"center\" | ";
        my $download = FindDownload(
            $context,
            $release_descriptor,
            $platform_package_descriptor,
            $package_type,
            $archive_name);
        if (defined $download)
        {
            my $url = $download->{'base-url'} . "/". $archive_name;
            printf $out "%s%s%s<br><br>%s%s %s<br>%s%s",
            $bold_text_start,
            CreateLink($url, $extension, $context),
            $bold_text_end,
            $small_text_start,
            CreateLink($url.".asc", "ASC", $context),
            CreateLink($url.".md5", "MD5", $context),
            CreateLink($url.".sha256", "SHA256", $context),
            $small_text_end;
        }
        printf $out "\n";
    }
    else
    {
        printf $out "|\n";
    }
}


sub FindDownload ($$$$$)
{
    my ($context,
        $release_descriptor,
        $platform_package_descriptor,
        $package_type,
        $archive_name) = @_;

    foreach my $download (@{$release_descriptor->{'downloads'}})
    {
        if ($download->{'platform-id'} eq $platform_package_descriptor->{'platform-id'})
        {
            my $url = $download->{'base-url'} . "/". $archive_name;
            if ($context->{'check-links'})
            {
                if (CheckLink($url))
                {
                    # URL points to an existing file.
                    printf "+";
                    return $download;
                }
                else
                {
                    # URL is broken.
                    # Try the next download area for the platform.
                    next;
                }
            }
            else
            {
                # Use the URL unchecked.  If there is more than one download area for the platform then only
                # the first is ever used.
                printf ".";
                return $download;
            }
        }
    }

    if ($context->{'check-links'})
    {
        printf "-";
    }

    return undef;
}


sub CreateLink ($$$)
{
    my ($url, $text, $context) = @_;

    my $is_link_broken = 0;
    if ($context->{'check-links'})
    {
        if (CheckLink($url))
        {
            $is_link_broken = 0;
            printf "+";
        }
        else
        {
            $is_link_broken = 1;
            printf "-";
        }
    }
    else
    {
        printf ".";
    }

    if ( ! $is_link_broken)
    {
        return sprintf ("[%s %s]", $url, $text);
    }
    elsif ($context->{'mark-broken-links'})
    {
        return sprintf ("%sbroken%s[%s %s]", $broken_link_start, $broken_link_end, $url, $text);
    }
    else
    {
        return sprintf ("%s", $text);
    }
}


=head2 CheckLink ($url)

    Check if the file referenced by $url can be downloaded.
    This is determined by downloading only the header.
    
=cut
my $LastCheckedURL = "";
my $LastCheckedResult = undef;
sub CheckLink ($)
{
    my ($url) = @_;

    if ($url ne $LastCheckedURL)
    {
        my $head = LWP::Simple::head($url);
        $LastCheckedURL = $url;
        $LastCheckedResult = !!$head;
    }

    return $LastCheckedResult;
}


sub SignFile ($$)
{
    my ($signature, $filename) = @_;

    my $command = sprintf(
        "gpg --armor --output %s.asc --detach-sig %s",
        $filename,
        $filename);
}


my $context = ProcessCommandline(@ARGV);
my $release_descriptor = ReadReleaseDescription($context->{'filename'}, $context);
if ($context->{'command'} eq "build")
{
    WriteMakefile($release_descriptor, $context);
}
elsif ($context->{'command'} eq "upload")
{
    Upload($release_descriptor, $context);
}
elsif ($context->{'command'} eq "wiki")
{
    Wiki($release_descriptor, $context);
}