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