├── root └── usr │ ├── share │ └── multipkg │ │ ├── scripts │ │ ├── transform │ │ ├── logrun │ │ ├── gembuild │ │ ├── supervisepreun.sh │ │ ├── supervisepost.sh │ │ └── build │ │ ├── templates │ │ ├── control.template │ │ ├── gemspec.template │ │ └── spec.template │ │ └── default.yaml │ └── bin │ ├── multipkg │ ├── svn-multipkg │ ├── hg-multipkg │ ├── git-multipkg │ └── p4-multipkg ├── examples ├── flex │ ├── build │ │ └── build │ └── index.yaml ├── yum │ ├── scripts │ │ └── build │ ├── index.yaml │ └── patches │ │ └── 01-fix-conf ├── daemontools │ ├── scripts │ │ ├── build │ │ ├── post.sh │ │ └── preun.sh │ └── index.yaml ├── nginx │ ├── index.yaml │ └── scripts │ │ └── build └── cpan-dbd-mysql │ └── index.yaml ├── scripts ├── transform └── build ├── README ├── index.yaml ├── source ├── Makefile.PL └── lib │ └── Seco │ ├── HTTP.pm │ ├── CPAN.pm │ ├── Class.pm │ └── Multipkg.pm ├── Readme.md ├── PERLARTISTIC └── GPLv2 /root/usr/share/multipkg/scripts/transform: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Could implement multipkg version embedding here, etc 4 | exit 0 5 | -------------------------------------------------------------------------------- /examples/flex/build/build: -------------------------------------------------------------------------------- 1 | !/bin/sh 2 | 3 | set -e 4 | set -x 5 | 6 | ./configure || exit 1 7 | make || exit 1 8 | make install || exit 1 9 | -------------------------------------------------------------------------------- /examples/yum/scripts/build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | make || exit 1 3 | make install DESTDIR=$DESTDIR || exit 1 4 | rm -f $DESTDIR/usr/local/info/dir 5 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/scripts/logrun: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | mkdir -p ./main 3 | chown -R nobody ./main 4 | exec setuidgid nobody multilog t I s200000 n5 ./main 5 | 6 | -------------------------------------------------------------------------------- /examples/daemontools/scripts/build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | sh package/compile 4 | 5 | mkdir -p $DESTDIR/usr/local/bin 6 | install -m755 -oroot command/* $DESTDIR/usr/local/bin 7 | 8 | -------------------------------------------------------------------------------- /examples/nginx/index.yaml: -------------------------------------------------------------------------------- 1 | default: 2 | name: nginx 3 | http: http://nginx.org/download/nginx-1.2.6.tar.gz 4 | version: 1.2.6 5 | 6 | # cpan-module will fetch directly from CPAN 7 | -------------------------------------------------------------------------------- /examples/nginx/scripts/build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ./configure --prefix=/opt/nginx --without-pcre --without-http_gzip_module --without-http_rewrite_module 3 | make install DESTDIR=$DESTDIR 4 | -------------------------------------------------------------------------------- /examples/daemontools/scripts/post.sh: -------------------------------------------------------------------------------- 1 | if ! grep svscanboot /etc/inittab 2>&1 > /dev/null ; then 2 | echo SV1:23:respawn:/usr/local/bin/svscanboot >>/etc/inittab 3 | init q 4 | fi 5 | -------------------------------------------------------------------------------- /examples/flex/index.yaml: -------------------------------------------------------------------------------- 1 | default: 2 | name: flex 3 | summary: "flex: The Fast Lexical Analyzer" 4 | version: '2.5.35' 5 | # grab flex from http://flex.sourceforge.net/ and untar it to ./source 6 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/scripts/gembuild: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | GEMDIR=$(gem environment gemdir) 4 | mkdir -p $DESTDIR/$GEMDIR/gems/$PACKAGENAME-$PACKAGEVERSION 5 | cp -a * $DESTDIR/$GEMDIR/gems/$PACKAGENAME-$PACKAGEVERSION 6 | 7 | 8 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/templates/control.template: -------------------------------------------------------------------------------- 1 | Package: %name% 2 | Version: %version%-%release% 3 | Architecture: %arch% 4 | Depends: %requirelist% 5 | Maintainer: %whoami% 6 | Source: %name% 7 | Description: 8 | %summary% 9 | -------------------------------------------------------------------------------- /examples/daemontools/index.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | default: 3 | build: '1' 4 | name: daemontools 5 | release: '1' 6 | summary: A collection of tools for managing UNIX services. 7 | version: '0.76' 8 | x86_64: 9 | nobuild: 1 10 | preferarch: i386 11 | -------------------------------------------------------------------------------- /examples/daemontools/scripts/preun.sh: -------------------------------------------------------------------------------- 1 | if [ $1 = 0 ] ; then 2 | grep -q svscanboot /etc/inittab || exit 0 3 | mv -f /etc/inittab /etc/inittab.tmp.$$ 4 | sed /svscanboot/d /etc/inittab && rm /etc/inittab.tmp.$$ 5 | fi 6 | init q 7 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/scripts/supervisepreun.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | PATH=/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin 3 | 4 | if [ "$1" = "0" ]; then 5 | rm /service/%service% 6 | svc -dx /etc/service/%service% /etc/service/%service%/log 7 | fi 8 | 9 | -------------------------------------------------------------------------------- /examples/cpan-dbd-mysql/index.yaml: -------------------------------------------------------------------------------- 1 | default: 2 | name: cpan-dbd-mysql 3 | cpan-module: DBD::mysql 4 | preferach: i386 5 | perl: /usr/local/bin/perl 6 | env: 7 | PERLTEST=no 8 | PERLINSTALL: INSTALLDIRS=perl 9 | 10 | # cpan-module will fetch directly from CPAN 11 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/scripts/supervisepost.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH=/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin 4 | 5 | chown nobody /etc/service/%service%/log/main 6 | ln -sfn /etc/service/%service% /service/%service% 7 | svc -t /service/%service% /service/%service%/log 8 | 9 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/default.yaml: -------------------------------------------------------------------------------- 1 | default: 2 | buildprefix: '/usr/local' 3 | prefix: '/' 4 | perl: '/usr/bin/perl' 5 | version: '0.0001' 6 | shebangmunge: 1 7 | os_specific: no 8 | xfercmd: '/usr/bin/curl -s -o %s %u' 9 | 10 | rpm: 11 | autoreqprov: no 12 | epoch: 20 13 | 14 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/templates/gemspec.template: -------------------------------------------------------------------------------- 1 | Gem::Specification.new do |s| 2 | s.name = "%name%" 3 | s.version = "%version%" 4 | s.date = "1970-01-01" 5 | s.summary = "%summary%" 6 | s.email = "a@b.net" 7 | s.description = "%summary%" 8 | s.authors = ["No Body"] 9 | s.files = [ %filelist% ] 10 | end 11 | -------------------------------------------------------------------------------- /examples/yum/index.yaml: -------------------------------------------------------------------------------- 1 | default: 2 | arch: noarch 3 | name: yum 4 | version: '2.4.0' 5 | summary: 'yellowdog updater, modified' 6 | requires: 7 | - python 8 | - python-sqlite 9 | - python-urlgrabber 10 | - python-celementtree 11 | 12 | # supply yum-2.4.0.tar.gz in this directory 13 | # from http://yum.baseurl.org/download/2.4/yum-2.4.0.tar.gz, md5sum c19a471ef5f72ddca3f100a60a07d1b3 14 | 15 | -------------------------------------------------------------------------------- /scripts/transform: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Tag files with PKGVERID 4 | [ -d "$INSTALLDIR" ] || exit 1 5 | [ -n "$PKGVERID" ] || exit 1 6 | 7 | for x in `find "$INSTALLDIR" -type f`; do 8 | grep -q __MULTIPKG_BUILD_VERSION__ "$x" && sed -i -e "s,__MULTIPKG_BUILD_VERSION__,$PKGVERID," "$x" 9 | grep -q __MULTIPKG_CONFIG_DIR__ "$x" && sed -i -e "s,__MULTIPKG_CONFIG_DIR__,$PREFIX/usr/share/multipkg," "$x" 10 | done 11 | 12 | exit 0 13 | -------------------------------------------------------------------------------- /examples/yum/patches/01-fix-conf: -------------------------------------------------------------------------------- 1 | --- yum-2.4.0/etc/Makefile 2005-03-27 22:30:17.000000000 -0800 2 | +++ yum-2.4.0-noconf/etc/Makefile 2006-10-19 18:17:23.000000000 -0700 3 | @@ -12,7 +12,6 @@ install: 4 | #install -m 644 yum.pam $(DESTDIR)/etc/pam.d/yum 5 | 6 | mkdir -p $(DESTDIR)/etc/yum.repos.d 7 | - install -m 644 yum.conf $(DESTDIR)/etc/yum.conf 8 | 9 | mkdir -p $(DESTDIR)/etc/cron.daily 10 | install -m 755 yum.cron $(DESTDIR)/etc/cron.daily/yum.cron 11 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011 Yahoo! Inc. All rights reserved. 2 | 3 | This program is free software; you can redistribute it and/or modify 4 | it under the terms of either: 5 | 6 | a) the GNU General Public License as published by the Free 7 | Software Foundation, version 2, found in the included file GPLv2. 8 | b) the Perl "Artistic License," found in the included file PERLARTISTIC. 9 | 10 | Authors: 11 | 12 | Erik Bourget 13 | Bruno Connelly 14 | Chris Wing 15 | Syam Purnam 16 | Evan Miller 17 | 18 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/scripts/build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ -f Makefile.PL ]; then 4 | $PERL Makefile.PL 5 | make || exit 1 6 | make test || exit 1 7 | make install DESTDIR=$DESTDIR || exit 1 8 | find $DESTDIR -name perllocal.pod -type f -exec rm {} \; 9 | find $DESTDIR -name .packlist -type f -exec rm {} \; 10 | elif [ -f setup.py ]; then 11 | python setup.py install --root $DESTDIR 12 | else 13 | ./configure --prefix=$PREFIX || exit 1 14 | make || exit 1 15 | make install DESTDIR=$DESTDIR INSTALLROOT=$DESTDIR || exit 1 16 | rm -f $DESTDIR/usr/local/info/dir 17 | fi 18 | 19 | -------------------------------------------------------------------------------- /index.yaml: -------------------------------------------------------------------------------- 1 | default: 2 | name: multipkg 3 | version: '1.2' 4 | summary: Automation for package builds (supports RPM, deb) 5 | buildprefix: /usr 6 | rpm: 7 | arch: noarch 8 | provides: 9 | - Seco::Multipkg 10 | - perl-seco-class 11 | - perl-seco-cpan 12 | requires: 13 | - perl-YAML-Syck 14 | - subversion-perl 15 | - perl-Git 16 | - perl-Error 17 | deb: 18 | arch: all 19 | provides: 20 | - perl-seco-class 21 | - perl-seco-cpan 22 | requires: 23 | - libfile-fnmatch-perl 24 | - libyaml-syck-perl 25 | - libsvn-perl 26 | - liberror-perl 27 | -------------------------------------------------------------------------------- /source/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use ExtUtils::MakeMaker; 5 | 6 | WriteMakefile( 7 | NAME => 'multipkg', 8 | AUTHOR => q{m10n-pe }, 9 | VERSION_FROM => 'lib/Seco/Multipkg.pm', 10 | ABSTRACT_FROM => 'lib/Seco/Multipkg.pm', 11 | ($ExtUtils::MakeMaker::VERSION >= 6.3002 12 | ? ('LICENSE'=> 'perl') 13 | : ()), 14 | PL_FILES => {}, 15 | PREREQ_PM => { 16 | 'Test::More' => 0, 17 | }, 18 | dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, 19 | clean => { FILES => 'multipkg-*' }, 20 | ); 21 | -------------------------------------------------------------------------------- /scripts/build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ ! -x "$PERL" ]; then 4 | PERL=/usr/bin/perl 5 | fi 6 | if [ "$PREFIX" = "" ]; then 7 | CONFIGDIR="/usr/share/multipkg" 8 | else 9 | CONFIGDIR="${PREFIX}/share/multipkg" 10 | fi 11 | 12 | if [ -f Makefile.PL ]; then 13 | $PERL Makefile.PL 14 | make CONFIGDIR="$CONFIGDIR" || exit 1 15 | make test || exit 1 16 | make install DESTDIR=$DESTDIR || exit 1 17 | find $DESTDIR -name perllocal.pod -type f -exec rm {} \; 18 | else 19 | ./configure --prefix=$PREFIX || exit 1 20 | make CONFIGDIR="$CONFIGDIR" || exit 1 21 | make install DESTDIR=$DESTDIR INSTALLROOT=$DESTDIR || exit 1 22 | rm -f $DESTDIR/usr/local/info/dir 23 | fi 24 | 25 | -------------------------------------------------------------------------------- /root/usr/share/multipkg/templates/spec.template: -------------------------------------------------------------------------------- 1 | Summary: %summary% 2 | Name: %name% 3 | Version: %version% 4 | Release: %release% 5 | License: %license% 6 | Group: Local 7 | Provides: %name% %providelist% 8 | Packager: %whoami% 9 | BuildRoot: %buildroot% 10 | BuildArch: %arch% 11 | autoreqprov: no 12 | Requires: %requirelist% 13 | Conflicts: %conflictlist% 14 | Obsoletes: %obsoletelist% 15 | %%ifset(prefix) 16 | Prefix: %prefix% 17 | %%endif 18 | 19 | %description 20 | %summary% 21 | 22 | %%ifscript(pre.sh) 23 | %pre 24 | %%pre.sh%% 25 | %%endif 26 | 27 | %%ifscript(post.sh) 28 | %post 29 | %%post.sh%% 30 | %%endif 31 | 32 | %%ifscript(preun.sh) 33 | %preun 34 | %%preun.sh%% 35 | %%endif 36 | 37 | %%ifscript(postun.sh) 38 | %postun 39 | %%postun.sh%% 40 | %%endif 41 | 42 | %%ifscript(posttrans.sh) 43 | %posttrans 44 | %%posttrans.sh%% 45 | %%endif 46 | 47 | %%ifscript(verifyscript.sh) 48 | %verifyscript 49 | %%verifyscript.sh%% 50 | %%endif 51 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | Multipkg 2 | ============== 3 | Multipkg automates and versions your package builds. 4 | 5 | Installation 6 | -------------- 7 | Multipkg is best installed via rpms/debs built by... Multipkg. 8 | 9 | The bootstrap process is a little primitive now, but here are the steps: 10 | 11 | 1. Install your developer tools 12 | * might be unnecessary now 13 | * yum -y groupinstall "Development Tools" 14 | 1. install YAML::Syck and makemaker 15 | 
16 | yum install perl-YAML-Syck perl-ExtUtils-MakeMaker
17 |
18 | 1. git clone multipkg 19 | 1. cd multipkg 20 | 1. manually build and install your first multipkg package 21 | 
22 | PREFIX=./root PKGVERID=0 INSTALLDIR=source scripts/transform
23 | perl -I ./source/lib root/usr/bin/multipkg -t .
24 | sudo yum -y install multipkg-*rpm
25 |
26 | 1. Remove the first package 27 | 
28 | rm multipkg*rpm
29 |
30 | 1. Build your final multipkg package from git 31 | 
32 | git-multipkg -b https://github.com/ytoolshed/ multipkg
33 |
34 | 1. upgrade on the current host immediately so there is no confusion 35 | 
36 | sudo yum upgrade ./multipkg*rpm
37 |
38 | 1. ENJOY 39 | -------------------------------------------------------------------------------- /source/lib/Seco/HTTP.pm: -------------------------------------------------------------------------------- 1 | package Seco::HTTP; 2 | 3 | # created at : 2013-03-21 15:56:19 4 | # author : Jianing Yang 5 | 6 | use strict; 7 | use base qw(Seco::Class); 8 | 9 | use File::Copy qw(copy); 10 | use File::Temp qw/tempfile tempdir/; 11 | use Cwd; 12 | use Getopt::Long qw/:config require_order gnu_compat/; 13 | 14 | BEGIN { 15 | __PACKAGE__->_accessors(xfercmd => undef, 16 | depositdir => undef, 17 | tmpdir => undef); 18 | __PACKAGE__->_requires(qw/depositdir/); 19 | } 20 | 21 | sub _init { 22 | my $self = shift; 23 | 24 | mkdir $self->depositdir 25 | unless(-d $self->depositdir); 26 | 27 | $self->tmpdir(tempdir(CLEANUP => 0)) 28 | unless(-d $self->tmpdir); 29 | 30 | return 1; 31 | } 32 | 33 | sub pull { 34 | my $self = shift; 35 | my $url = shift; 36 | 37 | my $basedir = $self->tmpdir . "/build"; 38 | mkdir $basedir unless(-d $basedir); 39 | 40 | my $tarball = $self->depositdir . '/source.tar.gz'; 41 | my $xfercmd = $self->xfercmd; 42 | 43 | $xfercmd =~ s/%s/$tarball/; 44 | $xfercmd =~ s/%u/$url/; 45 | 46 | system($xfercmd); 47 | return undef if($? >> 8); 48 | 49 | return { tarball => $tarball }; 50 | } 51 | 52 | 1; 53 | -------------------------------------------------------------------------------- /root/usr/bin/multipkg: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # Copyright (c) 2011 Yahoo! Inc. All rights reserved. 3 | 4 | use strict; 5 | 6 | use constant MULTIPKG_VERSION => '__MULTIPKG_BUILD_VERSION__'; 7 | 8 | use Seco::Multipkg; 9 | use Getopt::Long; 10 | 11 | # metadata tracing 12 | my $init_metadata = { 13 | 'actionlog' => [ 14 | { 'actor' => whoami(), 15 | 'time' => time(), 16 | 'type' => 'build', 17 | 'actions' => [ 18 | { 'summary' => 'multipkg initialiation', 19 | 'text' => "multipkg version: " 20 | . MULTIPKG_VERSION . "\n" 21 | . "invoked as: $0 " 22 | . join( ' ', @ARGV ) . "\n", 23 | }, 24 | ], 25 | }, 26 | ], 27 | }; 28 | 29 | my %opt = ( 30 | 'h|help' => "Display this help", 31 | 'v|verbose' => "Be verbose", 32 | 'k|keep-files' => "Keep files after build", 33 | 's|set=s' => "List of variables to set", 34 | 'f|force' => "Force build on sanity-check failure", 35 | 'p|platform=s' => "Include this platform", 36 | 't|testbuild' => "When building from a work dir, not source control", 37 | ); 38 | 39 | my %o; 40 | usage() unless GetOptions( \%o, keys %opt ); 41 | usage() if ( $o{h} ); 42 | usage() unless ( scalar @ARGV ); 43 | 44 | my %overrides = (); 45 | if ( $o{s} ) { 46 | my @sets = split /,/, $o{s}; 47 | for (@sets) { 48 | my ( $k, $v ) = split /=/, $_; 49 | $overrides{$k} = $v; 50 | } 51 | } 52 | 53 | # release must be specified unless we are making a test build. 54 | #unless ( $o{t} || defined( $overrides{'release'} ) ) { 55 | # print "*****************************************************************************\n" 56 | # . "multipkg cannot be run directly by user unless building a test release via -t\n" 57 | # . "*****************************************************************************\n" 58 | # . "Use svn-multipkg/p4-multipkg to build directly from source checkout when\n" 59 | # . "creating packages for production deployment.\n\n"; 60 | # exit(1); 61 | #} 62 | 63 | for (@ARGV) { 64 | my $mp = Seco::Multipkg->new( 65 | directory => $_, 66 | cleanup => !$o{k}, 67 | force => $o{f}, 68 | warn_on_error => 1, 69 | verbose => $o{v}, 70 | platform => $o{p}, 71 | overrides => \%overrides, 72 | meta => $init_metadata 73 | ) or exit 1; 74 | 75 | my $package = $mp->build 76 | or die $mp->error . "\n"; 77 | 78 | print "$package\n"; 79 | } 80 | 81 | sub usage { 82 | my $msg = shift; 83 | $msg = "\n$msg\n" if ($msg); 84 | $msg ||= ''; 85 | 86 | print "NOTE: -t is required to run multipkg by hand; production package builds must\n" 87 | . "use svn-multipkg/p4-multipkg to build directly from source checkout\n\n"; 88 | print "Usage: $0 [options]\n"; 89 | 90 | my @array; 91 | foreach my $key ( keys %opt ) { 92 | my ( $left, $right ) = split /[=:]/, $key; 93 | my ( $a, $b ) = split /\|/, $left; 94 | if ($b) { 95 | $left = "-$a, --$b"; 96 | } 97 | else { 98 | $left = " --$a"; 99 | } 100 | $left = substr( $left . ( ' ' x 20 ), 0, 20 ); 101 | push @array, "$left $opt{$key}\n"; 102 | } 103 | 104 | print sort @array; 105 | 106 | die "$msg\n"; 107 | } 108 | 109 | # generate identifying string for this host/user 110 | sub whoami { 111 | my $name; 112 | eval { 113 | require Sys::Hostname; 114 | 115 | my $user = getpwuid($<); 116 | $user = 'unknown' unless ( defined($user) ); 117 | 118 | $name = $user . '@' . Sys::Hostname->hostname(); 119 | }; 120 | $name = 'unknown' if ($@); 121 | 122 | return $name; 123 | } 124 | -------------------------------------------------------------------------------- /source/lib/Seco/CPAN.pm: -------------------------------------------------------------------------------- 1 | package Seco::CPAN; 2 | # Copyright (c) 2011 Yahoo! Inc. All rights reserved. 3 | 4 | use strict; 5 | use base qw(Seco::Class); 6 | 7 | use File::Copy qw(copy); 8 | use File::Temp qw/tempfile tempdir/; 9 | use Cwd; 10 | use Getopt::Long qw/:config require_order gnu_compat/; 11 | 12 | BEGIN { 13 | __PACKAGE__->_accessors(mirror => 'http://www.perl.com/CPAN', 14 | depositdir => undef, 15 | tmpdir => undef); 16 | __PACKAGE__->_requires(qw/depositdir/); 17 | } 18 | 19 | sub _init { 20 | my $self = shift; 21 | mkdir $self->depositdir; 22 | $self->tmpdir(tempdir(CLEANUP => 0)) 23 | unless(-d $self->tmpdir); 24 | return 1; 25 | } 26 | 27 | sub pull { 28 | my $self = shift; 29 | my $module = shift; 30 | 31 | my $basedir = $self->tmpdir . "/cpanbuild"; 32 | mkdir $basedir unless(-d $basedir); 33 | my $tarball; 34 | 35 | require CPAN; 36 | 37 | $INC{'CPAN/Config.pm'} = '/dev/null'; 38 | 39 | $CPAN::Config->{cpan_home} = "$basedir"; 40 | $CPAN::Config->{build_dir} = "$basedir/build"; 41 | $CPAN::Config->{build_cache} = q[10]; 42 | $CPAN::Config->{cache_metadata} = q[1]; 43 | $CPAN::Config->{cpan_version_check} = q[1]; 44 | $CPAN::Config->{ftp} = q[/usr/bin/ftp]; 45 | $CPAN::Config->{ftp_proxy} = q[]; 46 | 47 | $CPAN::Config->{getcwd} = q[cwd]; 48 | $CPAN::Config->{gpg} = q[/usr/bin/gpg]; 49 | $CPAN::Config->{gzip} = q[/bin/gzip]; 50 | $CPAN::Config->{histsize} = q[100]; 51 | $CPAN::Config->{http_proxy} = q[]; 52 | $CPAN::Config->{inactivity_timeout} = q[0]; 53 | $CPAN::Config->{index_expire} = q[1]; 54 | $CPAN::Config->{inhibit_startup_message} = q[0]; 55 | $CPAN::Config->{lynx} = q[]; 56 | $CPAN::Config->{make} = q[/usr/bin/make]; 57 | $CPAN::Config->{make_arg} = q[]; 58 | $CPAN::Config->{make_install_arg} = q[]; 59 | $CPAN::Config->{makepl_arg} = q[INSTALLDIRS=site]; 60 | $CPAN::Config->{ncftpget} = q[/usr/bin/ncftpget]; 61 | $CPAN::Config->{no_proxy} = q[]; 62 | $CPAN::Config->{pager} = q[/usr/bin/less]; 63 | $CPAN::Config->{prerequisites_policy} = q[ask]; 64 | $CPAN::Config->{scan_cache} = q[atstart]; 65 | $CPAN::Config->{shell} = q[/bin/bash]; 66 | $CPAN::Config->{tar} = q[/bin/tar]; 67 | $CPAN::Config->{term_is_latin} = q[1]; 68 | $CPAN::Config->{unzip} = q[/usr/bin/unzip]; 69 | $CPAN::Config->{wget} = q[/usr/bin/wget]; 70 | 71 | unshift @{$CPAN::Config->{'urllist'}}, $self->mirror; 72 | $CPAN::Config->{histfile} = "$basedir/history"; 73 | $CPAN::Config->{keep_source_where} = "$basedir/source"; 74 | $CPAN::Config->{prerequisites_policy} = 'ignore'; 75 | $CPAN::Config->{cpan_version_check} = 0; 76 | 77 | # CPAN is very loud :( 78 | open REAL, ">&STDOUT"; 79 | open STDOUT, ">/dev/null"; 80 | 81 | my $mod = CPAN::Shell->expand('Module', '/^'.$module.'$/') 82 | or do { open STDOUT, ">&REAL"; die "Can't find $module on CPAN"; }; 83 | my $version = $mod->cpan_version; 84 | 85 | my $dist = $CPAN::META->instance('CPAN::Distribution', 86 | $mod->cpan_file); 87 | $dist->get or do { 88 | open STDOUT, ">&REAL"; die "Cannot get ", $mod->cpan_file, "\n"; 89 | }; 90 | my $name = $mod->{ID}; 91 | $tarball = $dist->{localfile}; 92 | open STDOUT, ">&REAL"; 93 | 94 | system('cp', $tarball, $self->depositdir); 95 | return undef if($? >> 8); 96 | $tarball =~ s/^.*\///; 97 | $name =~ s/::/-/g; 98 | return { tarball => $self->depositdir . "/" . $tarball, 99 | name => 'cpan-' . $name, 100 | version => $version }; 101 | } 102 | 103 | 1; 104 | -------------------------------------------------------------------------------- /root/usr/bin/svn-multipkg: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # Copyright (c) 2011 Yahoo! Inc. All rights reserved. 3 | 4 | use strict; 5 | use warnings FATAL => qw/uninitialized/; 6 | 7 | use constant MULTIPKG_VERSION => '__MULTIPKG_BUILD_VERSION__'; 8 | 9 | use Getopt::Long; 10 | use YAML::Syck; 11 | use File::Path; 12 | use File::Temp; 13 | use SVN::Client; 14 | use HTTP::Date; 15 | 16 | # metadata tracing 17 | my @actions; 18 | my $init_action = { 19 | 'actor' => whoami(), 20 | 'time' => time(), 21 | 'type' => 'build', 22 | 'actions' => [ 23 | { 'summary' => 'svn-multipkg initialiation', 24 | 'text' => "svn-multipkg version: " 25 | . MULTIPKG_VERSION . "\n" 26 | . "invoked as: $0 " 27 | . join( ' ', @ARGV ) . "\n", 28 | }, 29 | ], 30 | }; 31 | 32 | sub usage() { 33 | print < 35 | Options: 36 | -c, changelog include changelog 37 | -m, mtime set mtime on files from last revision 38 | -b, baseuri=s base URI for SVN repo 39 | -r, rev=s revision to checkout 40 | -k, keep keep the temporary directory 41 | -v, verbose verbose 42 | -p, platform=s platform 43 | -s, set=s List of variables to set 44 | EOF 45 | exit(0); 46 | } 47 | 48 | my $opt = { 49 | 'b' => '', 50 | 'r' => 'HEAD', 51 | 'c' => 1, 52 | 'm' => 1, 53 | }; 54 | 55 | my %getoptions = ( 56 | 'c|changelog' => 'include changelog', 57 | 'm|mtime' => 'set mtime on files from last revision', 58 | 'b|baseuri=s' => 'base URI for SVN repo', 59 | 'r|rev=s' => 'revision to checkout', 60 | 'k|keep' => 'keep the temporary directory', 61 | 'v|verbose' => 'verbose', 62 | 'p|platform=s' => 'platform', 63 | 's|set=s' => 'List of variables to set', 64 | ); 65 | 66 | usage() unless GetOptions( $opt, keys %getoptions ); 67 | usage() if ( $opt->{h} ); 68 | 69 | my $package = shift || usage(); 70 | my $url = $opt->{b} . '/' . $package; 71 | my $verbose = $opt->{v}; 72 | my $wantrev = $opt->{r}; 73 | my $ctx = SVN::Client::->new; 74 | my $tmp = File::Temp::tempdir( CLEANUP => ( !defined( $opt->{k} ) ) ); 75 | my $srcdir = "$tmp/src"; 76 | my $build = "$tmp/build"; 77 | my $rev; 78 | 79 | # options to pass through to multipkg 80 | my @multipkg_opts = map { ("-$_") } grep { $opt->{$_} } (qw/k v/); 81 | 82 | info("get last change revision $url @ $wantrev"); 83 | $ctx->info( 84 | $url, undef, $wantrev, 85 | sub { 86 | my ( $path, $info ) = @_; 87 | $rev = $info->last_changed_rev; 88 | }, 89 | 0 90 | ); 91 | info("wanted revision $wantrev, got revision $rev"); 92 | 93 | info("checkout $url @ $rev to $srcdir"); 94 | $ctx->checkout( $url, $srcdir, $rev, 1 ); 95 | 96 | info("export $srcdir to $build"); 97 | $ctx->export( $srcdir, $build, undef, 1 ); 98 | 99 | if ( $opt->{m} ) { 100 | info("ls $url @ $rev"); 101 | my $nodes = $ctx->ls( $url, $rev, 1 ); 102 | 103 | for ( keys %$nodes ) { 104 | next unless ( $nodes->{$_}->kind == $SVN::Node::file ); 105 | # XXX: because there is no lutimes(), skip symlinks 106 | lstat("$build/$_") or die "can't lstat file from svn export: $build/$_"; 107 | next if ( -l _ ); 108 | 109 | my $mtime = int( $nodes->{$_}->time / 1000000 ); 110 | utime( $mtime, $mtime, "$build/$_" ) 111 | or die "could not set mtime on file: $_"; 112 | } 113 | } 114 | 115 | # metadata trace for checkout operation 116 | my $checkout_action = { 117 | 'actor' => whoami(), 118 | 'time' => time(), 119 | 'type' => 'build', 120 | 'actions' => [ 121 | { 'summary' => 'svn-multipkg checkout source from svn', 122 | 'text' => "url : $url\n" . "revision : $rev\n", 123 | }, 124 | ], 125 | }; 126 | 127 | if ( $opt->{c} ) { 128 | info("generating action log from revision history"); 129 | $ctx->log( 130 | $url, $rev, 0, 0, 0, 131 | sub { 132 | my ( $changed_paths, $revision, $author, $date, $message ) = @_; 133 | my $time = str2time $date; 134 | my $change_action = { 135 | 'actor' => $author, 136 | 'time' => $time, 137 | 'type' => 'source', 138 | 'actions' => [ 139 | { 'summary' => "SVN revision $revision", 140 | 'text' => $message, 141 | }, 142 | ], 143 | }; 144 | # XXX: svn returns log in reverse chronological order 145 | unshift @actions, $change_action; 146 | }, 147 | ); 148 | 149 | die "no revision history" unless (@actions); 150 | } 151 | 152 | # write out metadata 153 | mkpath("$build/meta"); 154 | my $metafile = "$build/meta/51svn-multipkg.yaml"; 155 | die "metadata file already exists: $metafile" if ( -e $metafile ); 156 | 157 | my $metadata = { 'actionlog' => [ @actions, $init_action, $checkout_action ], }; 158 | 159 | info("writing metadata"); 160 | YAML::Syck::DumpFile( $metafile, $metadata ); 161 | 162 | info("invoking multipkg"); 163 | 164 | my $platform = $opt->{p}; 165 | my @plat = (); 166 | @plat = ( '-p', $platform ) if ( defined $platform ); 167 | my $override_vars = ''; 168 | if ( defined( $opt->{s} ) ) { 169 | $override_vars = $opt->{s} . ','; 170 | } 171 | $ENV{'SRCZIP'} = 'svn'; 172 | system( 'multipkg', @plat, @multipkg_opts, '-s', 173 | $override_vars . "release=$rev,srcurl=$url,srcdir=$srcdir", $build ) == 0 174 | or die "fatal: multipkg died :|"; 175 | 176 | sub info { print "info: @_ \n" if ($verbose); } 177 | sub fatal { print "fatal: @_ \n"; exit 111; } 178 | 179 | # generate identifying string for this host/user 180 | sub whoami { 181 | my $name; 182 | eval { 183 | require Sys::Hostname; 184 | 185 | my $user = getpwuid($<); 186 | $user = 'unknown' unless ( defined($user) ); 187 | 188 | $name = $user . '@' . Sys::Hostname->hostname(); 189 | }; 190 | $name = 'unknown' if ($@); 191 | 192 | return $name; 193 | } 194 | 195 | __END__ 196 | -------------------------------------------------------------------------------- /root/usr/bin/hg-multipkg: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | # Modified from Noah Meyerhans' git-multipkg, written by Jianing YANG 4 | # . 5 | 6 | # Copyright (c) 2011 Noah Meyerhans All rights reserved. 7 | # This program is free software; you can redistribute it and/or modify 8 | # it under the terms of either: 9 | 10 | # a) the GNU General Public License as published by the Free 11 | # Software Foundation, version 2, found in the included file GPLv2. 12 | # b) the Perl "Artistic License," found in the included file PERLARTISTIC. 13 | 14 | use strict; 15 | use Data::Dumper; 16 | use File::Temp; 17 | use File::Basename; 18 | use File::Spec; 19 | use Getopt::Long; 20 | 21 | Getopt::Long::Configure("bundling"); 22 | 23 | my $opt = { 24 | 'b' => '', 25 | 'r' => 'tip', 26 | 'B' => 'default', 27 | }; 28 | 29 | my %options = ( 30 | 'h|help' => 'show usage information', 31 | 'b|baseurl=s' => 'base URI for the mercurial repo', 32 | 'B|branch=s' => 'branch to build from', 33 | 'r|rev=s' => 'revision to build (default=HEAD)', 34 | 'k|keep' => 'do not delete the working directory', 35 | 'v|verbose' => 'verbose output', 36 | 'f|force' => 'Force through multipkg errors', 37 | ); 38 | 39 | usage() unless GetOptions( $opt, keys %options ); 40 | my $package = shift; 41 | 42 | usage() if( $opt->{h} ); 43 | usage() unless( $opt->{b} ); 44 | usage() unless( $package ); 45 | 46 | my $verbose = $opt->{v}; 47 | 48 | sub usage { 49 | print < 52 | Options: 53 | -c, changelog include changelog (NOT IMPLEMENTED) 54 | -m, mtime set mtime on files from last revision (NOT IMPLEMENTED) 55 | -b, baseuri=s base URI for Mercurial repo 56 | -r, rev=s revision to checkout 57 | -B, branch=s branch to build from (default=default) 58 | -k, keep keep the temporary directory 59 | -v, verbose verbose 60 | -p, platform=s platform 61 | -s, set=s List of variables to set 62 | -f, force Force through multipkg errors 63 | 64 | EOF 65 | exit(0); 66 | } 67 | 68 | sub info { print "info: @_ \n" if ($verbose); } 69 | sub fatal { print "fatal: @_ \n"; exit 111; } 70 | 71 | # Clone the source repository to a local directory 72 | sub clone { 73 | my ($repo, $target, $opts) = @_; 74 | info("Cloning from $repo to $target"); 75 | my $out = qx(hg clone -u $opts->{B} $repo $target); 76 | info($out); 77 | } 78 | 79 | # Call multipkg 80 | sub pkg { 81 | my ($opts, $pkg, $srcdir, $build, $ts) = @_; 82 | info("Invoking multipkg on $srcdir"); 83 | # options to pass through to multipkg 84 | my @multipkg_opts = map { ("-$_") } grep { $opts->{$_} } (qw/k v f/); 85 | my $vars = "release=$ts,srcurl=$opts->{b},srcdir=$srcdir"; 86 | print "BUILD:$build\n"; 87 | system("multipkg", '-s', $vars, @multipkg_opts, $build); 88 | } 89 | 90 | # Copy the contents of the hg repository to the build directory 91 | sub archive { 92 | my ($src, $dest, $opts) = @_; 93 | my $cwd = $ENV{PWD}; 94 | info("archiving $src to $dest"); 95 | my $cmd = "hg archive -p . -t tar -r $opts->{r} - | (cd $dest && tar xf -)"; 96 | info("Running $cmd"); 97 | chdir($src); 98 | mkdir($dest); 99 | system($cmd); 100 | chdir($cwd); 101 | } 102 | 103 | sub get_timestamp { 104 | my ($dir, $rev) = @_; 105 | my $ts = 0; 106 | my $oldPWD = $ENV{PWD}; 107 | info("Gathering revision timestamp information for $dir\@$rev"); 108 | chdir($dir) or die; 109 | $ts = qx(hg log -r $rev --template '{date|hgdate}'); 110 | ($ts) = split /\s+/, $ts; 111 | chdir($oldPWD); 112 | die "Did not get a meaningful timestamp for $dir at $rev\n" unless($ts > 0); 113 | return $ts; 114 | } 115 | 116 | sub getrepo { 117 | my $path = shift; 118 | return [ split '/', $path ]->[0]; 119 | } 120 | 121 | sub getpkg { 122 | my $path = shift; 123 | return File::Basename::basename($path); 124 | } 125 | 126 | sub getpkgpath { 127 | my $path = shift; 128 | my $repo = getrepo($path); 129 | 130 | my $pkgpath = $path; 131 | $pkgpath =~ s{^$repo/?}{}; 132 | return $pkgpath; 133 | } 134 | 135 | sub main { 136 | my ($opts, $path) = @_; 137 | 138 | # Prepare the package, base and repo from the provided base URI 139 | 140 | # Package name is always the same 141 | my $pkg = getpkg($path); 142 | 143 | # $pkgbase is contrived from the base uri and package path provided 144 | # $repo is fed to hg clone 145 | my ($pkgbase, $repo); 146 | 147 | if ($opts->{b} =~ /^http/) { 148 | # can't use File::Spec->catdir for these because it'll destory the two 149 | # slashes in http://whatever.com/repo 150 | my $repoid = getrepo($path); 151 | $repoid =~ s{^/+}{}; 152 | my $base = $opts->{b}; 153 | $base =~ s{/+$}{}; 154 | 155 | $repo = "${base}/${repoid}"; 156 | $pkgbase = getpkgpath($path); 157 | } 158 | elsif ($opts->{b} =~ /\.hg$/){ 159 | $repo = $opts->{b}; 160 | 161 | # if $path is just a repo name, not a full path... 162 | if ( File::Basename::basename( $path ) eq $path ) { 163 | $pkgbase = ''; 164 | } 165 | else { 166 | #otherwise, shave off the first part of the path 167 | $pkgbase = $path; 168 | $pkgbase =~ s{^[^/]+/}{}; 169 | } 170 | } 171 | else { 172 | # -b was not provided 173 | # SHOULD NEVER BE REACHED 174 | die "unsupported base"; 175 | } 176 | 177 | my $dir = File::Temp::tempdir(CLEANUP => ( !defined($opts->{k}) )); 178 | my $build = "$dir/build"; 179 | my $clonedir = "$dir/clone"; 180 | clone($repo, $clonedir, $opts); 181 | 182 | my $srcdir = File::Spec->catdir($dir, 'src'); 183 | symlink File::Spec->catdir($clonedir, $pkgbase), $srcdir; 184 | archive($srcdir, $build, $opts); 185 | my $ts = get_timestamp($clonedir, $opts->{r}); 186 | pkg($opts, $pkg, $srcdir, $build, $ts); 187 | } 188 | 189 | main($opt, $package); 190 | -------------------------------------------------------------------------------- /root/usr/bin/git-multipkg: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # Copyright (c) 2011 Noah Meyerhans All rights reserved. 3 | # This program is free software; you can redistribute it and/or modify 4 | # it under the terms of either: 5 | 6 | # a) the GNU General Public License as published by the Free 7 | # Software Foundation, version 2, found in the included file GPLv2. 8 | # b) the Perl "Artistic License," found in the included file PERLARTISTIC. 9 | 10 | use strict; 11 | use Git; 12 | use Data::Dumper; 13 | use File::Temp; 14 | use File::Basename; 15 | use File::Spec; 16 | use Getopt::Long; 17 | 18 | Getopt::Long::Configure("bundling"); 19 | 20 | my $opt = { 21 | 'b' => '', 22 | 'r' => 'HEAD', 23 | 'B' => 'master', 24 | }; 25 | 26 | my %options = ( 27 | 'h|help' => 'show usage information', 28 | 'b|baseurl=s' => 'base URI for the git repo', 29 | 'B|branch=s' => 'branch to build from', 30 | 'r|rev=s' => 'revision to build (default=HEAD)', 31 | 'k|keep' => 'do not delete the working directory', 32 | 'v|verbose' => 'verbose output', 33 | 'f|force' => 'Force through multipkg errors', 34 | ); 35 | 36 | usage() unless GetOptions( $opt, keys %options ); 37 | my $package = shift; 38 | 39 | usage() if( $opt->{h} ); 40 | usage() unless( $opt->{b} ); 41 | usage() unless( $package ); 42 | 43 | my $verbose = $opt->{v}; 44 | 45 | sub usage { 46 | print < 49 | Options: 50 | -c, changelog include changelog (NOT IMPLEMENTED) 51 | -m, mtime set mtime on files from last revision (NOT IMPLEMENTED) 52 | -b, baseuri=s base URI for GIT repo 53 | -r, rev=s revision to checkout 54 | -B, branch=s branch to build from (default=master) 55 | -k, keep keep the temporary directory 56 | -v, verbose verbose 57 | -p, platform=s platform 58 | -s, set=s List of variables to set 59 | -f, force Force through multipkg errors 60 | 61 | Examples: 62 | git-multipkg -b https://github.com/ytoolshed/ multipkg 63 | git-multipkg -b https://github.com/ytoolshed/ range/libcrange 64 | 65 | git-multipkg -b git\@github.com:ytoolshed/multipkg.git multipkg 66 | git-multipkg -b git\@github.com:ytoolshed/range.git range/libcrange 67 | 68 | EOF 69 | exit(0); 70 | } 71 | 72 | sub info { print "info: @_ \n" if ($verbose); } 73 | sub fatal { print "fatal: @_ \n"; exit 111; } 74 | 75 | # Clone the source repository to a local directory 76 | sub clone { 77 | my ($repo, $target, $opts) = @_; 78 | info("Cloning from $repo to $target"); 79 | my $out = Git::command('clone', '-b', $opts->{B}, $repo, $target); 80 | info($out); 81 | } 82 | 83 | # Call multipkg 84 | sub pkg { 85 | my ($opts, $pkg, $srcdir, $build, $ts) = @_; 86 | info("Invoking multipkg on $srcdir"); 87 | # options to pass through to multipkg 88 | my @multipkg_opts = map { ("-$_") } grep { $opts->{$_} } (qw/k v f/); 89 | my $vars = "release=$ts,srcurl=$opts->{b},srcdir=$srcdir"; 90 | system("multipkg", '-s', $vars, @multipkg_opts, $build); 91 | } 92 | 93 | # Copy the contents of the git repository to the build directory 94 | sub archive { 95 | my ($src, $dest, $opts) = @_; 96 | my $cwd = $ENV{PWD}; 97 | info("archiving $src to $dest"); 98 | my $cmd = "git archive --format tar $opts->{r} | (cd $dest && tar xf -)"; 99 | info("Running $cmd"); 100 | chdir($src); 101 | mkdir($dest); 102 | system($cmd); 103 | chdir($cwd); 104 | } 105 | 106 | sub get_timestamp { 107 | my ($dir, $rev) = @_; 108 | my $ts = 0; 109 | my $oldPWD = $ENV{PWD}; 110 | info("Gathering revision timestamp information for $dir\@$rev"); 111 | chdir($dir) or die; 112 | $ts = Git::command_oneline('log', '-1', '--pretty=format:%ct', $rev); 113 | chdir($oldPWD); 114 | die "Did not get a meaningful timestamp for $dir at $rev\n" unless($ts > 0); 115 | return $ts; 116 | } 117 | 118 | sub getrepo { 119 | my $path = shift; 120 | return [ split '/', $path ]->[0]; 121 | } 122 | 123 | sub getpkg { 124 | my $path = shift; 125 | return File::Basename::basename($path); 126 | } 127 | 128 | sub getpkgpath { 129 | my $path = shift; 130 | my $repo = getrepo($path); 131 | 132 | my $pkgpath = $path; 133 | $pkgpath =~ s{^$repo/?}{}; 134 | return $pkgpath; 135 | } 136 | 137 | sub main { 138 | my ($opts, $path) = @_; 139 | 140 | # Prepare the package, base and repo from the provided base URI 141 | 142 | # Package name is always the same 143 | my $pkg = getpkg($path); 144 | 145 | # $pkgbase is contrived from the base uri and package path provided 146 | # $repo is fed to git clone 147 | my ($pkgbase, $repo); 148 | 149 | if ($opts->{b} =~ /^http/) { 150 | # can't use File::Spec->catdir for these because it'll destory the two 151 | # slashes in http://whatever.com/repo 152 | my $repoid = getrepo($path); 153 | $repoid =~ s{^/+}{}; 154 | my $base = $opts->{b}; 155 | $base =~ s{/+$}{}; 156 | 157 | $repo = "${base}/${repoid}"; 158 | $pkgbase = getpkgpath($path); 159 | } 160 | elsif ($opts->{b} =~ /\.git$/){ 161 | $repo = $opts->{b}; 162 | 163 | # if $path is just a repo name, not a full path... 164 | if ( File::Basename::basename( $path ) eq $path ) { 165 | $pkgbase = ''; 166 | } 167 | else { 168 | #otherwise, shave off the first part of the path 169 | $pkgbase = $path; 170 | $pkgbase =~ s{^[^/]+/}{}; 171 | } 172 | } 173 | else { 174 | # -b was not provided 175 | # SHOULD NEVER BE REACHED 176 | die "unsupported base"; 177 | } 178 | 179 | my $dir = File::Temp::tempdir(CLEANUP => ( !defined($opts->{k}) )); 180 | my $build = "$dir/build"; 181 | my $clonedir = "$dir/clone"; 182 | clone($repo, $clonedir, $opts); 183 | 184 | my $srcdir = File::Spec->catdir($dir, 'src'); 185 | symlink File::Spec->catdir($clonedir, $pkgbase), $srcdir; 186 | archive($srcdir, $build, $opts); 187 | my $ts = get_timestamp($clonedir, $opts->{r}); 188 | pkg($opts, $pkg, $srcdir, $build, $ts); 189 | } 190 | 191 | main($opt, $package); 192 | -------------------------------------------------------------------------------- /source/lib/Seco/Class.pm: -------------------------------------------------------------------------------- 1 | package Seco::Class; 2 | # Copyright (c) 2011 Yahoo! Inc. All rights reserved. 3 | use strict; 4 | 5 | use overload '""' => sub { shift->stringify_self; }; 6 | 7 | sub stringify_self { 8 | my $self = shift; 9 | my $string = "No stringification available."; 10 | 11 | eval { 12 | require Data::Dumper; 13 | $string = Data::Dumper::Dumper($self); 14 | }; 15 | 16 | return $string; 17 | } 18 | 19 | sub new { 20 | my $proto = shift; 21 | my %rest; 22 | if(@_ == 0) { 23 | %rest = (); 24 | } elsif(@_ == 1) { 25 | %rest = %{$_[0]} if (ref $_[0] eq 'HASH'); 26 | } else { 27 | %rest = @_; 28 | } 29 | 30 | my $class = ref $proto || $proto; 31 | my %d = $class->_defaults; 32 | my $nd = $class->_dereference(\%d); 33 | 34 | my $self = bless { (%$nd, %rest) }, $class; 35 | 36 | my @required; 37 | my @bad = (); 38 | for ($self->_required_fields) { 39 | push @bad, $_ unless(defined $self->{$_}); 40 | } 41 | 42 | if(@bad) { 43 | warn "Error creating '$class': " . 44 | (join ',', @bad) . " not defined\n"; 45 | return undef; 46 | } 47 | 48 | return undef unless $self->_init; 49 | 50 | return $self; 51 | } 52 | 53 | sub _init { 1; } 54 | 55 | sub dup { 56 | my $self = shift; 57 | my %override = @_; 58 | $self->new(%$self, %override); 59 | } 60 | 61 | sub _dereference { 62 | my $class = shift; 63 | my $arg = shift; 64 | my $ret; 65 | 66 | if(ref $arg eq 'ARRAY') { 67 | my @newarray = @$arg; 68 | $_ = $class->_dereference($_) for (@newarray); 69 | $ret = \@newarray; 70 | } elsif(ref $arg eq 'HASH') { 71 | my %newhash = %$arg; 72 | $newhash{$_} = $class->_dereference($newhash{$_}) for (keys %newhash); 73 | $ret = \%newhash; 74 | } elsif(ref $arg eq 'SCALAR') { 75 | my $newscalar = $arg; 76 | $ret = \$newscalar; 77 | } else { 78 | $ret = $arg; 79 | } 80 | 81 | return $ret; 82 | } 83 | 84 | sub infomsg { 85 | my $self = shift; 86 | return unless $self->{verbose}; 87 | for (@_) { 88 | print "INFO: $_\n"; 89 | } 90 | } 91 | 92 | 93 | sub error { 94 | my $self = shift; 95 | my $msg = join ' ', @_; 96 | 97 | warn "$msg\n" if($self->{warn_on_error}); 98 | 99 | if($msg) { 100 | $self->{_error} = $msg; 101 | return undef; 102 | } 103 | 104 | return $self->{_error}; 105 | } 106 | 107 | sub _defaults { 108 | (); 109 | } 110 | 111 | sub _required_fields { 112 | (); 113 | } 114 | 115 | sub _accessors { 116 | my($self, @fields) = @_; 117 | 118 | $self->_mk_accessors('make_accessor', @fields); 119 | } 120 | 121 | { 122 | no strict 'refs'; 123 | no warnings; 124 | 125 | sub _requires { 126 | my ($self, @fields) = @_; 127 | my $class = ref $self || $self; 128 | my %oldfields; 129 | 130 | my @oldfields; 131 | 132 | foreach ($class, @{"$class\::ISA"}) { 133 | next unless defined(&{$_."\::_required_fields"}); 134 | @oldfields = ($_->_required_fields, @oldfields); 135 | } 136 | 137 | my %newfields = map { $_ => 1 } (@oldfields, @fields); 138 | my @newfields = keys %newfields; 139 | 140 | *{$class."\::_required_fields"} = sub { @newfields }; 141 | } 142 | 143 | sub _mk_accessors { 144 | my ($self, $maker, %fields) = @_; 145 | my $class = ref $self || $self; 146 | my %oldfields; 147 | 148 | foreach ($class, @{"$class\::ISA"}) { 149 | next unless defined(&{$_."\::_defaults"}); 150 | %oldfields = ($_->_defaults, %oldfields); 151 | } 152 | 153 | *{$class."\::_defaults"} = sub { (%oldfields, %fields) }; 154 | 155 | # So we don't have to do lots of lookups inside the loop. 156 | $maker = $self->can($maker) unless ref $maker; 157 | 158 | foreach my $field (keys %fields) { 159 | if( $field eq 'DESTROY' ) { 160 | require Carp; 161 | Carp::carp("Having a data accessor named DESTROY in ". 162 | "'$class' is unwise."); 163 | } 164 | 165 | my $accessor = $self->$maker($field); 166 | my $alias = "_${field}_accessor"; 167 | 168 | *{$class."\:\:$field"} = $accessor 169 | unless defined &{$class."\:\:$field"}; 170 | 171 | *{$class."\:\:$alias"} = $accessor 172 | unless defined &{$class."\:\:$alias"}; 173 | } 174 | } 175 | } 176 | 177 | sub make_accessor { 178 | my ($class, $field, $default) = @_; 179 | 180 | # Build a closure around $field. 181 | return sub { 182 | my $self = shift; 183 | 184 | if(@_) { 185 | return $self->set($field, @_); 186 | } 187 | else { 188 | return $self->get($field); 189 | } 190 | }; 191 | } 192 | 193 | sub set { 194 | my($self, $key) = splice(@_, 0, 2); 195 | 196 | if(@_ == 1) { 197 | $self->{$key} = $_[0]; 198 | } 199 | elsif(@_ > 1) { 200 | $self->{$key} = [@_]; 201 | } 202 | else { 203 | require Carp; 204 | &Carp::confess("Wrong number of arguments received"); 205 | } 206 | 207 | return $self; 208 | } 209 | 210 | sub get { 211 | my $self = shift; 212 | 213 | if(@_ == 1) { 214 | return $self->{$_[0]}; 215 | } 216 | elsif( @_ > 1 ) { 217 | return @{$self}{@_}; 218 | } 219 | else { 220 | require Carp; 221 | &Carp::confess("Wrong number of arguments received."); 222 | } 223 | } 224 | 225 | 1; 226 | 227 | __END__ 228 | 229 | =pod 230 | 231 | =head1 NAME 232 | 233 | Seco::Class - base class for object oriented perl modules 234 | 235 | =head1 SYNOPSIS 236 | 237 | package MyModule; 238 | use base qw(Seco::Class); 239 | BEGIN { 240 | MyModule->_accessors(foo => 'default value for foo', 241 | bar => 78); 242 | } 243 | 244 | ... meanwhile ... 245 | 246 | my $mm = MyModule->new(foo => 'replace default value with this'); 247 | print $mm->bar; 248 | $mm->list(5, 3, 'hello'); 249 | my $count = $mm->list; 250 | my @list = $mm->list; 251 | 252 | my $duplicate = $mm->dup; 253 | my $otherdup = $mm->dup(bar => 2); 254 | 255 | print $otherdup; 256 | 257 | =head1 DESCRIPTION 258 | 259 | Base your classes on Seco::Class to enable them to define accessor methods 260 | that take default values. Seco::Class also defines a constructor 'new' 261 | that will take values to override defaults with, and a 'dup' method that will 262 | create a new object using the target's values as defaults. References will 263 | not be followed, so a Seco::Accessor::dup'd object may not necessarily be 264 | totally independent. 265 | 266 | Seco::Accessor defines a subroutine '_default' which returns a hash indiacting 267 | the default values you have assigned for all accessor elements. 268 | 269 | A subroutine "error" exists in Seco::Accessor. When called with an argument, 270 | it sets $object->{_error} to the value of the argument and returns undef. 271 | When called without an argument, it returns the value of $object->{_error}. 272 | This allows one to: dostuff or return $self->error("Stuff failed."); 273 | 274 | 275 | to return undef, and set _error, and then 276 | warn($obj->error) if(!$obj->stuff); 277 | 278 | in your scripts. 279 | 280 | In addition, it overloads the stringification operator "" to use 281 | YourClass::stringify_self($obj) for stringification. By default, this will 282 | print a Data::Dumper dump of the object. You can override this behavior by 283 | overloading the method "stringify_self". 284 | 285 | Class::Accessor 'getter' methods are modified in that they return the target 286 | object. 287 | 288 | -------------------------------------------------------------------------------- /PERLARTISTIC: -------------------------------------------------------------------------------- 1 | PERLARTISTIC(1) User Contributed Perl Documentation PERLARTISTIC(1) 2 | 3 | 4 | 5 | NAME 6 | perlartistic - the Perl Artistic License 7 | 8 | SYNOPSIS 9 | You can refer to this document in Pod via "L" 10 | Or you can see this document by entering "perldoc perlartistic" 11 | 12 | DESCRIPTION 13 | This is "The Artistic License". It’s here so that modules, programs, 14 | etc., that want to declare this as their distribution license, can link 15 | to it. 16 | 17 | It is also one of the two licenses Perl allows itself to be 18 | redistributed and/or modified; for the other one, the GNU General 19 | Public License, see the perlgpl. 20 | 21 | The "Artistic License" 22 | Preamble 23 | 24 | The intent of this document is to state the conditions under which a 25 | Package may be copied, such that the Copyright Holder maintains some 26 | semblance of artistic control over the development of the package, 27 | while giving the users of the package the right to use and distribute 28 | the Package in a more-or-less customary fashion, plus the right to make 29 | reasonable modifications. 30 | 31 | Definitions 32 | 33 | 34 | "Package" 35 | refers to the collection of files distributed by the Copyright 36 | Holder, and derivatives of that collection of files created through 37 | textual modification. 38 | 39 | "Standard Version" 40 | refers to such a Package if it has not been modified, or has been 41 | modified in accordance with the wishes of the Copyright Holder as 42 | specified below. 43 | 44 | "Copyright Holder" 45 | is whoever is named in the copyright or copyrights for the package. 46 | 47 | "You" 48 | is you, if you’re thinking about copying or distributing this 49 | Package. 50 | 51 | "Reasonable copying fee" 52 | is whatever you can justify on the basis of media cost, duplication 53 | charges, time of people involved, and so on. (You will not be 54 | required to justify it to the Copyright Holder, but only to the 55 | computing community at large as a market that must bear the fee.) 56 | 57 | "Freely Available" 58 | means that no fee is charged for the item itself, though there may 59 | be fees involved in handling the item. It also means that 60 | recipients of the item may redistribute it under the same 61 | conditions they received it. 62 | 63 | Conditions 64 | 65 | 66 | 1. You may make and give away verbatim copies of the source form of 67 | the Standard Version of this Package without restriction, provided 68 | that you duplicate all of the original copyright notices and 69 | associated disclaimers. 70 | 71 | 2. You may apply bug fixes, portability fixes and other modifications 72 | derived from the Public Domain or from the Copyright Holder. A 73 | Package modified in such a way shall still be considered the 74 | Standard Version. 75 | 76 | 3. You may otherwise modify your copy of this Package in any way, 77 | provided that you insert a prominent notice in each changed file 78 | stating how and when you changed that file, and provided that you 79 | do at least ONE of the following: 80 | 81 | a) place your modifications in the Public Domain or otherwise make 82 | them Freely Available, such as by posting said modifications to 83 | Usenet or an equivalent medium, or placing the modifications on 84 | a major archive site such as uunet.uu.net, or by allowing the 85 | Copyright Holder to include your modifications in the Standard 86 | Version of the Package. 87 | 88 | b) use the modified Package only within your corporation or 89 | organization. 90 | 91 | c) rename any non-standard executables so the names do not 92 | conflict with standard executables, which must also be 93 | provided, and provide a separate manual page for each non- 94 | standard executable that clearly documents how it differs from 95 | the Standard Version. 96 | 97 | d) make other distribution arrangements with the Copyright Holder. 98 | 99 | 4. You may distribute the programs of this Package in object code or 100 | executable form, provided that you do at least ONE of the 101 | following: 102 | 103 | a) distribute a Standard Version of the executables and library 104 | files, together with instructions (in the manual page or 105 | equivalent) on where to get the Standard Version. 106 | 107 | b) accompany the distribution with the machine-readable source of 108 | the Package with your modifications. 109 | 110 | c) give non-standard executables non-standard names, and clearly 111 | document the differences in manual pages (or equivalent), 112 | together with instructions on where to get the Standard 113 | Version. 114 | 115 | d) make other distribution arrangements with the Copyright Holder. 116 | 117 | 5. You may charge a reasonable copying fee for any distribution of 118 | this Package. You may charge any fee you choose for support of 119 | this Package. You may not charge a fee for this Package itself. 120 | However, you may distribute this Package in aggregate with other 121 | (possibly commercial) programs as part of a larger (possibly 122 | commercial) software distribution provided that you do not 123 | advertise this Package as a product of your own. You may embed 124 | this Package’s interpreter within an executable of yours (by 125 | linking); this shall be construed as a mere form of aggregation, 126 | provided that the complete Standard Version of the interpreter is 127 | so embedded. 128 | 129 | 6. The scripts and library files supplied as input to or produced as 130 | output from the programs of this Package do not automatically fall 131 | under the copyright of this Package, but belong to whoever 132 | generated them, and may be sold commercially, and may be aggregated 133 | with this Package. If such scripts or library files are aggregated 134 | with this Package via the so-called "undump" or "unexec" methods of 135 | producing a binary executable image, then distribution of such an 136 | image shall neither be construed as a distribution of this Package 137 | nor shall it fall under the restrictions of Paragraphs 3 and 4, 138 | provided that you do not represent such an executable image as a 139 | Standard Version of this Package. 140 | 141 | 7. C subroutines (or comparably compiled subroutines in other 142 | languages) supplied by you and linked into this Package in order to 143 | emulate subroutines and variables of the language defined by this 144 | Package shall not be considered part of this Package, but are the 145 | equivalent of input as in Paragraph 6, provided these subroutines 146 | do not change the language in any way that would cause it to fail 147 | the regression tests for the language. 148 | 149 | 8. Aggregation of this Package with a commercial distribution is 150 | always permitted provided that the use of this Package is embedded; 151 | that is, when no overt attempt is made to make this Package’s 152 | interfaces visible to the end user of the commercial distribution. 153 | Such use shall not be construed as a distribution of this Package. 154 | 155 | 9. The name of the Copyright Holder may not be used to endorse or 156 | promote products derived from this software without specific prior 157 | written permission. 158 | 159 | 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 160 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES 161 | OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 162 | 163 | The End 164 | 165 | 166 | 167 | perl v5.8.6 2010-05-21 PERLARTISTIC(1) 168 | -------------------------------------------------------------------------------- /root/usr/bin/p4-multipkg: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # Copyright (c) 2011 Yahoo! Inc. All rights reserved. 3 | 4 | use strict; 5 | 6 | use constant MULTIPKG_VERSION => '__MULTIPKG_BUILD_VERSION__'; 7 | 8 | use File::Temp qw/tempdir/; 9 | use File::Path qw/mkpath/; 10 | use File::Basename qw/dirname/; 11 | use Time::Local qw/timegm/; 12 | 13 | use YAML::Syck; 14 | 15 | use Seco::Getopt; 16 | 17 | # XXX: this is actually a kernel compile-time constant (MAX_ARG_PAGES), which 18 | # currently works out to 128k (including environment space) on x86. 19 | my $MAX_ARG_SIZE = 65536; 20 | 21 | # metadata tracing 22 | my @actions; 23 | my $init_action = { 24 | 'actor' => whoami(), 25 | 'time' => time(), 26 | 'type' => 'build', 27 | 'actions' => [ 28 | { 'summary' => 'p4-multipkg initialiation', 29 | 'text' => "p4-multipkg version: " 30 | . MULTIPKG_VERSION . "\n" 31 | . "invoked as: $0 " 32 | . join( ' ', @ARGV ) . "\n", 33 | }, 34 | ], 35 | }; 36 | 37 | my $opt = Seco::Getopt->new( 38 | options => { 39 | 'c|checkout=s' => 'Check out into this dir, don\'t build', 40 | 'b|basepath=s' => 'base Perforce repository path', 41 | 'r|rev=s' => 'check out source at this revision', 42 | 'k|keep!' => 'keep the temporary directory after build', 43 | 'v|verbose!' => 'verbose', 44 | 'p|platform=s' => 'multipkg platform', 45 | 's|set=s' => 'List of variables to set', 46 | }, 47 | default => { 48 | 'b' => '//depot/metapkg-ng-packages-yss/', 49 | 'r' => undef, # implicit Perforce "HEAD" 50 | }, 51 | required => [qw/b/], 52 | ); 53 | 54 | my $package = shift || $opt->usage(); 55 | my $depotpath = $opt->get('b'); 56 | 57 | my $override_vars = ( defined( $opt->get('s') ) ) ? $opt->get('s') . ',' : ''; 58 | 59 | sub vprint { 60 | if ( $opt->get('v') ) { 61 | print @_, "\n"; 62 | } 63 | } 64 | 65 | # Get metadata for everything contained within a given Perforce depot path. 66 | # Returns a hash keyed by depot path name, of metadata hashes. 67 | sub get_all_p4_file_metadata { 68 | my ( $depotpath, $at ) = @_; 69 | my $metadata = {}; 70 | 71 | my $depotpattern = $depotpath . '...' . $at; 72 | 73 | open( P4, '-|', 'p4', 'fstat', $depotpattern ) 74 | or die "can't run p4 fstat $depotpattern"; 75 | 76 | my $valid = 0; 77 | my $depotfile; 78 | my $md = {}; 79 | while () { 80 | chomp; 81 | 82 | # empty line marks end of record. 83 | if ( $_ eq '' ) { 84 | ($valid) || die "failed to parse p4 fstat output"; 85 | 86 | $metadata->{$depotfile} = $md; 87 | $valid = 0; 88 | $md = {}; 89 | 90 | next; 91 | } 92 | 93 | # perforce allows whitespace in names, but non-printing 94 | # characters are not allowed. so don't have to worry about 95 | # newlines, etc. 96 | /^\.\.\. (\S+) (.*)$/ 97 | or die "failed to parse p4 fstat output"; 98 | 99 | if ( $1 eq 'depotFile' ) { 100 | $depotfile = $2; 101 | $valid = 1; 102 | } 103 | else { 104 | $md->{$1} = $2; 105 | } 106 | } 107 | # in case the last record is corrupted, etc 108 | if ($valid) { 109 | die "failed to parse p4 fstat output"; 110 | } 111 | 112 | close(P4); 113 | 114 | return $metadata; 115 | } 116 | 117 | # Run 'p4 filelog' on a group of files and return all changes for each. 118 | # use '-i' to also report changes from files prior to branching (eg. renames) 119 | 120 | # For a moment I thought that it would suffice to just do: 'p4 filelog ...' 121 | # but this doesn't report on deletions, thus we'd potentially miss changesets. 122 | sub p4_run_filelog { 123 | my @files = @_; 124 | my @changes; 125 | 126 | # use multi-argument open to handle whitespace in file names 127 | open( P4, '-|', 'p4', 'filelog', '-i', @files ) 128 | or die "can't run p4 filelog"; 129 | 130 | while () { 131 | chomp; 132 | 133 | /^\.\.\. #\d+ change (\d+) / or next; 134 | 135 | push @changes, $1; 136 | } 137 | close(P4); 138 | 139 | return @changes; 140 | } 141 | 142 | # estimate the size of args which will be needed to run a p4 command; also 143 | # take size of the environment into account. ain't this a great way to talk 144 | # to the "perforce API"? 145 | sub p4_estimate_argsize { 146 | my $cmd = shift; 147 | 148 | my $size = length( 'p4 ' . $cmd ); 149 | for ( keys %ENV ) { 150 | $size += length($_) + length( $ENV{$_} ) + 2; # NAME=VALUE\0 151 | } 152 | 153 | return $size; 154 | } 155 | 156 | # get all changes assocated with all files. It's more efficient to have p4 157 | # query multiple files at once, instead of execing a separate p4 process for 158 | # each file. However, we are limited by MAX_ARG_SIZE, so do it in batches. 159 | sub get_all_p4_changes { 160 | my $at = shift; 161 | my @files = @_; 162 | my %changes; 163 | my @files_todo; 164 | 165 | my $arg_size = p4_estimate_argsize('filelog -i'); 166 | 167 | foreach my $f (@files) { 168 | # append $at so we can filter changes appropriately, etc. 169 | my $fat = $f . $at; 170 | 171 | # run a batch if we would exceed the argument limit 172 | if ( $arg_size + length($fat) + 1 > $MAX_ARG_SIZE ) { 173 | my @chg = p4_run_filelog(@files_todo); 174 | map { $changes{$_} = 1 } @chg; 175 | 176 | @files_todo = (); 177 | $arg_size = p4_estimate_argsize('filelog -i'); 178 | } 179 | 180 | # otherwise accumulate the next entry 181 | push @files_todo, $fat; 182 | $arg_size += length($fat) + 1; 183 | } 184 | # run the last bit 185 | if (@files_todo) { 186 | my @chg = p4_run_filelog(@files_todo); 187 | map { $changes{$_} = 1 } @chg; 188 | } 189 | 190 | # now return all unique changes. 191 | return keys %changes; 192 | } 193 | 194 | # parse a p4 timestamp of the form "YYYY/MM/DD HH:MM:SS" 195 | # XXX: note that p4 ignores the $TZ environment variable, and (most likely) 196 | # uses local time on the server, which should be UTC. 197 | sub parse_p4_timestamp { 198 | my $t = shift; 199 | 200 | ( $t =~ /^(\d\d\d\d)\/(\d\d)\/(\d\d) (\d\d):(\d\d):(\d\d)$/ ) 201 | or die "invalid p4 timestamp: $t"; 202 | 203 | my ( $year, $mon, $mday, $hour, $min, $sec ) = ( $1, $2, $3, $4, $5, $6 ); 204 | 205 | my $unixtime; 206 | eval { $unixtime = timegm( $sec, $min, $hour, $mday, $mon - 1, $year ) }; 207 | 208 | if ($@) { 209 | die "invalid timestamp: $t"; 210 | } 211 | 212 | return $unixtime; 213 | } 214 | 215 | sub p4_run_describe { 216 | my @changes = @_; 217 | my $chg_metadata; 218 | 219 | # use multi-argument open although it's not strictly needed here 220 | open( P4, '-|', 'p4', 'describe', '-s', @changes ) 221 | or die "can't run p4 describe"; 222 | 223 | my $valid = 0; 224 | my $changenum; 225 | my $chg = {}; 226 | 227 | while () { 228 | chomp; 229 | 230 | if (/^Change (\d+) by (\S+) on (\S+ \S+)/) { 231 | if ($valid) { 232 | die "failed to parse output from p4 describe"; 233 | } 234 | 235 | $valid = 1; 236 | $changenum = $1; 237 | $chg->{user} = $2; 238 | $chg->{timestamp} = parse_p4_timestamp($3); 239 | $chg->{description} = ''; 240 | 241 | # then followed by empty line... 242 | my $x = ; 243 | chomp $x; 244 | if ( $x ne '' ) { 245 | die "failed to parse output from p4 describe"; 246 | } 247 | 248 | next; 249 | } 250 | 251 | # skip other stuff like list of files, etc. 252 | if ( !$valid ) { 253 | next; 254 | } 255 | 256 | # empty line marks end of record 257 | if ( $_ eq '' ) { 258 | $chg_metadata->{$changenum} = $chg; 259 | 260 | $valid = 0; 261 | $chg = {}; 262 | next; 263 | } 264 | 265 | # otherwise, must be a description line 266 | if (/^\t(.*)$/) { 267 | $chg->{description} .= "$1\n"; 268 | next; 269 | } 270 | 271 | # anything else is a parse error 272 | die "unable to parse output from p4 describe"; 273 | } 274 | # make sure the last record isn't corrupted 275 | if ($valid) { 276 | die "failed to parse output from p4 describe"; 277 | } 278 | 279 | close(P4); 280 | 281 | return $chg_metadata; 282 | } 283 | 284 | # run 'p4 describe -s' to get the text description for each changelist. 285 | # return a hash by changelist number, of changelist metadata hashes: 286 | # 287 | # user => (username who submited the changelist) 288 | # timestamp => (unix time when submitted) 289 | # description => (array reference of description text) 290 | # 291 | sub get_all_p4_change_descriptions { 292 | my @changes = @_; 293 | 294 | my $chg_metadata; 295 | my @changes_todo; 296 | 297 | my $arg_size = p4_estimate_argsize('describe -s'); 298 | 299 | foreach my $c (@changes) { 300 | # run a batch if we would exceed the argument limit 301 | if ( $arg_size + length($c) + 1 > $MAX_ARG_SIZE ) { 302 | my $m = p4_run_describe(@changes_todo); 303 | map { $chg_metadata->{$_} = $m->{$_} } keys %$m; 304 | 305 | $arg_size = p4_estimate_argsize('describe -s'); 306 | @changes_todo = (); 307 | } 308 | 309 | # otherwise accumulate the next entry 310 | push @changes_todo, $c; 311 | $arg_size += length($c) + 1; 312 | } 313 | # run the last bit 314 | if (@changes_todo) { 315 | my $m = p4_run_describe(@changes_todo); 316 | map { $chg_metadata->{$_} = $m->{$_} } keys %$m; 317 | } 318 | 319 | # return entire metadata set. 320 | return $chg_metadata; 321 | } 322 | 323 | # Based on the description from 'p4 help filetypes' 324 | my %p4_type_aliases = ( 325 | 'ctext' => 'text+C', 326 | 'cxtext' => 'text+Cx', 327 | 'ktext' => 'text+k', 328 | 'kxtext' => 'text+kx', 329 | 'ltext' => 'text+F', 330 | 'tempobj' => 'binary+Sw', 331 | 'ubinary' => 'binary+F', 332 | 'uresource' => 'resource+F', 333 | 'uxbinary' => 'binary+Fx', 334 | 'xbinary' => 'binary+x', 335 | 'xltext' => 'text+Fx', 336 | 'xtempobj' => 'binary+Swx', 337 | 'xtext' => 'text+x', 338 | 'xunicode' => 'unicode+x', 339 | 'xutf16' => 'utf16+x' 340 | ); 341 | 342 | sub parse_p4_filetype { 343 | my $typestr = shift; 344 | my ( $filetype, $modifiers ); 345 | my $type; 346 | my $mode = 0444; 347 | 348 | if ( defined( $p4_type_aliases{$typestr} ) ) { 349 | $typestr = $p4_type_aliases{$typestr}; 350 | } 351 | 352 | if ( $typestr =~ /^([a-z]+)\+([a-zA-Z]+)$/ ) { 353 | $filetype = $1; 354 | $modifiers = $2; 355 | } 356 | elsif ( $typestr =~ /^([a-z]+)$/ ) { 357 | $filetype = $1; 358 | $modifiers = ''; 359 | } 360 | else { 361 | die "invalid perforce filetype: $typestr\n"; 362 | } 363 | 364 | # The only modifiers we care about are +w and +x. 365 | # XXX: we are going to implicitly force +m on every file 366 | # XXX: what about +k? 367 | # XXX: +S may imply that we can't fetch some or all revisions older 368 | # than HEAD 369 | if ( index( $modifiers, 'x' ) != -1 ) { 370 | $mode |= 0111; 371 | } 372 | if ( index( $modifiers, 'w' ) != -1 ) { 373 | $mode |= 0200; 374 | } 375 | 376 | # XXX: assume that anything not a symlink is a regular file. 377 | if ( $filetype eq 'symlink' ) { 378 | $type = 'l'; 379 | } 380 | else { 381 | $type = 'f'; 382 | } 383 | 384 | return ( $type, $mode ); 385 | } 386 | 387 | ##################################################################### 388 | # 389 | # Start here. 390 | # 391 | ##################################################################### 392 | 393 | my $depotpkgpath = $depotpath . $package . '/'; 394 | 395 | my $at = ''; 396 | $at = '@' . $opt->get('r') if ( defined( $opt->get('r') ) ); 397 | 398 | vprint "building package from p4 path: $depotpkgpath...$at"; 399 | 400 | # Get all files + metadata under this path 401 | vprint "reading metadata from p4..."; 402 | my $p4_files_md = get_all_p4_file_metadata( $depotpkgpath, $at ); 403 | 404 | my $tempdir; 405 | if ( $opt->get('c') ) { 406 | $tempdir = $opt->get('c'); 407 | } 408 | else { 409 | $tempdir = tempdir( CLEANUP => 1 ); 410 | } 411 | 412 | my $newest = 0; 413 | 414 | # Set umask to sane default. 415 | umask(022); 416 | 417 | vprint "downloading files from p4..."; 418 | 419 | my $hasfiles; 420 | foreach my $f ( keys %$p4_files_md ) { 421 | my $md = $p4_files_md->{$f}; 422 | 423 | # Collect the newest change, out of all entries in the depot (even 424 | # deletions, etc) 425 | $newest = $md->{headChange} if ( $md->{headChange} > $newest ); 426 | 427 | # Ignore anything for which the last action was 'delete'. Everything else 428 | # ('add', 'edit', 'branch', 'integrate') should mean there is still a file 429 | # present at this path. 430 | if ( $md->{headAction} eq 'delete' ) { 431 | next; 432 | } 433 | 434 | $hasfiles++; 435 | 436 | # strip off the depot path to get the file name 437 | if ( substr( $f, 0, length($depotpkgpath) ) ne $depotpkgpath ) { 438 | die "invalid filename in depot: $f"; 439 | } 440 | my $file = substr( $f, length($depotpkgpath) ); 441 | my $dest = $tempdir . '/' . $package . '/' . $file; 442 | 443 | my ( $type, $mode ) = parse_p4_filetype( $md->{headType} ); 444 | 445 | # 'p4 print -o' will recreate all objects properly, even symlinks. 446 | # XXX: It's actually buggy for symlinks, if the link text contains a 447 | # newline. We will ignore this case. 448 | # It also will chmod() files to what it deems correct (subject to umask), 449 | # so we don't need to do this outselves. 450 | eval { mkpath( dirname($dest) ) }; 451 | if ($@) { 452 | die "failed to create parent directory for: $dest"; 453 | } 454 | 455 | # If revision specified via -a, use that version. 456 | system( 'p4', 'print', '-q', '-o', $dest, $f . $at ) == 0 457 | or die "failed to run: p4 print $f$at"; 458 | 459 | # Force mtime to repository value for all regular files 460 | if ( $type eq 'f' ) { 461 | utime( $md->{headModTime}, $md->{headModTime}, $dest ) 462 | or die "failed to set utime for: $dest"; 463 | } 464 | } 465 | 466 | die "No files to build\n" unless ($hasfiles); 467 | 468 | # metadata trace for checkout operation 469 | my $checkout_action = { 470 | 'actor' => whoami(), 471 | 'time' => time(), 472 | 'type' => 'build', 473 | 'actions' => [ 474 | { 'summary' => 'p4-multipkg checkout source from p4', 475 | 'text' => "depot path : $depotpkgpath...$at\n" 476 | . "files found : " 477 | . scalar( keys %$p4_files_md ) . "\n", 478 | }, 479 | ], 480 | }; 481 | 482 | # get full change descriptions and write out metadata file 483 | my $metadir = "$tempdir/$package/meta"; 484 | my $metafile = "$metadir/50p4-multipkg.yaml"; 485 | die "metadata file already exists: $metafile" if ( -e $metafile ); 486 | 487 | vprint "listing all p4 changelists..."; 488 | my @p4_changes = get_all_p4_changes( $at, keys %$p4_files_md ); 489 | 490 | vprint "downloading changelist metadata..."; 491 | my $p4_changes_md = get_all_p4_change_descriptions(@p4_changes); 492 | 493 | vprint "building actionlog metadata from p4 history..."; 494 | 495 | # assume that ascending numerical order is chronological order 496 | for my $c ( sort { $a <=> $b } keys %$p4_changes_md ) { 497 | my $change_action = { 498 | 'actor' => $p4_changes_md->{$c}->{'user'}, 499 | 'time' => $p4_changes_md->{$c}->{'timestamp'}, 500 | 'type' => 'source', 501 | 'actions' => [ 502 | { 'summary' => "Perforce change $c", 503 | 'text' => $p4_changes_md->{$c}->{'description'}, 504 | }, 505 | ], 506 | }; 507 | 508 | push @actions, $change_action; 509 | } 510 | 511 | # generate final metadata structure 512 | my $metadata = { 'actionlog' => [ @actions, $init_action, $checkout_action ], }; 513 | 514 | # serialize it 515 | vprint "writing metadata file..."; 516 | eval { mkpath($metadir) }; 517 | if ($@) { 518 | die "can't create multipkg metadata dir: $metadir"; 519 | } 520 | 521 | YAML::Syck::DumpFile( $metafile, $metadata ) 522 | or die "can't create metadata file: $metafile"; 523 | 524 | unless ( $opt->get('c') ) { 525 | vprint "running multipkg..."; 526 | 527 | my @plat = (); 528 | @plat = ( '-p', $opt->get('p') ) 529 | if ( defined( $opt->get('p') ) ); 530 | 531 | system( 'multipkg', @plat, '-s', $override_vars . "release=$newest,srcurl=p4:$depotpkgpath...$at", 532 | "$tempdir/$package" ) == 0 533 | or die "failed to run multipkg"; 534 | } 535 | 536 | # generate identifying string for this host/user 537 | sub whoami { 538 | my $name; 539 | eval { 540 | require Sys::Hostname; 541 | 542 | my $user = getpwuid($<); 543 | $user = 'unknown' unless ( defined($user) ); 544 | 545 | $name = $user . '@' . Sys::Hostname->hostname(); 546 | }; 547 | $name = 'unknown' if ($@); 548 | 549 | return $name; 550 | } 551 | -------------------------------------------------------------------------------- /GPLv2: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /source/lib/Seco/Multipkg.pm: -------------------------------------------------------------------------------- 1 | package Seco::Multipkg; 2 | # Copyright (c) 2011 Yahoo! Inc. All rights reserved. 3 | use strict; 4 | use constant MULTIPKG_VERSION => '__MULTIPKG_BUILD_VERSION__'; 5 | use File::Spec; 6 | use File::Basename; 7 | use Cwd; 8 | 9 | use base qw/Seco::Class/; 10 | 11 | BEGIN { 12 | __PACKAGE__->_accessors( 13 | startdir => undef, 14 | directory => undef, 15 | confdir => '__MULTIPKG_CONFIG_DIR__', 16 | info => undef, 17 | cleanup => 0, 18 | cwd => undef, 19 | overrides => {}, 20 | meta => undef, 21 | force => 0, 22 | platform => undef, 23 | warn_on_error => 0, 24 | verbose => 0 25 | ); 26 | __PACKAGE__->_requires(qw/directory/); 27 | } 28 | 29 | sub _init { 30 | my $self = shift; 31 | my $cwd = getcwd; 32 | $self->cwd($cwd); 33 | $self->{directory} =~ s/\/$//; 34 | $self->{directory} = File::Spec->rel2abs( $self->{directory} ); 35 | return $self->error( "No such directory " . $self->directory . "." ) 36 | unless ( -d $self->directory ); 37 | 38 | $self->{confdir} =~ s/\/$//; 39 | $self->{confdir} = File::Spec->rel2abs( $self->{confdir} ); 40 | return $self->error( "No such directory " . $self->confdir ) 41 | unless ( -d $self->confdir ); 42 | 43 | $self->info( 44 | Seco::Multipkg::Info->new( 45 | overrides => $self->overrides, 46 | platform => $self->platform, 47 | directory => $self->directory, 48 | confdir => $self->confdir, 49 | verbose => $self->verbose, 50 | meta => $self->meta 51 | ) 52 | ); 53 | } 54 | 55 | sub build { 56 | my $self = shift; 57 | 58 | my $builder; 59 | 60 | $builder = Seco::Multipkg::Builder::Gem->new( 61 | verbose => $self->verbose, 62 | info => $self->info, 63 | force => $self->force, 64 | cwd => $self->cwd 65 | ) if ( $self->info->data->{packagetype} eq 'gem' ); 66 | $builder = Seco::Multipkg::Builder::Rpm->new( 67 | verbose => $self->verbose, 68 | info => $self->info, 69 | force => $self->force, 70 | cwd => $self->cwd 71 | ) if ( $self->info->data->{packagetype} eq 'rpm' ); 72 | $builder = Seco::Multipkg::Builder::Deb->new( 73 | verbose => $self->verbose, 74 | info => $self->info, 75 | force => $self->force, 76 | cwd => $self->cwd 77 | ) if ( $self->info->data->{packagetype} eq 'deb' ); 78 | $builder = Seco::Multipkg::Builder::Tarball->new( 79 | verbose => $self->verbose, 80 | info => $self->info, 81 | force => $self->force, 82 | cwd => $self->cwd 83 | ) if ( $self->info->data->{packagetype} eq 'tarball' ); 84 | 85 | $builder->build; 86 | $builder->copyroot; 87 | $builder->transform; 88 | $builder->verify_data 89 | or $builder->forceok("Finished package contains no files"); 90 | 91 | # build action log 92 | my $multipkg_build_meta = { 93 | actionlog => [ 94 | { 'time' => time(), 95 | 'type' => 'build', 96 | 'actor' => $self->info->data->{'whoami'}, 97 | 'actions' => [ 98 | { 'summary' => 'Seco::Multipkg build complete', 99 | 'text' => "multipkg version: " . MULTIPKG_VERSION . "\n", 100 | }, 101 | ], 102 | }, 103 | ], 104 | }; 105 | $self->info->mergemeta($multipkg_build_meta); 106 | 107 | my $pkg = $builder->makepackage; 108 | 109 | if ( $self->cleanup ) { 110 | $builder->cleanup; 111 | } 112 | else { 113 | warn "Not cleaning up: " . $builder->tmpdir . "\n"; 114 | } 115 | return $pkg; 116 | } 117 | 118 | package Seco::Multipkg::Builder; 119 | use File::Find qw/find/; 120 | use File::Temp qw/tempfile tempdir/; 121 | use File::Copy; 122 | use IPC::Open3; 123 | use FileHandle; 124 | use Fcntl ':mode'; 125 | 126 | use constant MULTIPKG_VERSION => '__MULTIPKG_BUILD_VERSION__'; 127 | 128 | use base qw/Seco::Class/; 129 | 130 | BEGIN { 131 | __PACKAGE__->_accessors( 132 | info => undef, 133 | verbose => 0, 134 | tmpdir => undef, 135 | force => 0, 136 | builddir => undef, 137 | cwd => undef, 138 | installdir => undef 139 | ); 140 | __PACKAGE__->_requires(qw/info/); 141 | } 142 | 143 | sub _init { 144 | my $self = shift; 145 | 146 | $self->{_vars} = {}; 147 | 148 | $self->tmpdir( tempdir( CLEANUP => 0 ) ); 149 | $self->infomsg( "Using tmpdir " . $self->tmpdir ); 150 | 151 | my $builddir = $self->tmpdir . "/build"; 152 | mkdir($builddir) or die "Unable to mkdir $builddir: $!"; 153 | $self->builddir($builddir); 154 | 155 | my $installdir = $self->tmpdir . "/install"; 156 | mkdir($installdir) or die "Unable to mkdir $installdir: $!"; 157 | chmod 0755, $installdir; 158 | $self->installdir($installdir); 159 | 160 | $self->setrelease; 161 | 162 | $self->{_rules} = [ $self->get_file_rules ]; 163 | } 164 | 165 | sub taroption { 166 | my $self = shift; 167 | my $tarball = shift; 168 | 169 | return 'zxf' if $tarball =~ /\.(tar\.gz|tgz)$/; 170 | return 'jxf' if $tarball =~ /\.(tar\.bz2|tbz)$/; 171 | return 'Jxf' if $tarball =~ /\.(tar\.xz)$/; 172 | } 173 | 174 | sub setrelease { 175 | my $self = shift; 176 | 177 | # When release is not provided, we must be making a test build. 178 | # Use "0.time()" as release version to avoid ever conflicting with an actual 179 | # build from source checkout 180 | $self->info->data->{release} = sprintf "0.%u", time() 181 | unless ( defined $self->info->data->{release} ); 182 | $self->info->data->{release} .= "." . $self->info->data->{os} 183 | if (defined($self->info->data->{os})); 184 | } 185 | 186 | sub pkgverid { 187 | my $self = shift; 188 | 189 | return join '-', $self->info->data->{'name'}, 190 | $self->info->data->{'version'}, 191 | $self->info->data->{'release'}; 192 | } 193 | 194 | sub forceok { 195 | my $self = shift; 196 | my $msg = shift; 197 | die "FATAL (use --force to override): $msg\n" unless ( $self->force ); 198 | warn "WARN: $msg\n"; 199 | } 200 | 201 | sub template_file { 202 | my $self = shift; 203 | my $from = shift; 204 | my $to = shift; 205 | my $chmod = shift; 206 | 207 | my $str = $self->template_string($from); 208 | open my $f, ">$to"; 209 | print $f $str; 210 | close $f; 211 | 212 | chmod $chmod, $to if ( defined $chmod ); 213 | } 214 | 215 | # XXX: dumb variable substitution, intended for use for expanding relative 216 | # strings in index.yaml parameters, etc 217 | sub substvars { 218 | my $self = shift; 219 | my $buf = shift; 220 | 221 | for my $v ( keys %{ $self->{_vars} } ) { 222 | my $retxt = quotemeta( '$(' . $v . ')' ); 223 | my $re = qr/$retxt/; 224 | 225 | $buf =~ s/$re/$self->{_vars}->{$v}/gm; 226 | } 227 | return $buf; 228 | } 229 | 230 | sub template_string { 231 | my $self = shift; 232 | my $from = shift; 233 | 234 | open my $f, "<$from" or die "$from: $!"; 235 | my $ret = ''; 236 | 237 | my $skipping = 0; 238 | for (<$f>) { 239 | # XXX: use of '%' prefix potentially conflicts with RPM specfile syntax 240 | if (/^%%ifscript\(([A-Za-z\.]+)\)$/) { 241 | my $script = $1; 242 | 243 | # increase nesting count for every nested %%if statement when we are inside an 244 | # %%if which evaluated false. 245 | if ($skipping) { 246 | $skipping++; 247 | next; 248 | } 249 | 250 | # start skipping lines once we hit a false %%if statement. 251 | if ( !$self->info->scripts->{$script} ) { 252 | $skipping++; 253 | } 254 | next; 255 | } 256 | 257 | # XXX: use of '%' prefix potentially conflicts with RPM specfile syntax 258 | if (/^%%ifset\(([A-Za-z\.]+)\)$/) { 259 | my $match = $1; 260 | 261 | # increase nesting count for every nested %%if statement when we are inside an 262 | # %%if which evaluated false. 263 | if ($skipping) { 264 | $skipping++; 265 | next; 266 | } 267 | 268 | # start skipping lines once we hit a false %%if statement. 269 | if ( !$self->info->data->{$match} ) { 270 | $skipping++; 271 | } 272 | next; 273 | } 274 | 275 | # reduce the nesting count for each %%endif until we leave the original %%if 276 | # that evaluated false. 277 | if (/^%%endif$/) { 278 | if ($skipping) { 279 | $skipping--; 280 | } 281 | next; 282 | } 283 | 284 | # skip lines if we are inside an %if that evaluated false. 285 | if ($skipping) { 286 | next; 287 | } 288 | 289 | while (/%([A-Za-z_-]+)%/) { 290 | my $match = $1; 291 | if ( defined( my $repl = $self->info->data->{$match} ) ) { 292 | s/%$match%/$repl/; 293 | } 294 | else { 295 | s/%$match%/UNKNOWN/; 296 | $self->infomsg("WARN: $match not defined for $from"); 297 | } 298 | } 299 | 300 | while (/%%([A-Za-z\.]+)%%/) { 301 | my $match = $1; 302 | if ( ( my $f = $self->info->scripts->{$match} ) 303 | and ( -f $f ) ) 304 | { 305 | my $script = $self->template_string($f); 306 | s/%%$match%%/$script/; 307 | } 308 | else { 309 | s/%%$match%%//; 310 | } 311 | } 312 | 313 | $ret .= $_; 314 | } 315 | 316 | close $f; 317 | return $ret; 318 | } 319 | 320 | sub makepackage { 321 | my $self = shift; 322 | die "makepackage not implemented"; 323 | } 324 | 325 | sub install_gemspec { 326 | my $self = shift; 327 | 328 | # shove the file list into $self->info->data->{filelist} 329 | my $installdir = $self->installdir; 330 | my $buildprefix = $self->info->data->{buildprefix}; 331 | my @filelist; 332 | 333 | my $geminstalldir = [$self->runcmd("gem environment gemdir")]->[0]; 334 | return $self->error("Can't run: $@") if($@); 335 | 336 | chomp $geminstalldir; 337 | my $fullinstalldir = $geminstalldir . "/gems/" . 338 | $self->info->data->{name} . "-" . 339 | $self->info->data->{version}; 340 | foreach ($self->listdir("$installdir/$fullinstalldir")) { 341 | if (-f "$installdir/$fullinstalldir/$_") { 342 | s#^$installdir/$fullinstalldir/##; 343 | s#^$buildprefix/##; 344 | push @filelist, "\"$_\""; 345 | } 346 | } 347 | $self->info->data->{filelist} = join ",", @filelist; 348 | # generate the gemspec file based on that 349 | 350 | my $name = $self->info->data->{'name'}; 351 | my $version = $self->info->data->{'version'}; 352 | 353 | $self->runcmd("mkdir -p $installdir/$geminstalldir/specifications"); 354 | $self->template_file($self->info->confdir . "/templates/gemspec.template", 355 | "$installdir/$geminstalldir/specifications/" . 356 | "$name-$version.gemspec"); 357 | } 358 | 359 | sub cleanup { 360 | my $self = shift; 361 | # my $tmpdir = $ENV{TMPDIR} || '/tmp'; 362 | # $tmpdir =~ s/\/$//; 363 | # die "Unsafe to clean up " . $self->tmpdir 364 | # unless ( $self->tmpdir =~ /^$tmpdir\/\w/ ); 365 | 366 | $self->infomsg( "Cleaning up " . $self->tmpdir ); 367 | system( "rm -rf " . $self->tmpdir ); 368 | } 369 | 370 | sub _listfile { 371 | my ( $path, $parent, $found_root ) = @_; 372 | 373 | # the root must be a directory 374 | if ( $path eq $parent ) { 375 | lstat($parent) or die "can't lstat parent ($parent)"; 376 | die "parent ($parent) is not a directory" unless ( -d _ ); 377 | $$found_root = 1; 378 | return; 379 | } 380 | 381 | # otherwise the path must be a child of the parent 382 | die "path ($path) outside parent ($parent)" 383 | unless ( substr( $path, 0, length($parent) + 1 ) eq "$parent/" ); 384 | 385 | my $name = substr( $path, length($parent) + 1 ); 386 | die "invalid path ($path)" unless ( length($name) ); 387 | 388 | # return relative path 389 | return $name; 390 | } 391 | 392 | # Strips the leading directory path and returns the relative path name of the 393 | # contents of '$dir' 394 | sub listdir { 395 | my $self = shift; 396 | my $dir = shift; 397 | 398 | my @ret = (); 399 | my $found_root = 0; 400 | 401 | find( 402 | { wanted => sub { push @ret, _listfile( $_, $dir, \$found_root ); }, 403 | no_chdir => 1, 404 | }, 405 | $dir 406 | ); 407 | 408 | die "find failed on path ($dir)" unless ($found_root); 409 | 410 | # preserve daemontools log dirs, not needed with new logrun 411 | #@ret = ($dir) if(scalar @ret == 0 and $dir eq 'main'); 412 | return @ret; 413 | } 414 | 415 | # XXX: maybe keep a "global log of all command output" in the builder object, 416 | # so we can toss that into the generated package too for tracability? 417 | sub runcmd { 418 | my $self = shift; 419 | my $cmd = shift; 420 | my $count = shift; 421 | $count ||= 10; 422 | 423 | $self->infomsg("RUNNING: $cmd"); 424 | 425 | my @last = (); 426 | my $writer = FileHandle->new; 427 | my $reader = FileHandle->new; 428 | 429 | my $pid = open3( $writer, $reader, undef, $cmd ); 430 | close $writer; 431 | while (<$reader>) { 432 | print if ( $self->verbose ); 433 | push @last, $_; 434 | shift @last if ( @last > $count ); 435 | } 436 | close $reader; 437 | 438 | waitpid $pid, 0; 439 | 440 | die "Build failed: @last" if ( $? >> 8 ); 441 | 442 | return @last; 443 | } 444 | 445 | sub fetch { 446 | my $self = shift; 447 | my $target; 448 | 449 | # build cpan module 450 | if ( $target = $self->info->data->{'cpan-module'} ) { 451 | 452 | eval { require Seco::CPAN; }; 453 | die "Seco::CPAN required to install cpan modules" if ($@); 454 | $self->infomsg("Fetching $target from CPAN"); 455 | my $agent = Seco::CPAN->new( 456 | depositdir => ( $self->tmpdir . "/cpan" ), 457 | tmpdir => $self->tmpdir 458 | ); 459 | 460 | my $hash = $agent->pull($target) 461 | or die "Unable to pull $target: $!"; 462 | my $name = lc $hash->{name}; 463 | my $loc = $hash->{tarball}; 464 | my $version = $hash->{version}; 465 | 466 | if ( $name ne $self->info->data->{name} ) { 467 | $self->forceok( "Package wants to be called $name, " 468 | . "you asked for " 469 | . $self->info->data->{name} 470 | . "\n" ); 471 | } 472 | 473 | $self->info->data->{sourcetar} = $loc; 474 | $self->info->data->{version} = $version; 475 | 476 | } 477 | # build from http 478 | elsif ( $target = $self->info->data->{'http'} ) { 479 | 480 | eval { require Seco::HTTP; }; 481 | die "Seco::HTTP required to build package from web: $@" if ($@); 482 | $self->infomsg("Fetching $target"); 483 | my $agent = Seco::HTTP->new( 484 | xfercmd => $self->info->data->{xfercmd}, 485 | depositdir => ( $self->tmpdir . "/source" ), 486 | tmpdir => $self->tmpdir 487 | ); 488 | 489 | my $hash = $agent->pull($target) 490 | or die "Unable to pull $target: $!"; 491 | my $loc = $hash->{tarball}; 492 | 493 | $self->info->data->{sourcetar} = $loc; 494 | 495 | } 496 | } 497 | 498 | sub build { 499 | my $self = shift; 500 | 501 | chdir $self->info->directory; 502 | my $realbuild = $self->builddir; 503 | 504 | # fetch source from remote 505 | $self->fetch(); 506 | 507 | # build the source if there is any 508 | if ( $self->info->data->{sourcedir} and -d $self->info->data->{sourcedir} ) { 509 | $self->infomsg( "Building from " . $self->info->data->{sourcedir} ); 510 | system( "cd " 511 | . $self->info->data->{sourcedir} . " && " 512 | . "tar cf - . | tar xf - -C $self->{builddir}" ); 513 | } 514 | elsif ( $self->info->data->{sourcetar} 515 | and -f $self->info->data->{sourcetar} ) 516 | { 517 | $self->infomsg( "Building from " . $self->info->data->{sourcetar} ); 518 | my $tar_opt = $self->taroption($self->info->data->{sourcetar}); 519 | system( "tar $tar_opt $self->{info}->{data}->{sourcetar} " . "-C $self->{builddir}" ); 520 | my $d; 521 | opendir $d, $self->builddir; 522 | foreach ( readdir $d ) { 523 | next if /^\./; 524 | if ( -d $self->builddir . "/$_" ) { 525 | $realbuild = $self->builddir . "/$_"; 526 | last; 527 | } 528 | } 529 | closedir $d; 530 | } 531 | else { 532 | return; 533 | } 534 | 535 | my $destdir = $self->installdir; 536 | my $prefix = $self->info->data->{buildprefix}?$self->info->data->{buildprefix}:"/usr"; 537 | my $perl = $self->info->data->{perl}?$self->info->data->{perl}:"/usr/bin/perl"; 538 | 539 | chdir $realbuild; 540 | $self->{_vars}{BUILDDIR} = $realbuild; 541 | 542 | my $patchdir = $self->info->directory . "/patches"; 543 | if ( -d $patchdir ) { 544 | $self->infomsg("Applying patches"); 545 | my $d; 546 | opendir $d, $patchdir; 547 | my @patches = sort { $a cmp $b } 548 | grep { $_ !~ /^\./ and -f "$patchdir/$_" } readdir $d; 549 | closedir $d; 550 | 551 | for my $patch (@patches) { 552 | $self->infomsg("Applying $patch"); 553 | $self->runcmd("patch --ignore-whitespace -p 1 -d . < $patchdir/$patch"); 554 | } 555 | } 556 | 557 | $self->infomsg("Building source"); 558 | 559 | if($self->info->data->{gem} and 560 | $self->info->scripts->{gembuild}) { 561 | # FATAL ON ERRORS 562 | $self->runcmd( "PERL=$perl INSTALLROOT=$destdir DESTDIR=$destdir " 563 | . "PREFIX=$prefix PKGVERID=" 564 | . $self->pkgverid . " " 565 | . "PACKAGEVERSION=" . $self->info->data->{version} . " " 566 | . "PACKAGENAME=" . $self->info->data->{name} . " " 567 | . $self->info->scripts->{build} ); 568 | return $self->error("Error running: $@") if($@); 569 | } else { 570 | # FATAL ON ERRORS 571 | $self->runcmd( "PERL=$perl INSTALLROOT=$destdir DESTDIR=$destdir " 572 | . "PREFIX=$prefix PKGVERID=" 573 | . $self->pkgverid . " " 574 | . "PACKAGEVERSION=" . $self->info->data->{version} . " " 575 | . "PACKAGENAME=" . $self->info->data->{name} . " " 576 | . $self->info->scripts->{build} ); 577 | return $self->error("Error running: $@") if($@); 578 | } 579 | chdir $self->cwd; 580 | } 581 | 582 | # verifies that installroot got some data 583 | sub verify_data { 584 | my $self = shift; 585 | my $root = shift; 586 | $root = $self->installdir unless defined($root); 587 | my $dir; 588 | opendir $dir, $root; 589 | while ( my $f = readdir $dir ) { 590 | next if ( $f eq '.' or $f eq '..' ); 591 | return 1 if ( -f "$root/$f" ); 592 | if ( -d "$root/$f" ) { 593 | return 1 if $self->verify_data("$root/$f"); 594 | } 595 | } 596 | closedir $dir; 597 | return 0; 598 | } 599 | 600 | # change #!/usr/bin/wrongperl to the one you asked for in index.yaml 601 | sub shebangmunge { 602 | my $self = shift; 603 | my $dirname = shift; 604 | if ( !defined($dirname) ) { 605 | $dirname = $self->installdir; 606 | } 607 | 608 | my $dir; 609 | opendir $dir, $dirname or die "Can't open $dirname"; 610 | while ( my $f = readdir $dir ) { 611 | next if ( $f eq '.' or $f eq '..' ); 612 | if ( -f "$dirname/$f" ) { 613 | my $out = `file $dirname/$f`; 614 | next unless ( $out =~ /text/ ); 615 | 616 | open my $g, "$dirname/$f"; 617 | my $firstline = <$g>; 618 | next unless ( $firstline =~ m#^\#\!(/.*/)(\w+)\s+?(.*)# ); 619 | my ( $path, $interpreter, $options ) = ( $1, $2, $3 ); 620 | 621 | if ( $self->info->data->{$interpreter} ) { 622 | $self->infomsg("SHEBANG-MUNGING $interpreter: $dirname/$f"); 623 | my $newinterp = $self->info->data->{$interpreter}; 624 | 625 | $firstline =~ s/$path$interpreter/$newinterp/; 626 | open my $h, ">" . $self->tmpdir . "/temp-munge" 627 | or die "Can't open " . $self->tmpdir . "/temp-munge"; 628 | print $h $firstline; 629 | while (<$g>) { 630 | print $h $_; 631 | } 632 | close $g; 633 | close $h; 634 | 635 | my $mode = ( stat("$dirname/$f") )[2]; 636 | rename $self->tmpdir . "/temp-munge" => "$dirname/$f"; 637 | chmod $mode, "$dirname/$f"; 638 | } 639 | } 640 | elsif ( -d "$dirname/$f" ) { 641 | $self->shebangmunge("$dirname/$f"); 642 | } 643 | } 644 | 645 | closedir $dir; 646 | } 647 | 648 | # process filetransforms (s/// on files) and dirtransforms 649 | # (moving directories around) 650 | sub transform { 651 | my $self = shift; 652 | my $installdir = $self->installdir; 653 | 654 | $self->shebangmunge if ( $self->info->data->{shebangmunge} ); 655 | 656 | if ( $self->info->data->{filetransforms} ) { 657 | for my $file ( keys %{ $self->info->data->{filetransforms} } ) { 658 | my ( $fh, $filename ) = tempfile( 'tempXXXXX', DIR => $self->tmpdir ); 659 | $self->infomsg("TRANSFORMING: $installdir/$file"); 660 | open my $g, "$installdir/$file" or next; 661 | while (<$g>) { 662 | for my $trans ( @{ $self->info->data->{filetransforms}->{$file} } ) { 663 | for my $from ( keys %$trans ) { 664 | my $to = $trans->{$from}; 665 | s/$from/$to/g; 666 | } 667 | } 668 | print $fh $_; 669 | } 670 | close $g; 671 | close $fh; 672 | rename $filename => "$installdir/$file"; 673 | } 674 | } 675 | 676 | if ( $self->info->data->{dirtransforms} ) { 677 | foreach my $transform ( @{ $self->info->data->{dirtransforms} } ) { 678 | my $from = $transform->{from}; 679 | my $to = $transform->{to}; 680 | 681 | $self->runcmd("mkdir -p '$installdir/$to'"); 682 | $self->runcmd("mv $installdir/$from/* $installdir/$to || echo fine"); 683 | $self->runcmd( "rmdir -p --ignore-fail-on-non-empty " . "$installdir/$from || echo fine" ); 684 | } 685 | } 686 | 687 | if($self->info->scripts->{transform}) { 688 | $self->runcmd( "INSTALLDIR=$installdir " 689 | . "PKGVERID=" 690 | . $self->pkgverid . " " 691 | . $self->info->scripts->{transform} ); 692 | } 693 | } 694 | 695 | sub copyroot { 696 | my $self = shift; 697 | 698 | my $installdir = $self->installdir; 699 | 700 | # copy root/ or root.tar.gz into installdir 701 | if ( $self->info->data->{rootdir} and -d $self->info->data->{rootdir} ) { 702 | $self->infomsg( "Using " . $self->info->data->{rootdir} ); 703 | system( "cd " 704 | . $self->info->data->{rootdir} . " && " 705 | . "tar cf - --exclude \.svn . | tar xf - -C $self->{installdir}" ); 706 | } 707 | elsif ( $self->info->data->{roottar} 708 | and -f $self->info->data->{roottar} ) 709 | { 710 | $self->infomsg( "Using " . $self->info->data->{roottar} ); 711 | my $tar_opt = $self->taroption($self->info->data->{roottar}); 712 | system( "tar $tar_opt $self->{info}->{data}->{roottar} " . " -C $self->{installdir}" ); 713 | } 714 | 715 | # install daemontools service 716 | if ( $self->info->scripts->{run} 717 | and $self->info->scripts->{logrun} ) 718 | { 719 | $self->info->data->{service} ||= $self->info->data->{name}; 720 | my $service = $self->info->data->{service}; 721 | 722 | $self->infomsg("Installing daemontools service $service"); 723 | 724 | for ( 725 | "etc", "etc/service", 726 | "etc/service/$service", "etc/service/$service/log", 727 | "etc/service/$service/log/main" 728 | ) 729 | { 730 | mkdir "$installdir/$_" unless ( -d "$installdir/$_" ); 731 | } 732 | 733 | copy( $self->info->scripts->{run}, "$installdir/etc/service/$service/run" ); 734 | copy( $self->info->scripts->{logrun}, "$installdir/etc/service/$service/log/run" ); 735 | chmod 0755, "$installdir/etc/service/$service/run", "$installdir/etc/service/$service/log/run"; 736 | my $uid = ( getpwnam('nobody') )[2]; 737 | my $gid = ( getpwnam('nobody') )[3]; 738 | chown $uid, $gid, "$installdir/etc/service/$service/log/main"; 739 | } 740 | } 741 | 742 | sub _find_attributes { 743 | my $name = shift; 744 | my $rules = shift; 745 | 746 | # return the last match 747 | my @found = ( grep { $_->{name} eq $name } (@$rules) ); 748 | return pop(@found); 749 | } 750 | 751 | sub _find_match_attributes { 752 | my $name = shift; 753 | my $rules = shift; 754 | 755 | # return the last shell pattern match 756 | my @found = ( grep { _fnmatch( $_->{name}, $name ) } (@$rules) ); 757 | return pop(@found); 758 | } 759 | 760 | # pure-perl implementation of File::FnMatch::fnmatch with 'FNM_PATHNAME' argument 761 | sub _fnmatch { 762 | my $pat = shift; 763 | my $str = shift; 764 | 765 | #dots are literal dots 766 | $pat =~ s{\.}{\\\.}g; 767 | 768 | #internal slashes must be escaped 769 | $pat =~ s{/}{\\/}g; 770 | 771 | #asterisks are everything but slash 772 | $pat =~ s{\*}{[^\/]*}g; 773 | 774 | #anchor it 775 | $pat =~ s{^}{\^}; 776 | $pat =~ s{$}{\$}; 777 | 778 | return $str =~ m/$pat/; 779 | } 780 | 781 | sub _find_parent_attributes { 782 | my $name = shift; 783 | my $rules = shift; 784 | 785 | my @found; 786 | for my $r (@$rules) { 787 | # syntax for "include all children of dir" is '/dir/...' 788 | next unless ( $r->{name} =~ /^(.+)\/\.\.\.$/ ); 789 | my $parent = quotemeta($1); 790 | 791 | push @found, $r 792 | if ( $name =~ /^$parent\/.+/ ); 793 | } 794 | 795 | return pop @found; 796 | } 797 | 798 | sub get_file_rules { 799 | my $self = shift; 800 | 801 | my @rules; 802 | for my $p ( @{ $self->info->data->{files} } ) { 803 | for my $f ( sort keys %$p ) { 804 | # remove any leading /, as a convenience for writing the files 805 | # configuration (->listdir() returns all contents using relative 806 | # paths) 807 | ( my $n = $f ) =~ s/^\/*//; 808 | # XXX: it could be useful to call ->substvars() here, so that a 809 | # single set of file rules would work for both rpm and yinst, etc 810 | $p->{$f}{name} = $n; 811 | if ( exists( $p->{$f}{perm} ) ) { 812 | die "perm was not octal for $f" 813 | unless ( $p->{$f}{perm} =~ /^0/ ); 814 | } 815 | push @rules, $p->{$f}; 816 | } 817 | } 818 | 819 | return @rules; 820 | } 821 | 822 | # Look up attribute 823 | sub get_file_attributes { 824 | my $self = shift; 825 | my $name = shift; 826 | 827 | my $attribs = undef; 828 | 829 | # first try to find a rule for the exact path name 830 | $attribs = _find_attributes( $name, $self->{_rules} ); 831 | return $attribs if ( defined($attribs) ); 832 | 833 | # next try matching via shell patterns 834 | $attribs = _find_match_attributes( $name, $self->{_rules} ); 835 | return $attribs if ( defined($attribs) ); 836 | 837 | # finally try matching for subtrees 838 | $attribs = _find_parent_attributes( $name, $self->{_rules} ); 839 | return $attribs; 840 | } 841 | 842 | package Seco::Multipkg::Builder::Rpm; 843 | use base qw/Seco::Multipkg::Builder/; 844 | 845 | use POSIX qw/strftime/; 846 | 847 | BEGIN { 848 | __PACKAGE__->_accessors( stagedir => undef ); 849 | } 850 | 851 | sub makepackage { 852 | my $self = shift; 853 | 854 | mkdir $self->tmpdir . "/rpm"; 855 | mkdir $self->tmpdir . "/rpm/rpmtop"; 856 | mkdir $self->tmpdir . "/rpm/rpmtop/BUILD"; 857 | mkdir $self->tmpdir . "/rpm/rpmtop/RPMS"; 858 | mkdir $self->tmpdir . "/rpm/rpmtemp"; 859 | mkdir $self->tmpdir . "/rpm/rpmbuild"; 860 | 861 | $self->info->data->{rpmtemprepo} = $self->tmpdir . "/rpm"; 862 | 863 | if ( !$self->info->data->{arch} ) { 864 | $self->info->data->{arch} = `arch`; 865 | chomp $self->info->data->{arch}; 866 | } 867 | 868 | $self->template_file( $self->info->confdir . "/templates/spec.template", 869 | $self->tmpdir . "/spec" ); 870 | 871 | open my $f, ">>" . $self->tmpdir . "/spec"; 872 | print $f "%files\n"; 873 | print $f "%defattr(-,root,root)\n"; 874 | my $installdir = $self->installdir; 875 | if($self->info->data->{gem}) { 876 | $self->install_gemspec; 877 | } 878 | 879 | foreach ( $self->listdir($installdir) ) { 880 | my $path = "$installdir/$_"; 881 | next if m{/\.packlist$}; # XXX: cleanup in build, not here 882 | 883 | # get attributes string 884 | my ( $rpmattr, $is_removed ) = $self->get_rpm_file_attributes($_); 885 | 886 | # skip directories unless .keep exists, in which case use %dir 887 | # skip .keep files 888 | next if (/\.keep$/); 889 | lstat($path) or die "can't lstat $path"; 890 | 891 | # ignore files pruned via the 'remove' attribute 892 | if ($is_removed) { 893 | # non-directories must actually be deleted, else RPM's check-files 894 | # script will abort the build 895 | unless ( -d _ ) { 896 | unlink($path) or die "cannot remove $path : $!"; 897 | } 898 | next; 899 | } 900 | 901 | if ( -d _ ) { 902 | print $f $rpmattr . "\%dir /$_\n" if ( -e "$path/.keep" ); 903 | } 904 | else { 905 | print $f $rpmattr . "/$_\n"; 906 | } 907 | } 908 | 909 | print $f "\n%changelog\n"; 910 | $self->writechangelog($f); 911 | 912 | close $f; 913 | 914 | open my $g, ">" . $self->tmpdir . "/spec.tmp"; 915 | open $f, "<" . $self->tmpdir . "/spec"; 916 | while ( my $line = <$f> ) { 917 | print $g $line 918 | unless ( $line =~ /^Conflicts:\s*$/ 919 | or $line =~ /^Requires:\s*$/ 920 | or $line =~ /^Obsoletes:\s*$/ 921 | or $line =~ /^Provides:\s*$/ ); 922 | } 923 | 924 | close $f; 925 | close $g; 926 | rename $self->tmpdir . "/spec.tmp" => $self->tmpdir . "/spec"; 927 | 928 | # remove any '.packlist' files created by makemaker 929 | $self->runcmd( "find " . $self->tmpdir . " -name .packlist -exec rm {} \\;" ); 930 | # remove .keep files 931 | $self->runcmd( "find " . $self->tmpdir . " -name .keep -exec rm {} \\;" ); 932 | 933 | my $rpm; 934 | my @ten; 935 | # FATAL ON ERRORS 936 | my $setarch = ''; 937 | if($self->info->data->{arch} eq 'i686') { 938 | $setarch = " setarch " . $self->info->data->{arch}; 939 | } 940 | 941 | @ten = $self->runcmd( 942 | "INSTALLROOT=" . $self->installdir . $setarch . 943 | " rpmbuild -bb --define '_topdir " . $self->tmpdir . "/rpm/rpmtop" . 944 | "' --buildroot " . $self->installdir . " " . 945 | $self->tmpdir . "/spec" ); 946 | # return $self->error("Can't run: $@") if($@); 947 | 948 | for my $rpmline (@ten) { 949 | if ( $rpmline =~ /Wrote: (.*\.rpm)/ ) { 950 | $rpm = $1; 951 | } 952 | } 953 | unless ($rpm) { 954 | return $self->error("Can't find rpm name"); 955 | } 956 | 957 | my $myrpm = File::Basename::basename $rpm; 958 | File::Copy::copy( $rpm, $self->cwd . "/$myrpm" ) 959 | or die "Unable to copy rpm to cwd: $!"; 960 | return $myrpm; 961 | } 962 | 963 | sub get_rpm_file_attributes { 964 | my $self = shift; 965 | my $name = shift; 966 | 967 | my $attr = $self->get_file_attributes($name); 968 | return ( '', 0 ) unless ( defined($attr) ); 969 | 970 | # convert attribs to rpm syntax 971 | my @rpmattrs; 972 | 973 | if ( exists( $attr->{config} ) ) { 974 | push @rpmattrs, '%config'; 975 | } 976 | if ( exists( $attr->{owner} ) || exists( $attr->{group} ) || exists( $attr->{perm} ) ) { 977 | my $mode = ( exists( $attr->{perm} ) ) ? "$attr->{perm}" : '-'; 978 | my $user = ( exists( $attr->{owner} ) ) ? $attr->{owner} : 'root'; 979 | my $group = ( exists( $attr->{group} ) ) ? $attr->{group} : 'root'; 980 | 981 | push @rpmattrs, "\%attr($mode, $user, $group)"; 982 | } 983 | my $is_removed = ( exists( $attr->{remove} ) ) ? $attr->{remove} : 0; 984 | 985 | my $rpmattr = (@rpmattrs) ? ( join( ' ', @rpmattrs ) . ' ' ) : ''; 986 | return ( $rpmattr, $is_removed ); 987 | } 988 | 989 | sub writechangelog { 990 | my $self = shift; 991 | my $output = shift; 992 | 993 | my $meta = $self->info->{'meta'}; 994 | 995 | my $fd; 996 | if ( ref($output) ) { 997 | $fd = $output; 998 | } 999 | else { 1000 | open $fd, '>', $output or die "can't open for writing: $output"; 1001 | } 1002 | 1003 | # rpm changelog happens in reverse 1004 | for my $c ( reverse( @{ $meta->{'actionlog'} } ) ) { 1005 | my @gmt = gmtime( $c->{'time'} ); 1006 | my $timestr = strftime( '%a %b %d %Y %H:%M:%S', @gmt ); 1007 | 1008 | printf $fd "* \%s \%s \n", $timestr, $c->{'actor'}; 1009 | for my $m ( @{ $c->{'actions'} } ) { 1010 | printf $fd "- \%s\n", $m->{'summary'}; 1011 | for ( split( "\n", $m->{'text'} ) ) { 1012 | s/\%/\%\%/g; # XXX: need to escape '%' in spec file 1013 | printf $fd " - \%s\n", $_; 1014 | } 1015 | } 1016 | print $fd "\n"; 1017 | } 1018 | 1019 | close($fd) unless ref($output); 1020 | } 1021 | 1022 | package Seco::Multipkg::Builder::Deb; 1023 | use base qw/Seco::Multipkg::Builder/; 1024 | 1025 | BEGIN { 1026 | 1027 | } 1028 | 1029 | sub makepackage { 1030 | my $self = shift; 1031 | 1032 | mkdir $self->installdir . "/DEBIAN" 1033 | unless ( -d $self->installdir . "/DEBIAN" ); 1034 | 1035 | if ( !$self->info->data->{arch} ) { 1036 | $self->info->data->{arch} = `dpkg --print-architecture`; 1037 | chomp $self->info->data->{arch}; 1038 | } 1039 | 1040 | $self->template_file( $self->info->confdir . "/templates/control.template", 1041 | $self->installdir . "/DEBIAN/control" ); 1042 | 1043 | my %trans = ( 1044 | 'pre.sh' => 'preinst', 1045 | 'post.sh' => 'postinst', 1046 | 'preun.sh' => 'prerm', 1047 | 'postun.sh' => 'postrm' 1048 | ); 1049 | 1050 | for (qw/pre.sh post.sh preun.sh postun.sh/) { 1051 | $self->template_file( $self->info->scripts->{$_}, 1052 | $self->installdir . "/DEBIAN/" . $trans{$_}, 0755 ) 1053 | if ( $self->info->scripts->{$_} 1054 | and -f $self->info->scripts->{$_} ); 1055 | } 1056 | 1057 | chdir( $self->cwd ); 1058 | my $deb = undef; 1059 | my @ten; 1060 | # FATAL ON ERRORS 1061 | @ten = $self->runcmd( "fakeroot dpkg-deb -b " . $self->installdir . " ." ); 1062 | # return $self->error("Cant run: $@") if($@); 1063 | 1064 | my $debline = pop @ten; 1065 | if ( $debline =~ /([^\/]+\.deb)'/ ) { 1066 | $deb = $1; 1067 | } 1068 | 1069 | return $deb; 1070 | } 1071 | 1072 | package Seco::Multipkg::Builder::Gem; 1073 | use base qw/Seco::Multipkg::Builder/; 1074 | 1075 | sub makepackage { 1076 | my $self = shift; 1077 | 1078 | # shove the file list into $self->info->data->{filelist} 1079 | my $installdir = $self->installdir; 1080 | my $buildprefix = $self->info->data->{buildprefix}; 1081 | my @filelist; 1082 | 1083 | my $geminstalldir = `gem environment gemdir`; 1084 | chomp $geminstalldir; 1085 | my $fullinstalldir = $geminstalldir . "/gems/" . 1086 | $self->info->data->{name} . "-" . 1087 | $self->info->data->{version}; 1088 | foreach ($self->listdir("$installdir/$fullinstalldir")) { 1089 | if (-f "$installdir/$fullinstalldir/$_") { 1090 | s#^$installdir/$fullinstalldir/##; 1091 | s#^$buildprefix/##; 1092 | push @filelist, "\"$_\""; 1093 | } 1094 | } 1095 | $self->info->data->{filelist} = join ",", @filelist; 1096 | 1097 | # generate the gemspec file based on that 1098 | my $name = $self->info->data->{name}; 1099 | my $version = $self->info->data->{version}; 1100 | 1101 | $self->runcmd("mkdir -p $installdir/$geminstalldir/specifications"); 1102 | 1103 | $self->template_file($self->info->confdir . "/templates/gemspec.template", 1104 | "$installdir/$geminstalldir/specifications/" . 1105 | "$name-$version.gemspec"); 1106 | 1107 | chdir($installdir . "/" . $fullinstalldir); 1108 | my $gem = undef; 1109 | my @ten = $self->runcmd("gem build $installdir/$geminstalldir/" . 1110 | "specifications/$name-$version.gemspec"); 1111 | for my $gemline (@ten) { 1112 | if ($gemline =~ /File: (.*\.gem)/) { 1113 | $gem = $1; 1114 | } 1115 | } 1116 | 1117 | unless ($gem) { 1118 | return $self->error("Can't find gem name"); 1119 | } 1120 | File::Copy::copy($gem, $self->cwd . "/$gem") 1121 | or die "Unable to copy gem to cwd: $!"; 1122 | 1123 | return $gem; 1124 | } 1125 | 1126 | package Seco::Multipkg::Builder::Tarball; 1127 | use base qw/Seco::Multipkg::Builder/; 1128 | 1129 | sub makepackage { 1130 | my $self = shift; 1131 | 1132 | my $tarname = 1133 | $self->info->data->{name} . '-' 1134 | . $self->info->data->{version} . '-' 1135 | . $self->info->data->{release} 1136 | . '.tar.gz'; 1137 | my @ten; 1138 | chdir( $self->installdir ); 1139 | eval { @ten = $self->runcmd( "tar zcvf '" . $self->cwd . "/$tarname' ." ); }; 1140 | chdir( $self->cwd ); 1141 | return $self->error("Can't run: $@") if ($@); 1142 | 1143 | return $tarname; 1144 | } 1145 | 1146 | package Seco::Multipkg::Info; 1147 | use YAML::Syck; 1148 | use File::Spec; 1149 | use base qw/Seco::Class/; 1150 | 1151 | use constant MULTIPKG_VERSION => '__MULTIPKG_BUILD_VERSION__'; 1152 | 1153 | BEGIN { 1154 | __PACKAGE__->_accessors( 1155 | directory => undef, 1156 | confdir => '__MULTIPKG_CONFIG_DIR__', 1157 | scripts => undef, 1158 | platform => undef, 1159 | overrides => {}, 1160 | data => undef, 1161 | meta => undef, 1162 | ); 1163 | __PACKAGE__->_requires(qw/directory/); 1164 | } 1165 | 1166 | sub _init { 1167 | my $self = shift; 1168 | 1169 | my $data; 1170 | 1171 | # try to load from YAML 1172 | 1173 | for ( $self->confdir . "/default.yaml", $self->directory . "/index.yaml" ) { 1174 | next unless ( -e $_ ); 1175 | 1176 | my $table; 1177 | eval { $table = YAML::Syck::LoadFile($_); }; 1178 | return $self->error("$_ exists but is malformed: $@") if $@; 1179 | $self->infomsg( "LOADING " . $_ ); 1180 | 1181 | foreach my $key ( keys %$table ) { 1182 | $data->{$key} ||= {}; 1183 | foreach my $key2 ( keys %{ $table->{$key} } ) { 1184 | $data->{$key}->{$key2} = $table->{$key}->{$key2}; 1185 | } 1186 | } 1187 | } 1188 | 1189 | # try to piece together the remaining data 1190 | my $dirname = $self->directory; 1191 | $self->directory =~ m/([^\/]+)?$/; 1192 | $data->{default}->{name} ||= $1 if ($1); 1193 | 1194 | my @platforms = $self->platforms; 1195 | 1196 | # look inside the directories, pick out good defaults 1197 | foreach my $base (@platforms) { 1198 | my $basedir = $self->directory . "/$base"; 1199 | $basedir = $self->directory if ( $base eq 'default' ); 1200 | $basedir = File::Spec->rel2abs($basedir); 1201 | 1202 | my $dir; 1203 | 1204 | if ( opendir $dir, $basedir ) { 1205 | my $name = $data->{$base}->{name}; 1206 | foreach ( readdir $dir ) { 1207 | next if /^\./; 1208 | 1209 | if ( -f "$basedir/$_" ) { 1210 | if (/^$name-([\d\.]+)\.tar\.(gz|bz2)/) { 1211 | $data->{$base}->{sourcetar} ||= "$basedir/$_"; 1212 | $data->{$base}->{version} ||= $1; 1213 | } 1214 | } 1215 | 1216 | if ( -d "$basedir/$_" ) { 1217 | if (/^$name-([\d\.]+)$/) { 1218 | $data->{$base}->{sourcedir} ||= "$basedir/$_"; 1219 | $data->{$base}->{version} ||= $1; 1220 | } 1221 | } 1222 | } 1223 | } 1224 | 1225 | $data->{$base}->{sourcedir} ||= "$basedir/source" 1226 | if ( -d "$basedir/source" ); 1227 | $data->{$base}->{rootdir} ||= "$basedir/root" 1228 | if ( -d "$basedir/root" ); 1229 | 1230 | my @suffix = qw(.tar.gz .tgz .tar.bz2 .tbz .tar.xz); 1231 | my @sourcetar = grep { -f } map { "$basedir/source$_" } @suffix; 1232 | my @roottar = grep { -f } map { "$basedir/root$_" } @suffix; 1233 | $data->{$base}->{sourcetar} ||= shift @sourcetar if @sourcetar; 1234 | $data->{$base}->{roottar} ||= shift @roottar if @roottar; 1235 | 1236 | for (qw/sourcedir rootdir/) { 1237 | next unless ( $data->{$base} and $data->{$base}->{$_} ); 1238 | next if ( $data->{$base}->{$_} =~ m!/! ); 1239 | $data->{$base}->{$_} = "$basedir/" . $data->{$base}->{$_} 1240 | if ( -d "$basedir/" . $data->{$base}->{$_} ); 1241 | } 1242 | 1243 | for (qw/sourcetar roottar/) { 1244 | next unless ( $data->{$base} and $data->{$base}->{$_} ); 1245 | next if ( $data->{$base}->{$_} =~ m!/! ); 1246 | $data->{$base}->{$_} = "$basedir/" . $data->{$base}->{$_} 1247 | if ( -f "$basedir/" . $data->{$base}->{$_} ); 1248 | } 1249 | } 1250 | 1251 | my $finaldata; 1252 | 1253 | for (@platforms) { 1254 | if ( my $platdata = $data->{$_} ) { 1255 | foreach my $key ( keys %$platdata ) { 1256 | $finaldata->{$key} = $platdata->{$key}; 1257 | } 1258 | } 1259 | } 1260 | 1261 | if ( !$finaldata->{packagetype} ) { 1262 | for ( reverse @platforms ) { 1263 | $finaldata->{packagetype} ||= 'gem' 1264 | if ( $_ eq 'gem' ); 1265 | $finaldata->{packagetype} ||= 'rpm' 1266 | if ( $_ eq 'rpm' ); 1267 | $finaldata->{packagetype} ||= 'deb' 1268 | if ( $_ eq 'deb' ); 1269 | } 1270 | $finaldata->{packagetype} ||= 'tarball'; 1271 | } 1272 | 1273 | # get scripts 1274 | my @scriptdirs = map { $self->directory . "/$_/scripts" } 1275 | grep { $_ ne 'default' } @platforms; 1276 | 1277 | unshift @scriptdirs, $self->directory . "/scripts"; 1278 | unshift @scriptdirs, $self->confdir . "/scripts"; 1279 | 1280 | my $scripts; 1281 | 1282 | for my $dir (@scriptdirs) { 1283 | $dir = File::Spec->rel2abs($dir); 1284 | if ( -d $dir ) { 1285 | my $d; 1286 | opendir $d, $dir; 1287 | for ( readdir $d ) { 1288 | next if (/^\./); 1289 | next unless ( -f "$dir/$_" ); 1290 | $scripts->{$_} = "$dir/$_"; 1291 | } 1292 | } 1293 | } 1294 | 1295 | $finaldata->{conflicts} ||= []; 1296 | $finaldata->{provides} ||= []; 1297 | $finaldata->{requires} ||= []; 1298 | $finaldata->{obsoletes} ||= []; 1299 | if ( $scripts->{run} ) { 1300 | push @{ $finaldata->{requires} }, 'daemontools'; 1301 | $scripts->{'post.sh'} ||= $scripts->{'supervisepost.sh'}; 1302 | $scripts->{'preun.sh'} ||= $scripts->{'supervisepreun.sh'}; 1303 | } 1304 | 1305 | my %new = map { $_ => 1 } @{ $finaldata->{conflicts} }; 1306 | my @cfl = keys %new; 1307 | $finaldata->{conflicts} = \@cfl; 1308 | 1309 | %new = map { $_ => 1 } @{ $finaldata->{requires} }; 1310 | my @req = keys %new; 1311 | $finaldata->{requires} = \@req; 1312 | 1313 | %new = map { $_ => 1 } @{ $finaldata->{obsoletes} }; 1314 | my @obs = keys %new; 1315 | $finaldata->{obsoletes} = \@obs; 1316 | 1317 | %new = map { $_ => 1 } @{ $finaldata->{provides} }; 1318 | my @prov = keys %new; 1319 | $finaldata->{provides} = \@prov; 1320 | 1321 | $finaldata->{conflictlist} = join ', ', @{ $finaldata->{conflicts} }; 1322 | $finaldata->{providelist} = join ', ', @{ $finaldata->{provides} }; 1323 | $finaldata->{requirelist} = join ', ', @{ $finaldata->{requires} }; 1324 | $finaldata->{obsoletelist} = join ', ', @{ $finaldata->{obsoletes} }; 1325 | 1326 | foreach my $k ( %{ $self->overrides } ) { 1327 | $finaldata->{$k} = $self->overrides->{$k}; 1328 | } 1329 | 1330 | $finaldata->{author} = 'nobody@null' 1331 | unless ( defined( $finaldata->{author} ) ); 1332 | 1333 | $finaldata->{url} = $finaldata->{srcurl} 1334 | if ( !( defined( $finaldata->{url} ) ) && defined( $finaldata->{srcurl} ) ); 1335 | 1336 | $finaldata->{url} = '' 1337 | unless ( defined( $finaldata->{url} ) ); 1338 | 1339 | $finaldata->{whoami} = _whoami(); 1340 | 1341 | $self->data($finaldata); 1342 | $self->scripts($scripts); 1343 | 1344 | # read in metadata from the package dir 1345 | my $init_meta = $self->meta; 1346 | $self->meta( {} ); 1347 | 1348 | my $mdir = $self->directory . '/meta'; 1349 | if ( -d $mdir ) { 1350 | my $d; 1351 | opendir $d, $mdir or die; 1352 | for ( sort grep { ( -f "$mdir/$_" ) } readdir $d ) { 1353 | $self->mergemeta("$mdir/$_"); 1354 | } 1355 | } 1356 | 1357 | # meta passed to the constructor overrides anything loaded 1358 | $self->mergemeta($init_meta) if ($init_meta); 1359 | 1360 | # initial action log 1361 | my $multipkg_init_meta = { 1362 | actionlog => [ 1363 | { 'time' => time(), 1364 | 'type' => 'build', 1365 | 'actor' => $finaldata->{'whoami'}, 1366 | 'actions' => [ 1367 | { 'summary' => 'Seco::Multipkg::Info initialization', 1368 | 'text' => "multipkg version: " . MULTIPKG_VERSION() . "\n", 1369 | }, 1370 | ], 1371 | }, 1372 | ], 1373 | }; 1374 | $self->mergemeta($multipkg_init_meta); 1375 | 1; 1376 | } 1377 | 1378 | sub findpath { 1379 | my $self = shift; 1380 | my $file = shift; 1381 | 1382 | my @platforms = $self->platforms; 1383 | 1384 | for my $root ( $self->directory, $self->confdir ) { 1385 | for ( reverse @platforms ) { 1386 | if ( -f "$root/$_/$file" ) { 1387 | $self->infomsg("Using $root/$_/$file"); 1388 | return "$root/$_/$file"; 1389 | } 1390 | } 1391 | if ( -f "$root/$file" ) { 1392 | $self->infomsg("Using $root/$file"); 1393 | return "$root/$file"; 1394 | } 1395 | } 1396 | 1397 | return undef; 1398 | } 1399 | 1400 | sub platforms { 1401 | my $self = shift; 1402 | 1403 | return @{ $self->{platforms} } if ( $self->{platforms} ); 1404 | my @platforms; 1405 | 1406 | if ( -f '/etc/platforms' ) { 1407 | open my $f, "/etc/platforms"; 1408 | while (<$f>) { 1409 | chomp; 1410 | push @platforms, $_; 1411 | } 1412 | close $f; 1413 | } 1414 | 1415 | my $uname = `uname`; 1416 | chomp $uname; 1417 | push @platforms, lc $uname; 1418 | 1419 | my $arch = `uname -m`; 1420 | chomp $arch; 1421 | $arch =~ s/686/386/; 1422 | push @platforms, $arch; 1423 | 1424 | if ( -f '/etc/debian_version' ) { 1425 | push @platforms, 'debian'; 1426 | push @platforms, 'deb'; 1427 | } 1428 | 1429 | if ( -f '/etc/redhat-release' ) { 1430 | push @platforms, 'redhat'; 1431 | push @platforms, 'rpm'; 1432 | open my $f, "/etc/redhat-release"; 1433 | my $rel = <$f>; 1434 | close $f; 1435 | 1436 | if ( $rel =~ /Red Hat Enterprise Linux AS release (\S+)/ ) { 1437 | push @platforms, "rhel-$1"; 1438 | } 1439 | 1440 | if ( $rel =~ /Red Hat Linux Advanced Server release (\S+)/ ) { 1441 | push @platforms, "rhas-$1"; 1442 | } 1443 | 1444 | if ( $rel =~ /Red Hat Linux release (\S+)/ ) { 1445 | push @platforms, "redhat-$1"; 1446 | } 1447 | } 1448 | push @platforms, 'override'; 1449 | push @platforms, $self->platform 1450 | if ( defined( $self->platform ) ); 1451 | 1452 | unshift @platforms, 'default'; 1453 | $self->{platforms} = \@platforms; 1454 | return @platforms; 1455 | } 1456 | 1457 | sub mergemeta { 1458 | my $self = shift; 1459 | my $merge = shift; 1460 | 1461 | my $d = ( ref($merge) ) ? $merge : YAML::Syck::LoadFile($merge); 1462 | _merge_tree( $self->meta, $d ); 1463 | } 1464 | 1465 | # dumb data merger: recurses into hash trees 1466 | # array types are concatenated, scalars overwrite each other 1467 | sub _merge_tree { 1468 | my ( $into, $from ) = @_; 1469 | 1470 | for ( keys %$from ) { 1471 | if ( ref( $from->{$_} ) eq 'HASH' ) { 1472 | $into->{$_} = {} unless exists( $into->{$_} ); 1473 | die "can't merge hash into non hash" 1474 | unless ( ref( $into->{$_} ) eq 'HASH' ); 1475 | _merge_tree( $into->{$_}, $from->{$_} ); 1476 | } 1477 | elsif ( ref( $from->{$_} ) eq 'ARRAY' ) { 1478 | $into->{$_} = [] unless exists( $into->{$_} ); 1479 | die "can't merge array into non array" 1480 | unless ( ref( $into->{$_} ) eq 'ARRAY' ); 1481 | push @{ $into->{$_} }, @{ $from->{$_} }; 1482 | } 1483 | else { 1484 | $into->{$_} = $from->{$_}; 1485 | } 1486 | } 1487 | } 1488 | 1489 | # generate identifying string for this host/user 1490 | sub _whoami { 1491 | my $name; 1492 | eval { 1493 | require Sys::Hostname; 1494 | 1495 | my $user = getpwuid($<); 1496 | $user = 'unknown' unless ( defined($user) ); 1497 | 1498 | $name = $user . '@' . Sys::Hostname->hostname(); 1499 | }; 1500 | $name = 'unknown' if ($@); 1501 | 1502 | return $name; 1503 | } 1504 | 1505 | 1; 1506 | --------------------------------------------------------------------------------