Bivio::Util::Release
# Copyright (c) 2001-2013 bivio Software, Inc. All rights reserved. # $Id$ package Bivio::Util::Release; use strict; use Bivio::Base 'Bivio.ShellUtil'; use Config (); use File::Find (); use URI::Heuristic (); b_use('IO.ClassLoaderAUTOLOAD'); # C<Bivio::Util::Release> Build and Release Management with b-release # # Host configuration is controlled via the C</etc/bivio.bconf>: # # cvs_rpm_spec_dir - cvs directory with rpm package specifications # rpm_http_root - rpm repository host name/port or absolute file # rpm_home_dir - location of rpms on build host # # # In the common form, 'build' will create a new rpm file for the # package. The package's rpm spec file will be retrieved from cvs and # the package will be checked out of cvs, and assembled into an rpm # according to the spec file. By default the 'HEAD' or current version # will be used checked out from cvs unless the '-version' flag is # specified. The output from the command details the steps involved # and the output from the cvs and rpm utilities. # # Example: # # b-release build myproject # # The commands executed would be (summarized): # # cvs checkout -f -r HEAD <cvs_rpm_spec_dir>/myproject.spec # rpmbuild -bb <cvs_rpm_spec_dir>/myproject.spec-build # cp -p i386/myproject-HEAD-<date_time>.i386.rpm <rpm_home_dir> # ln -s myproject-HEAD-<date_time>.i386.rpm myproject-HEAD.rpm # # The myproject.spec-build file is created dynamically by # b-release. # # # Installs the latest version of the package. The '-force' and # '-nodeps' can be used to control the rpm installation. The # '-version' flag determines the package version installed, the # default is 'HEAD'. # # Example: # # b-release install myproject # # The commands executed would be: # # rpm -Uvh <rpm_http_root>/<rpm_home_dir>/myproject-HEAD.rpm our($_TRACE); our($_MACROS); my($_VC_CHECKOUT) = 'bivio vc checkout'; my($_DT) = __PACKAGE__->use('Type.DateTime'); my($_FILES_LIST_BASE) = 'b_release_files.list'; my($_FILES_LIST) = '%{_builddir}/' . $_FILES_LIST_BASE; my($_EXCLUDE_LIST) = '%{_builddir}/b_release_files.exclude'; my($_NEED_BUILD_ROOT) = `rpmbuild --version` =~ /version 4\.[0-4]\./ ? 1 : 0; my($_R) = b_use('IO.Ref'); my($_C) = b_use('IO.Config'); $_C->register(my $_CFG = { cvs_rpm_spec_dir => ['pkgs'], rpm_home_dir => $_C->REQUIRED, rpm_http_root => undef, rpm_user => $_C->REQUIRED, rpm_group => undef, http_realm => undef, http_user => undef, http_password => undef, install_umask => 022, tmp_dir => "/var/tmp/build-$$", https_ca_file => undef, projects => [ [Bivio => b => 'bivio Software, Inc.'], ], }); sub OPTIONS { # build_stage : string [b] # # Value of C<-b> argument to C<rpm>. # # nodeps : boolean [0] # # Pass C<--nodeps> to C<rpm> # # version : string [HEAD] # # The suffix to the C<rpm> to install. If you want a particular version, # you would use this parameter. Otherwise, you probably would use # the default (C<HEAD>). return { %{__PACKAGE__->SUPER::OPTIONS()}, build_stage => ['String', 'b'], nodeps => ['Boolean', 0], version => ['String', 'HEAD'], }; } sub OPTIONS_USAGE { # Adds the following to standard options: # # -build_stage - rpm build stage, valid values [p,c,i,b], # identical to the rpm(1) -b option # -nodeps - install without checking dependencies # -version - the version to be built (default: HEAD) return __PACKAGE__->SUPER::OPTIONS_USAGE() .<<'EOF'; -build_stage - rpm build stage, valid values [p,c,i,b], identical to the rpm(1) -b option -nodeps - install without checking dependencies -version - the version to be built (default: HEAD) EOF } sub USAGE { # Returns: # # usage: b-release [options] command [args...] # commands: return <<'EOF'; usage: b-release [options] command [args...] commands: build package ... -- compile & build rpms create_stream pkg... -- generate a stream from a list of pkg names run_sh script -- runs script.sh from repository get_projects -- returns a hash_ref of projects install package ... -- install rpms from network repository install_host_stream -- executes "-force install_stream $(hostname)" install_stream stream_name -- installs all rpms in a stream list [uri] -- displays packages in network repository list_installed match -- lists packages which match pattern list_projects -- get project list as an array_ref list_projects_el -- get project list for Lisp setq list_projects_sh_except_bivio -- for home-env/install.sh list_updates stream_name -- list packages that need to updated update stream_name -- retrieve and apply updates yum_update -- bracket with magic to make yum update work EOF } sub build { my($self, @packages) = @_; # Builds software in stages (prepare, compile, install, package), # using an RPM spec file. build is wrapper around the original # rpm application to help the user access the right source code. # # package may be a fully qualified package spec such as # # spec-dir/myproject.spec # # or simple name which will default spec in the default cvs directory # # myproject # # Returns information about the commands executed. $self->assert_not_root; $self->usage_error("Missing spec file\n") unless @packages; my($rpm_stage) = $self->get('build_stage'); $self->usage_error("Invalid build_stage ", $rpm_stage, "\n") unless $rpm_stage =~ /^[pcib]$/; return _do_in_tmp($self, 1, sub { my($tmp, $output, $pwd) = @_; for my $specin (@packages) { my($specout, $base) = _create_rpm_spec( $self, $specin, $output, $pwd); my($rpm_command) = "rpmbuild -b$rpm_stage $specout"; if ($self->get('noexecute')) { _would_run("cd $tmp; $rpm_command", $output); next; } _system($rpm_command, $output); my($rpm_file) = $$output =~ /.*Wrote:\s+(\S+\.rpm)\n/is; _save_rpm_file($rpm_file, $output); _link_base_version(Type_FilePath()->get_tail($rpm_file), "$base.rpm", $output); } return; }); } sub create_stream { my($self, @pkg) = shift->name_args([['Line']], \@_); return `rpm -q @pkg --queryformat '%{NAME} %{VERSION}-%{RELEASE} %{NAME}-%{VERSION}-%{RELEASE}.%{ARCH}.rpm\n' | sort`; } sub download_file { sub DOWNLOAD_FILE {[ [qw(file_name Text)], ]} my($self, $bp) = shift->parameters(\@_); my($uri) = $bp->{file_name}; IO_File()->write($bp->{file_name}, _http_get(\$uri)); return; } sub get_projects { # Returns a map of root packages names and long names. # { # pet => 'bivio Software, Inc.', # } return {map({lc @$_[0], @$_[2]} @{$_CFG->{projects}})}; } sub handle_config { my(undef, $cfg) = @_; # cvs_rpm_spec_dir : array [pkgs] # # The cvs directories which hold your package specifications. # # http_password : string [undef] # # Password used if I<http_realm> set. # # http_realm : string [undef] # # Use basic authentication to retrieve files. It is recommended that # files are accessed via https to avoid passwords being sent in the clear. # # http_user : string [undef] # # User to use if I<http_realm> set. # # install_umask : int [022] # # Umask for builds and installs of binaries and libraries. # # projects : array_ref [[[Bivio => b => 'bivio Software, Inc.']]] # # Array_ref of array_refs of the form: # # [ # [ProjectRootPkg => shell-util-prefix => 'Copyright Owner, Inc.'], # ] # # This list is used by L<list_projects_el|"list_projects_el">. # # rpm_home_dir : string (required) # # The directory on the build server, where the rpms and tars reside, e.g. # # /home/b-release # # rpm_http_root : string [rpm_http_root] # # Where the packages reside in the http hierarchy, e.g. # # http://build-server/b-release # # It may also be a simple file. # # rpm_group : string [rpm_user] # # The group which owns the releases. This is probably the same group which # your http server is running as. # # rpm_user : string (required) # # The user which owns the releases. Typically, you want this to be root. # # tmp_dir : string ["/var/tmp/build-$$"] # # Where the builds and installs take place. b_die($cfg->{projects}, ': projects must be an array_ref') unless ref($cfg->{projects}) eq 'ARRAY'; $_CFG = {%$cfg}; $_CFG->{rpm_http_root} = $_CFG->{rpm_home_dir} unless defined($_CFG->{rpm_http_root}); $_CFG->{rpm_group} ||= $_CFG->{rpm_user}; return; } sub install { my($self, @packages) = @_; # Manages packages for a host. It will install/upgrade/remove packages. # Uses the environment settings for http_proxy if present. # # package may be a fully qualified name such as # # myproject-1.5.2-2.i386.rpm # # or simple name which will default the current version # # myproject # # Returns a list of commands executed. $self->usage_error("No packages to install?") unless @packages; my($command) = ['rpm', '-Uvh']; push(@$command, '--force') if $self->unsafe_get('force'); push(@$command, '--nodeps') if $self->unsafe_get('nodeps'); push(@$command, '--test') if $self->unsafe_get('noexecute'); #BUG: rpm 4.0.4 has a bug with proxy: after downloading correctly, it # installs the first package N times. NOTE: check below $ENV{http_proxy}. # push(@$command, _get_proxy($self)) # unless $_CFG->{http_realm}; # install all the packages my($prev) = []; foreach my $package (@packages) { push(@$prev, `rpm -q --queryformat '\%{NAME}-\%{VERSION}-\%{RELEASE}.\%{ARCH}.rpm' $package 2>/dev/null`, ); $package .= '.rpm' if $package =~ /\.\d+$/; $package .= '-'.$self->get('version').'.rpm' unless $package =~ /\.rpm$/; push(@$command, _create_uri($package)); } #TODO: download srcrpm and build/install _umask(); my($run) = sub { my($op) = @_; my($err) = $? if $op->() != 0; $self->print( "To rollback:\n", "rpm -Uvh --force --nodeps @$prev\n", ); if ($err) { $self->print("ERROR: exit status = $err\n"); CORE::exit(1); } return; }; return _do_in_tmp($self, 0, sub { my($tmp, $output) = @_; my($i) = 0; foreach my $arg (@$command) { next unless $arg =~ /^http/; my($file) = $arg =~ m{([^/]+)$}; b_use('IO.File')->write($file, _http_get(\$arg, $output)); substr($prev->[$i++], 0, 0) = ($arg =~ m{(.*/)})[0]; substr($arg, 0) = $file; } _output($output, "@$command\n"); # For some reason, system and `` doesn't work right with rpm and # a redirect (see _system, but `@$command 2>&1` doesn't work either). # There seems to be a "wait" problem. $self->print($$output); $$output = ''; $run->(sub {system(@$command)}); return; }) if $_CFG->{http_realm} || $ENV{http_proxy}; $self->print(join(' ', @$command, "\n")); $run->(sub {system(@$command)}); return; } sub install_host_stream { return shift->put(force => 1)->install_stream(_host_name()); } sub install_stream { my($self) = @_; # Installs the entire stream. return $self->install(@{_get_update_list(1, @_)}); } sub list { my($self, $uri) = @_; # Displays packages in default network repository. # # # Displays the packages at the specified repository. The uri may be of the # complete form: # # http://host:port/dir # # or directory. return join('', map("$_\n", ${_http_get(\($uri ||= ''))} =~ /.+\">\s*(\S+\.rpm)<\/A>/g)); } sub list_installed { my($self, $match) = @_; # Lists installed packages with Group and BuildHost for easy parsing. # I<match> is a regexp which can be used to limit packages listed. # Case is ignored on the match. $match = '.' unless defined($match); return join('', grep(/$match/i, split(/(?<=\n)/, `rpm -qa --queryformat '\%{NAME}-\%{VERSION}-\%{RELEASE} \%{GROUP} %{BUILDHOST}\\n'` ))); } sub list_projects { return $_R->nested_copy($_CFG->{projects}); } sub list_projects_el { # Returns the list of configured projects in the following order: # # RootPackage short-name Copyright Owner, Inc. return "(setq b-perl-projects\n '(" . join("\n ", map(sprintf('("%s" "%s" "%s")', @$_), @{$_CFG->{projects}})) . "))\n"; } sub list_projects_sh_except_bivio { # excluding Bivio and Bivio/PetShop return join( ' ', grep( !m{^Bivio(?:$|/)}, map($_->[0], @{$_CFG->{projects}}), ), ); } sub list_updates { # Lists packages in I<stream> that have updates. return join('', map("$_\n", @{_get_update_list(0, @_)})); } sub map_projects { my($proto, $op) = @_; return [map( $op->(@$_), @{$proto->list_projects}, )]; } sub update { my($self) = @_; # Download and apply package updates for the current stream. Does not install # packages if they aren't already on the current host. my($x) = _get_update_list(0, @_); return @$x ? $self->install(@$x) : "All packages up to date\n"; } sub _b_release_define { my($name, $string) = @_; $_MACROS->{$name} = $string; $string = ${b_use('IO.Ref')->to_string($string, undef, 0)} if ref($string); $string =~ s/\n/ /g; return '%define ' . $name . ' ' . $string; } sub _b_release_files { my($instructions) = @_; $instructions ||= <<'EOF'; + %files EOF $instructions .= "\%files\n" unless $instructions =~ /\%files\b/; my($prefix) = ''; my($res) = "cd \%{buildroot}\n"; $instructions = [split(/\n/, $instructions)]; while (defined(my $line = shift(@$instructions))) { $line =~ s/^\s+|\s+$//g; next unless length($line); if ($line =~ s/^\$\{(\w+)\}(.*)/"\$_MACROS->{$1}$2 || ''"/ee) { unshift(@$instructions, split(/\n/, $line)); next; } if ($line =~ /^\%defattr/) { $res .= "echo '$line'"; } elsif ($line eq '%files') { $res .= <<"EOF"; test -s '$_FILES_LIST' || { echo 'ERROR: Empty files list' exit 1 } \%files -f $_FILES_LIST_BASE EOF next; } elsif ($line eq '%') { # clear prefix $prefix = '', next; } elsif ($line =~ /^%/) { $prefix = $line . ' '; next; } elsif ($line eq '+') { $res .= <<"EOF"; { test -f $_FILES_LIST && perl -p -e 's#^[^/]+##' $_FILES_LIST echo 'so file is not empty' } > $_EXCLUDE_LIST ( # Protect against error exit %{allfiles} | fgrep -x -v -f $_EXCLUDE_LIST || true EOF $res .= ') '; if ($prefix) { my($p) = $prefix; $p =~ s/(\W)/\\$1/g; $res .= "| perl -p -e 's{^}{\Q$prefix\E}'"; } $res .= q{| perl -p -e 'm{/man\d[a-z]?/.*\.\d+} && s{$}{*}m'}; } elsif ($line =~ m#^/#) { if ($line =~ /[\?\*\[\]]/) { $line =~ s{^/}{}; $res .= qq{for file in $line; do test "\$file" = '$line' || echo '$prefix' "/\$file"; done}; } else { $res .= "echo '$prefix$line'"; } } else { die($line, ": unknown _b_release_files instruction"); } $res .= ">> $_FILES_LIST\n"; } # Don't need last \n chop($res); return $res; } sub _b_release_include { my($to_include, $spec_dir, $version, $output) = @_; # Returns contents of $to_include # _system("cd $_CFG->{tmp_dir} && bivio vc checkout $version" # . " $_CFG->{cvs_rpm_spec_dir}/$to_include", $output) # if $version; return ${b_use('IO.File')->read("$spec_dir$to_include")}; } sub _build_macros { my($build_root) = @_; my($vc_find) = b_use('Util.VC')->CONTROL_DIR_FIND_PREDICATE; return ($_NEED_BUILD_ROOT ? "BuildRoot: $build_root\n" : '') . '%define build_root %{buildroot}' . "\n" . <<"EOF"; \%define allfiles cd \%{buildroot}; find . $vc_find -prune -o -type l -print -o -type f -print | sed -e 's/^\\.//' \%define allcfgs cd \%{buildroot}; find . -name $vc_find -prune -o -type l -print -o -type f -print | sed -e 's/^\\./%config /' EOF } sub run_sh { my($self, $script) = @_; return $self->piped_exec('sh -x', _http_get(\("$script.sh"))); } sub yum_update { my($self, @command) = @_; my($restore) = []; my($conflicts) = _parse_stream( _host_name(), sub { my($base, $version, $rpm) = @_; # Can't use $version if HEAD, because that's # a symlink and not the actual version which yum knows return $version eq 'HEAD' ? $base : $rpm; } ); foreach my $rpm (@$conflicts) { system(qw(rpm --erase --justdb --nodeps), $rpm) } system( 'yum', $self->unsafe_get('force') ? '-y' : (), @command ? @command : 'update', ); $self->install_host_stream; return; } sub _chdir { my($dir, $output) = @_; b_use('IO.File')->chdir($dir); _output($output, "cd $dir\n"); return $dir; } sub _create_rpm_spec { my($self, $specin, $output, $pwd) = @_; my($build_root) = _mkdir_rpmbuild($self); my($version) = $self->get('version'); my($cvs) = 0; if ($specin =~ /\.spec$/) { $specin = $pwd.'/'.$specin unless $specin =~ m!^/!; } else { my($spec_dir) = $_CFG->{cvs_rpm_spec_dir}; my($first); foreach my $sd (ref($spec_dir) ? @$spec_dir : $spec_dir) { _system("bivio vc checkout '$version' '$sd'", $output); if ($first) { _system("cp -a '$sd'/*.* '$first'"); } else { $first = $sd; } } $specin = "$first/$specin.spec"; $specin = b_use('IO.File')->pwd.'/'.$specin unless $specin =~ m!^/!; $cvs = 1; } my($spec_dir) = $specin; $spec_dir =~ s#[^/]+$##; my($base_spec) = _read_all($specin); my($release) = _search('release', $base_spec) || _get_date_format(); my($name) = _search('name', $base_spec) || (b_use('Type.FileName')->get_tail($specin) =~ /(.*)\.spec$/); my($provides) = _search('provides', $base_spec) || $name; my($vc_find) = $self->new_other('VC')->CONTROL_DIR_FIND_PREDICATE; my($buf) = <<"EOF" . _perl_macros(); \%define suse_check echo not calling /usr/sbin/Check \%define cvs $_VC_CHECKOUT $version \%define rm_cvs_dirs (cd \%{_builddir} && find '\%{cvs_dir}' -type d $vc_find -exec \%{safe_rm} '{}' ';' -prune) || exit 1 Release: $release Name: $name Provides: $provides EOF # This is a different version $buf .= "Version: $version\n" unless _search('version', $base_spec); $buf .= "License: N/A\n" unless _search('license', $base_spec); $buf .= _build_macros($build_root); for my $line (@$base_spec) { 0 while $line =~ s{^\s*_b_release_include\((.+?)\);} {"_b_release_include($1, \$spec_dir, \$cvs ? \$version : 0, \$output)"}xeemg; $buf .= $line unless $line =~ /^(release|name|provides): /i; } local($_MACROS) = {}; $buf =~ s/\b(_b_release_(?:files|define)\(.*?\));/$1/eegs; my($safe_rm) = "b-release-safe_rm-$$-" . Biz_Random()->string; b_die('%prep', ': missing from spec file') unless $buf =~ s{(\n\%prep\s*?)\n}{$1 cd /tmp @{[_safe_rm($safe_rm)]} ./$safe_rm \%{_builddir} \%{buildroot} mkdir -p \%{_builddir} %{buildroot} mv $safe_rm \%{_builddir} cd \%{_builddir} \%define safe_rm \%{_builddir}/$safe_rm }s; $version = $1 if $buf =~ /\nVersion:\s*(\S+)/i; my($specout) = "$specin-build"; b_use('IO.File')->write($specout, \$buf); return ($specout, "$name-$version", "$name-$version-$release"); } sub _create_uri { my($name) = @_; # Returns a full URI for the specified file name. Prepends host and/or # directory if not already specified. return $name =~ /^http/ ? $name : "$_CFG->{rpm_http_root}/$name"; } sub _do_in_tmp { my($self, $assert_root, $op) = @_; # Returns output of operations. $self->usage_error($_CFG->{rpm_home_dir}, ': rpm_home_dir not found') unless !$assert_root || -d $_CFG->{rpm_home_dir}; b_use('IO.File')->rm_rf($_CFG->{tmp_dir}); b_use('IO.File')->mkdir_p($_CFG->{tmp_dir}); return _do_output(sub { my($output) = @_; my($prev_dir) = b_use('IO.File')->pwd; $op->(_chdir($_CFG->{tmp_dir}, $output), $output, $prev_dir); _chdir($prev_dir); b_use('IO.File')->rm_rf($_CFG->{tmp_dir}) unless $self->get('noexecute'); return; }); } sub _do_output { my($op) = @_; # Catch die and print output along with die. my($output) = ''; my($die) = Bivio::Die->catch(sub { return $op->(\$output); }); return $output unless $die; Bivio::IO::Alert->print_literally($output); $die->throw; # DOES NOT RETURN } sub _err_parser { my($orig, $final) = @_; # Gets rid of 'warning: x saved as y' if the files are the same return ("warning: $orig saved as $final\n") unless ${b_use('IO.File')->read($orig)} eq ${b_use('IO.File')->read($final)}; return ''; } sub _get_date_format { my(@n) = localtime; # Returns a date format for the current local time. return sprintf("%4d%02d%02d_%02d%02d%02d", 1900+$n[5], 1+$n[4], $n[3], $n[2], $n[1], $n[0]); } sub _get_proxy { my($self) = @_; # Returns the http proxy arguments if present, parsed from the # environment variable http_proxy. my($proxy) = $ENV{http_proxy}; return () unless $proxy; $proxy =~ m,/([\w\.]+):(\d+), || b_die('couldn\'t parse proxy: ', $proxy); return ( '--httpproxy', $1, '--httpport', $2, ); } sub _get_update_list { my($install, $self, $stream) = @_; # Returns a list of packages that exist on this machine and need updating. $self->usage_error("no stream specified.") unless $stream; my($local_rpms) = { map({ ($_ => 1, ($_ =~ /^(\S+)/)[0] => 1); } split( /\n/, `rpm -qa --queryformat '%{NAME} %{VERSION}-%{RELEASE}\n' | sort`, )), }; my($uri); return _parse_stream( $stream, sub { my($base, $version, $rpm) = @_; return !$local_rpms->{"$base $version"} && ($install || $local_rpms->{$base}) ? $rpm : (); }, ) } sub _host_name { return Sys::Hostname::hostname(); } sub _http_get { my($uri, $output) = @_; # Returns content pointed to by $uri. Handles local files as well # as remote files. ($$uri = _create_uri($$uri)) =~ /^\w+:/ or $$uri = URI::Heuristic::uf_uri($$uri)->as_string; _output($output, "GET $$uri\n"); local($ENV{HTTPS_CA_FILE}) = $_CFG->{https_ca_file} if $_CFG->{https_ca_file}; my($ua) = b_use('Ext.LWPUserAgent') ->new ->bivio_ssl_no_check_certificate ->bivio_redirect_automatically; $ua->credentials( URI->new($$uri)->host_port, @$_CFG{qw(http_realm http_user http_password)}, ) if $_CFG->{http_realm}; my($reply) = $ua->request( HTTP::Request->new('GET', $$uri)); b_die($$uri, ": GET failed: ", $reply->status_line) unless $reply->is_success; return \($reply->content); } sub _link_base_version { my($version, $base, $output) = @_; # Create link from $base to $version in rpm_home_dir. $base = "$_CFG->{rpm_home_dir}/$base"; unlink($base); _output($output, "LINKING $version AS $base\n"); _system("ln -s '$version' '$base'", $output); return if $base =~ /-HEAD\./; unlink($base); _output($output, "LINKING $version AS $base\n"); _system("ln -s '$version' '$base'", $output); return; } sub _mkdir_rpmbuild { my($self) = @_; my($map) = {${$self->piped_exec('rpmbuild --showrc')} =~ /:\s+(_[a-z]+)\s+(\S+)/g}; my($lookup) = sub { my($name) = @_; b_die($name, ': not found in `rpmbuild --showrc`') unless my $d = $map->{$name}; $map->{$name} = $d if $d =~ s{^\%\{getenv:(\w+)\}}{$ENV{$1}}; return $d if $name eq '_topdir'; b_die($d, ": $name does not begin with _topdir") unless $d =~ /^\%{_topdir}(.+)/; return $map->{_topdir} . $1; }; my($top) = $lookup->('_topdir'); foreach my $dir (qw( _builddir _rpmdir _sourcedir _specdir _srcrpmdir )) { IO_File()->mkdir_p($top . $lookup->($dir)); } return $lookup->('_builddir') . '/install'; } sub _output { my($output) = shift; # Appends output with arg(s). _trace(@_) if $_TRACE; $$output .= join('', @_) if $output; return; } sub _parse_stream { my($stream, $op) = @_; my($uri) = _stream_file($stream); return [ map({ my($base, $version, $rpm) = split(/\s+/, $_); $version ||= 'HEAD'; $rpm ||= "$base-$version.rpm"; $op->($base, $version, $rpm); } split(/\n/, ${_http_get(\$uri)})), ]; } sub _perl_macros { return join( '', map( '%define ' . $_ . " \%{nil}\n", '__perl_provides', '__perl_requires', ), map( _perl_macros_one(@$_), [ 'perl_build', 'Build.PL --destdir %{buildroot} --installdirs vendor', './Build code', './Build', ], [ 'perl_make', 'Makefile.PL DESTDIR=%{buildroot} INSTALLDIRS=vendor', 'make POD2MAN=true', 'make POD2MAN=true', ], ), ); } sub _perl_macros_one { my($name, $make_make, $make, $install) = @_; my($def) = sub { return ( '%define ', $name, shift(@_), ' ', _umask_string(), ' && ', @_, "\n", ); }; return ( $def->( '', 'perl ', $make_make, ' < /dev/null', ' && ', $make ), $def->( '_install', $install, ' pure_install', ' && %{safe_rm} %{buildroot}/usr/share/man %{buildroot}/usr/man', q{ && find %{buildroot} -name '*.bs' -o -name .packlist -o -name perllocal.pod | xargs rm -f}, ), ); } sub _project_args { my($want_die, $self, @projects) = @_; # Returns project config: ($self, $project) $self->usage_error('project not supplied') unless @projects; return ( $self, map({ my($p) = $_; (grep(lc($_->[0]) eq lc($p) || lc($_->[1]) eq lc($p), @{$_CFG->{projects}} ))[0] or $want_die ? $self->usage_error($_, ': project not found') : $p; } @projects), ); } sub _read_all { my($file) = @_; # Returns the entire contents of the named file. open(IN, $file) || b_die("$file: $!"); my(@data) = <IN>; close(IN); return \@data; } sub _rpm_uri_to_filename { my($uri) = @_; # Creates file name from $uri. Ensures directory exists. return b_use('IO.File')->mkdir_p('/var/spool/up2date') . '/'. b_use('Type.FileName')->get_tail($uri); } sub _safe_rm { my($name) = @_; return <<"END1" . <<'END2'; cat > $name <<'EOF' && chmod +x $name END1 #!/usr/bin/perl -w use strict; foreach my $f (@ARGV) { next unless -r $f; if (-f $f || -l $f && ! -d $f) { unlink($f); } elsif (`cd '$f' && pwd` =~ m{^(/[^/]+){3,}}s) { system(qw(rm -rf), $f); } else { die("$f: not deleting\n"); } } EOF END2 } sub _save_rpm_file { my($rpm_file, $output) = @_; b_die($rpm_file, ': missing rpm file') unless -f $rpm_file; $$output .= "SAVING RPM $rpm_file in $_CFG->{rpm_home_dir}\n"; _system("chown $_CFG->{rpm_user}.$_CFG->{rpm_group} $rpm_file", $output); _system("mv -f $rpm_file $_CFG->{rpm_home_dir}", $output); return; } sub _search { my($tag, $source) = @_; my($res) = [map(/^$tag: (.+)/i ? $1 : (), @$source)]; return @$res ? join(', ', @$res) : undef; } sub _stream_file { my($stream) = @_; return "$stream-rpms.txt" } sub _system { my($command, $output) = @_; # Executes the specified command, appending any results to the output. # Dies if the system call fails. my($die) = Bivio::Die->catch(sub { $command =~ s/'/"/g; _output($output, "$command\n"); _output($output, ${__PACKAGE__->piped_exec("sh -ec '$command' 2>&1")}); return; }); return unless $die; _output($output, ${$die->get('attrs')->{output}}); $die->throw; # DOES NOT RETURN } sub _umask { my($output) = @_; umask($_CFG->{install_umask}); _output($output, _umask_string() . "\n"); return; } sub _umask_string { return sprintf('umask 0%o', $_CFG->{install_umask}); } sub _would_run { my($cmd, $output) = @_; _output($output, "Would run: $cmd\n"); return; } 1;