App-CPANtoRPM
view release on metacpan or search on metacpan
lib/App/CPANtoRPM.pm view on Meta::CPAN
package App::CPANtoRPM;
# Copyright (c) 2012-2024 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
###############################################################################
use warnings;
use strict;
use locale;
use POSIX qw(locale_h);
use IO::File;
our($VERSION);
$VERSION="1.15";
$| = 1;
use vars qw($COM $DIR $ARCH $VERS);
use Config;
$ARCH = $Config{'archname'};
$VERS = $Config{'version'};
###############################################################################
# GLOBAL VARIABLES
###############################################################################
our $TMPDIR = "/tmp/cpantorpm";
our %Macros = (0 => {
'_optimize' => '$RPM_OPT_FLAGS',
'_buildroot' => '$RPM_BUILD_ROOT',
},
1 => {
'_optimize' => '%{optimize}',
'_buildroot' => '%{buildroot}',
}
);
our ($OUTPUT,@OUTPUT,%package,$MAN);
$package{'VERSION'} = $VERSION;
my $old_locale = setlocale(LC_TIME);
setlocale(LC_TIME, "C");
$package{'date'} = POSIX::strftime("%a %b %d %Y",localtime());
setlocale(LC_TIME, $old_locale);
###############################################################################
###############################################################################
sub _new {
my($class) = @_;
my $self = {
'add_provide' => [],
'add_require' => [],
'author' => [],
'build' => [],
'build_input' => [],
'build_rec' => 0,
'build_type' => '',
'clean_macros' => 0,
'config' => [],
'config_input' => [],
'cpan' => 'cpanplus',
'cwd' => '',
'debug' => 0,
'description' => '',
'disttag' => '%{?dist}',
'env' => {},
'epoch' => '',
'extracted' => '',
'file_path' => '',
'gpg_name' => '',
'gpg_passfile' => '',
'gpg_passwd' => '',
'gpg_path' => '',
'group' => 'Development/Libraries',
'inst_base' => '',
'inst_type' => '',
'install' => '',
'macros' => 0,
'mainpod' => '',
'mandir' => '',
'name' => '',
'no_clean' => 0,
'no_deps' => 0,
'no_tests' => 0,
'package' => '',
'packager' => '',
'patch' => '',
'patch_dir' => '',
'prefix' => 'perl-',
'release' => 1,
'rem_provide' => [],
'rem_require' => [],
'repl_provide' => [],
'repl_require' => [],
'rpmbuild' => '',
'runtime_rec' => 0,
lib/App/CPANtoRPM.pm view on Meta::CPAN
return 1 if ($@);
} elsif ($mod) {
eval "use $mod $vers ()";
return 1 if ($@);
} else {
eval "use $vers";
return 1 if ($@);
}
return 0;
}
############################################################################
# This function will try to accomplish a simple task using several
# different methods. It will try each method in order until success
# is achieved, or if all of them fail, an error condition will be
# noted.
#
# This is useful for simple tasks which can be trivially checked for
# success, but for which there are multiple possible ways to perform
# it, not all of which may be available.
#
# $success = $self->_multiple_methods($test,$method1,$method2,...);
#
# $test is a listref of:
#
# $test = [ CODEREF, ARGS ]
#
# where CODEREF is a reference to a subroutine to test to see if a method
# succeeded. ARGS is an optional list of arguments to pass to the function.
#
# Each method is a listref of one of the following forms:
#
# $method = [ 'system', EXECUTABLE, COMMAND, ARGS ]
# Run COMMAND as a system command (with ARGS). If EXECUTABLE
# (which is the main command) can't be found, this method is
# ignored.
#
# $method = [ 'module', MODULE, IMPORT_LIST, EVAL_STRING ]
# $method = [ 'module', MODULE, VERSION, IMPORT_LIST, EVAL_STRING ]
# First tries to load MODULE. If it succeeds, it imports
# the functions in IMPORT_LIST (which is a listref).
# Once done, it evaluates the string stored in EVAL_STRING.
#
# $method = [ 'function', CODEREF, ARGS ]
# Run &CODEREF (with ARGS)
#
# It returns 1 if one of the methods succeed, 0 otherwise.
#
sub _multiple_methods {
my($self,$test,@method) = @_;
my($testfunc,@args) = @$test;
$self->_log_indent(+1);
my(@print);
METHOD:
foreach my $method (@method) {
my($type,@tmp) = @$method;
@OUTPUT = ();
if ($type eq 'ignore') {
next METHOD;
} elsif ($type eq 'module') {
my ($module,$vers,$import_list,$eval_string);
if (ref($tmp[1])) {
($module,$import_list,$eval_string) = @tmp;
$vers = '';
} else {
($module,$vers,$import_list,$eval_string) = @tmp;
}
push(@print,
$self->_log_message('INFO',"Attempting module method: $module"));
my $err = $self->_load_module($module,$vers,@$import_list);
if ($err) {
$self->_log_indent(+1);
push(@print,
$self->_log_message('INFO',"Failed to load module: $module"));
$self->_log_indent(-1);
next METHOD;
}
push(@OUTPUT,eval "$eval_string");
} elsif ($type eq 'system' ||
$type eq 'system-null') {
my($bin,$command,@args) = @tmp;
my $exe = $self->_find_exe($bin);
if (! $exe) {
push(@print,
$self->_log_message('INFO',"System command not found: $command"));
next METHOD;
}
my $cmd;
if ($type eq 'system-null') {
$cmd = '(' . join(' ',$command,@args) . ") > /dev/null";
} else {
$cmd = '(' . join(' ',$command,@args) . ") > '$TMPDIR/cmd.out'";
}
$cmd =~ s/\{$bin\}/$exe/g;
push(@print,
$self->_log_message('INFO',"Attempting system command: $cmd"));
if (system($cmd) != 0) {
$self->_log_indent(+1);
push(@print,
$self->_log_message('INFO',"Failed system command: $cmd"));
$self->_log_indent(-1);
next METHOD;
}
if ($type eq 'system-null') {
@OUTPUT = ();
} else {
my $in = new IO::File;
$in->open("$TMPDIR/cmd.out");
my @out = <$in>;
$in->close();
chomp(@out);
@OUTPUT = @out;
}
} elsif ($type eq 'function') {
my($coderef,@args) = @$method;
my @out = &$coderef(@args);
chomp(@out);
@OUTPUT = @out;
}
if (&$testfunc(@args)) {
$self->_log_indent(-1);
return 1;
}
}
if (@print) {
$self->_log_message('NONE',@print);
}
$self->_log_message('WARN','All methods for this task failed',
'Please make sure one of the above methods works.');
$self->_log_indent(-1);
return 0;
}
############################################################################
# Read in an opts file
#
sub _opt_file {
my($self,$file) = @_;
if (! -r $file) {
$self->_log_message('ERR',"Options file not readable: $file");
}
my $succ;
if ($file =~ /\.(yml|yaml)$/i) {
$succ = $self->_multiple_methods
( [ sub { 1; } ],
[ 'module', 'YAML::XS', [],
"my \@tmp = YAML::XS::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
[ 'module', 'YAML::Tiny', [],
"my \@tmp = YAML::Tiny::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
[ 'module', 'YAML', [],
"my \@tmp = YAML::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
[ 'module', 'YAML::Syck', [],
"my \@tmp = YAML::Syck::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
);
} elsif ($file =~ /\.json$/i) {
$succ = $self->_multiple_methods
( [ sub { 1; } ],
[ 'module', 'JSON::XS', ['decode_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = decode_json(\$json_text);" ],
[ 'module', 'JSON', ['from_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = from_json(\$json_text);" ],
[ 'module', 'JSON::PP', ['decode_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = decode_json(\$json_text);" ],
[ 'module', 'JSON::DWIW', ['from_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = from_json(\$json_text);" ],
);
} else {
$self->_log_message('ERR',"Options file must be YAML or JSON: $file");
}
if (! $succ) {
$self->_log_message('ERR',"Unable to read options file: $file");
}
return () if (! exists $OUTPUT->{$$self{'package'}});
my @opts;
foreach my $line (@{ $OUTPUT->{$$self{'package'}} }) {
if ($line =~ /^(.+?)(?:\s+|=)(.+?)\s*$/) {
push(@opts,$1,$2);
} else {
push(@opts,$line);
}
}
return @opts;
}
###############################################################################
# This either renames or copies a file.
#
sub _backup_file {
my($self,$file1,$file2,$copy) = @_;
if ($copy) {
if (-d $file2) {
my @f = split(/\//,$file1);
my $f = pop(@f);
$file2 = "$file2/$f";
}
if (-f $file2) {
if (! unlink $file2) {
$self->_log_message('ERR',
"Unable to remove/overwrite file: $file2: $!");
}
}
my $succ = $self->_multiple_methods( [ sub { -f "$file2" } ],
['module','File::Copy',['copy'],
"copy('$file1','$file2')" ],
['system','cp',
"{cp} '$file1' '$file2'"],
);
if (! $succ) {
$self->_log_message('ERR',"Unable to copy file: $file1 -> $file2");
}
} else {
if (! rename $file1,$file2) {
$self->_log_message('ERR',"Unable to back up file: $file1");
}
}
}
###############################################################################
###############################################################################
# This will install a newly created RPM into a yum repository. It will include
# both the RPM and SRPM.
sub _install_yum {
my($self) = @_;
my $yum = $$self{'yum'};
$self->_log_message('HEAD',"Installing in yum repository: $package{name}");
lib/App/CPANtoRPM.pm view on Meta::CPAN
#
if ($$self{'summary'}) {
$package{'summary'} = $$self{'summary'};
} elsif ($package{'m_abstract'}) {
$package{'summary'} = $package{'m_abstract'};
} elsif ($package{'files'}{'mainpod'} &&
$package{'files'}{'mainpod'}[2]) {
$package{'summary'} = $package{'files'}{'mainpod'}[2];
} else {
$package{'summary'} = 'A perl module';
}
#
# Handle the prefix and get various file names.
#
$package{'prefix'} = $$self{'prefix'};
my $pkgname = $$self{'prefix'} . $package{'name'};
$package{'rpmname'} = $pkgname;
$package{'specname'} = "$pkgname.spec";
#
# Check the requires/provides for this package.
#
$self->_provides();
$self->_requires('instfiles');
#
# Now clean up the directory.
#
system("cd $package{DIR}; $package{clean_cmd}");
}
# Get a list of all of the files in the package. We'll ignore directories.
# It will return a hash:
# { LC_FILE => { FILE => 1 } }
# where LC_FILE is a file (all lowercased) and FILE is the same file (or files)
# in the case they actually exist. All FILE and LC_FILE are the paths
# relative to the top directory in the package.
#
# {
# manifest => { MANIFEST => 1 }
# t/readme => { t/README => 1,
# t/Readme => 1 }
# }
#
sub _get_filelist {
my($self,$dir) = @_;
$self->_log_message('INFO',"Listing package files");
my $succ = $self->_multiple_methods
( [ sub { 1; } ],
[ 'module','File::Find',['find'],
qq< find(sub { push(\@OUTPUT,\$File::Find::name) if (-f) },"$dir"); >
],
[ 'system','find',
"{find} '$dir' -type f" ]
);
my %files;
foreach my $file (@OUTPUT) {
$file =~ s,^$dir/,,;
next if (! $file);
$files{lc($file)}{$file} = 1;
}
return %files;
}
# This looks at the filelist determines which are pod files, which are
# .pm files, which are test files, etc.
#
sub _categorize_files {
my($self,$op,$dir,%files) = @_;
$self->_log_message('INFO',"Categorizing $op package files");
# First pass based on some simple tests.
my $in = new IO::File;
foreach my $file (keys %files) {
foreach my $f (keys %{ $files{$file} }) {
if ($op eq 'build') {
# Files in the blib directory:
#
# Ignored:
# */*.exists
#
# PM files:
# **/*.pm
#
# Bin files
# bin/*
# script/*
#
# man1 files:
# man1/*
# bindoc/*
#
# man3 files:
# man3/*
# libdoc/*
if ($f =~ /\.exists$/) {
next;
} elsif ($f =~ m,^lib/\Q$ARCH\E/.*\.pm$, ||
$f =~ m,^arch/auto/.*\.pm$,) {
$package{'instfiles'}{'pm'}{$f} = 1;
$package{'arch_inst'} = 1;
} elsif ($f =~ m,.*\.pm$,) {
$package{'instfiles'}{'pm'}{$f} = 1;
$package{'lib_inst'} = 1;
} elsif ($f =~ m,^lib/\Q$ARCH\E/.*\.so$, ||
$f =~ m,^arch/auto/.*\.so$,) {
lib/App/CPANtoRPM.pm view on Meta::CPAN
# is 'shallowest'. In other words, if the POD files in the distribution
# are named:
# Foo
# Foo::Bar
# Foo::Bar2
# we'll take 'Foo' one since it is the least number of levels. This
# will only occur if there is exactly 1 POD file at that level.
#
my ($n,$f);
$n = 100;
foreach my $pod (sort keys %{ $package{'files'}{'pod'} }) {
my $name = $package{'files'}{'pod'};
next if (! $name);
my @tmp = split(/::/,$name);
if (@tmp == $n) {
$f = '';
} elsif (@tmp < $n) {
$n = @tmp;
$f = $pod;
}
}
if ($f) {
($name,$summary,$description) = $self->_get_meta_pod($f);
$mainpod = $f;
last POD;
}
#
# We weren't able to determine the main POD file.
#
$self->_log_message
('WARN',"Automatic detection of main POD file failed.");
last POD;
}
if ($mainpod) {
$package{'files'}{'mainpod'} = [ $mainpod,$name,$summary,$description ];
}
}
# This will extract the information froma single META file.
sub _get_meta_meta {
my($self,$type,$filehash) = @_;
my $meta;
my @tmp = keys %$filehash;
if (@tmp != 1) {
my $tmp = $tmp[0];
$self->_log_message
('WARN',
"Multiple '$tmp' files exist (with different cases).",
"This is not supported, so they will be ignored.");
return;
}
my $file = "$package{DIR}/$tmp[0]";
$OUTPUT = '';
$self->_log_message('INFO',"Reading META file: $tmp[0]");
my $succ;
if ($type eq 'json') {
$succ = $self->_multiple_methods
( [ sub { 1; } ],
[ 'module', 'Parse::CPAN::Meta', '1.41', [],
"\$OUTPUT = Parse::CPAN::Meta->load_file('$file')" ],
[ 'module', 'JSON', ['from_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = from_json(\$json_text);" ],
[ 'module', 'JSON::XS', ['decode_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = decode_json(\$json_text);" ],
[ 'module', 'JSON::PP', ['decode_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = decode_json(\$json_text);" ],
[ 'module', 'JSON::DWIW', ['from_json'],
"my \$fh; " .
"open \$fh,'<:utf8','$file'; " .
"my \$json_text = do { local \$/; <\$fh> }; " .
"\$OUTPUT = from_json(\$json_text);" ],
);
} else {
$succ = $self->_multiple_methods
( [ sub { 1; } ],
# [ 'module', 'Parse::CPAN::Meta', [],
# "\$OUTPUT = Parse::CPAN::Meta::LoadFile('$file')" ],
# [ 'module', 'CPAN::Meta::YAML', [],
# "my \$fh; " .
# "open \$fh,'<:utf8','$file'; " .
# "my \$yaml_text = do { local \$/; <\$fh> }; " .
# "my \$tmp = CPAN::Meta::YAML->read_string(\$yaml_text);" .
# "\$OUTPUT = \$tmp->[0]" ],
[ 'module', 'YAML', [],
"my \@tmp = YAML::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
[ 'module', 'YAML::Syck', [],
"my \@tmp = YAML::Syck::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
[ 'module', 'YAML::XS', [],
"my \@tmp = YAML::XS::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
[ 'module', 'YAML::Tiny', [],
"my \@tmp = YAML::Tiny::LoadFile('$file'); " .
"\$OUTPUT = \$tmp[0]" ],
);
}
if (! $succ) {
$self->_log_message('WARN',"Unable to read META file: $tmp[0]");
return;
}
if (! $OUTPUT) {
$self->_log_message('ERR',"META file empty or corrupt: $tmp[0]");
return;
}
# Now get the meta information:
foreach my $f (qw(name version keywords abstract description author provides)) {
$self->_get_meta_field($f,"m_$f");
}
# License information is stored in multiple places:
# license => VALUE
# license => [ VALUE, VALUE, ... ]
# resources => license => [ VALUE, VALUE, ... ]
# license_uri => VALUE
if (! $package{'m_license'}) {
my $lic = '';
if ($OUTPUT->{'license'}) {
my @lic;
if (ref($OUTPUT->{'license'})) {
@lic = @{ $OUTPUT->{'license'} };
} else {
@lic = ($OUTPUT->{'license'});
}
foreach my $l (@lic) {
if ($l =~ /^perl$/i ||
$l =~ /^perl_5$/i) {
$l="GPL+ or Artistic";
} elsif ($l =~ /^apache$/i) {
$l="Apache Software License";
} elsif ($l =~ /^artistic$/i) {
$l="Artistic";
} elsif ($l =~ /^artistic_?2$/i) {
$l="Artistic 2.0";
} elsif ($l =~ /^bsd$/i) {
$l="BSD";
} elsif ($l =~ /^gpl$/i) {
$l="GPL+";
} elsif ($l =~ /^lgpl$/i) {
$l="LGPLv2+";
} elsif ($l =~ /^mit$/i) {
$l="MIT";
} elsif ($l =~ /^mozilla$/i) {
$l="MPL";
} elsif ($l =~ /^open_source$/i) {
$l="OSI-Approved"; # rpmlint will complain
} elsif ($l =~ /^unrestricted$/i) {
$l="Distributable";
} elsif ($l =~ /^restrictive$/i) {
$l="Non-distributable";
$self->_log_message
('WARN',
'License is "restrictive".',
'This package should not be redistributed.');
} else {
$l="Unknown license: $l";
$self->_log_message
('WARN',
"Unknown license: $l",
'Check to make sure this package is distributable.');
}
}
$lic = join(', ',@lic);
} elsif ($OUTPUT->{'resources'} &&
$OUTPUT->{'resources'}->{'license'}) {
$lic = join(' ',@{ $OUTPUT->{'resources'}->{'license'} });
} elsif ($OUTPUT->{'license_uri'}) {
$lic = $OUTPUT->{'license_uri'};
}
$package{'m_license'} = $lic if ($lic);
}
# Requires can come from an old-style META.yml file:
# requires => FEATURE => VERSION
# build_requires => FEATURE => VERSION
# configure_requires => FEATURE => VERSION
# or a new style META.json file:
# prereqs =>
# LEVEL => LEVEL = configure, build, test, runtime
# KEY => KEY = requires, recommends
# FEATURE => VERSION
#
# If we find prereqs in multiple files, we'll merge them
# (but we'll use the VERSION from the first file they're
# found in so we'll assume that we're examining the most
# accurate file first).
my %requires;
if ($OUTPUT->{'prereqs'}) {
my %lev = ( 'configure' => [ 'build' ],
'build' => [ 'build' ],
'test' => [ 'test' ],
'runtime' => [ 'build', 'runtime' ],
);
foreach my $lev (keys %lev) {
foreach my $t (@{ $lev{$lev} }) {
my @key = ('requires');
push(@key,'recommends')
if ( ($t eq 'build' && $$self{'build_rec'}) ||
($t eq 'test' && $$self{'test_rec'}) ||
($t eq 'runtime' && $$self{'runtime_rec'}) );
foreach my $key (@key) {
if ($OUTPUT->{'prereqs'}->{$lev} &&
$OUTPUT->{'prereqs'}->{$lev}->{$key}) {
foreach my $f (keys %{ $OUTPUT->{'prereqs'}->{$lev}->{$key} }) {
my $v = $OUTPUT->{'prereqs'}->{$lev}->{$key}->{$f};
$requires{$t}{$f} = $v;
}
}
}
}
}
} else {
# Requires
my %lev = ( 'configure_requires' => [ 'build' ],
'build_rquires' => [ 'build' ],
'requires' => [ 'build', 'runtime' ],
);
foreach my $lev (keys %lev) {
if ($OUTPUT->{$lev}) {
foreach my $f (keys %{ $OUTPUT->{$lev} }) {
my $v = $OUTPUT->{$lev}->{$f};
foreach my $t (@{ $lev{$lev} }) {
$requires{$t}{$f} = $v;
}
}
}
}
# Recommends
%lev = ( 'recommends' => [ 'build', 'runtime' ],
);
foreach my $lev (keys %lev) {
if ($OUTPUT->{$lev}) {
foreach my $f (keys %{ $OUTPUT->{$lev} }) {
my $v = $OUTPUT->{$lev}->{$f};
foreach my $t (@{ $lev{$lev} }) {
if ( ($t eq 'build' && $$self{'build_rec'}) ||
($t eq 'test' && $$self{'test_rec'}) ||
($t eq 'runtime' && $$self{'runtime_rec'}) ) {
$requires{$t}{$f} = $v;
}
}
}
}
}
}
if (%requires) {
foreach my $t (keys %requires) {
foreach my $f (keys %{ $requires{$t} }) {
my $v = $requires{$t}{$f};
$package{'requires'}{$t}{$f} = $v if (! $package{'requires'}{$t}{$f});
}
}
} else {
$package{'requires'} = \%requires;
}
}
sub _get_meta_field {
my($self,$meta_field,$pack_field) = @_;
return if ($package{$pack_field} ||
! exists $OUTPUT->{$meta_field});
$package{$pack_field} = $OUTPUT->{$meta_field};
# Strings containing newlines in the META.* files cause problems,
# so change them to spaces.
$package{$pack_field} =~ tr{\n}{ } if (! ref($OUTPUT->{$meta_field}));
}
# This will get the NAME, SUMMARY, and DESCRIPTION sections of a POD
# file. It will return () if it is not a valid POD file.
#
# This will use the following perl modules:
# Pod::Parser
# Pod::Simple::TextContent
#
sub _get_meta_pod {
my($self,$file) = @_;
my($name,$summary,$description);
POD:
while (1) {
#
# Try Pod::Parser
#
$self->_log_message('INFO',"Analyzing pod file with Pod::Parser: $file");
my $err = $self->_load_module("Pod::Select");
if (! $err) {
# NAME - SUMMARY
Pod::Select::podselect( { -output => "$TMPDIR/pod_select",
-selections => ["NAME"]
}, "$package{DIR}/$file");
my $fh = new IO::File;
$fh->open("$TMPDIR/pod_select");
my @in = <$fh>;
$fh->close();
chomp(@in);
if (@in) {
shift(@in);
while (@in && ! $in[0]) {
shift(@in);
}
if (@in && $in[0] =~ /^(\S+)\s+\-\s+(.*)$/) {
($name,$summary) = ($1,$2);
}
}
# DESCRIPTION
Pod::Select::podselect( { -output => "$TMPDIR/pod_select",
-selections => ["DESCRIPTION"]
}, "$package{DIR}/$file");
$fh->open("$TMPDIR/pod_select");
@in = <$fh>;
chomp(@in);
$fh->close();
# Although not great, we're going to keep only the first paragraph.
# The description stuff gets too long otherwise.
if (@in) {
shift(@in);
lib/App/CPANtoRPM.pm view on Meta::CPAN
" Vers : $package{vers}",
" Ext : " . ($package{'ext'} ? $package{'ext'} : ''),
" CPAN dir : " . ($package{'cpandir'} ? $package{'cpandir'} : '')
);
$self->_apply_patch();
$self->_run_script();
}
sub _is_file {
my($self,$package) = @_;
my $cwd = `pwd`;
chomp($cwd);
chdir $$self{'cwd'};
my $ret = '';
if (-d $package) {
$ret = 'dir';
} elsif (-e $package) {
$ret = 'file';
}
chdir($cwd);
# Set the file_path
if ($ret) {
if ($package =~ m,^/,) {
$$self{'file_path'} = $package;
} else {
$$self{'file_path'} = $$self{'cwd'} . "/" . $package;
}
}
return $ret;
}
# This will copy the directory unmodified into the temporary directory.
# It can use any of the following methods:
# File::Copy::Recursive
# system(cp -r)
#
sub _get_package_dir {
my($self,$package) = @_;
my($err);
$self->_log_message('INFO',"Package type: directory");
$package{'from'} = 'dir';
$package{'fromsrc'} = $package;
# If directory ends in '.' or '..', then we'll have to do a pwd
# to handle it.
$package =~ m,^(.*/)?(.*)$,;
my $dir = $2;
if ($dir eq '.' || $dir eq '..') {
$self->_log_message('INFO',"Diretory name not specified. Assuming '.'");
my $succ = $self->_multiple_methods( [ sub { 1; } ],
['system','pwd',
"cd '$$self{file_path}'; {pwd}"],
);
if (! $succ || ! @OUTPUT) {
$self->_log_message('ERR',
"Unable to determine package directory: $package");
}
$package = $OUTPUT[0];
$package =~ m,^(.*/)?(.*)$,;
$dir = $2;
}
my ($dist,$vers);
if ($dir =~ /^(.+)\-(.+)$/) {
($dist,$vers) = ($1,$2);
} else {
$self->_log_message('ERR','Invalid directory name: $dir');
}
$package{'DIR'} = "$TMPDIR/$dir";
$package{'dir'} = $dir;
$package{'dist'} = $dist;
$package{'vers'} = $vers;
# Copy in the directory
$self->_log_message('INFO',"Copying diretory");
my $succ = $self->_multiple_methods
( [ sub { -d "$TMPDIR/$dir" } ],
['module','File::Copy::Recursive',['dircopy'],
"\$File::Copy::Recursive::CPRFComp = 1; " .
"dircopy('$$self{file_path}','$TMPDIR')" ],
['system','cp',
"{cp} -r '$$self{file_path}' '$TMPDIR'"],
);
if (! $succ) {
$self->_log_message('ERR',"Unable to copy directory: $package");
}
}
# This takes an archive file containing a package and copies it into
# the temporary directory. It can use any of the following methods:
# File::Copy
# system(cp)
#
sub _get_package_file {
my($self,$package) = @_;
my $err;
$self->_log_message('INFO',"Package type: archive file");
$package{'from'} = 'file';
$package{'fromsrc'} = $package;
my($valid,$dir,$dist,$vers,$archive,$ext,$filetype) =
$self->_is_archive($$self{'file_path'});
if (! $valid) {
$self->_log_message('ERR',"Package file not a valid archive: $package");
}
$package{'DIR'} = "$TMPDIR/$dir";
$package{'dir'} = $dir;
$package{'dist'} = $dist;
$package{'vers'} = $vers;
$package{'archive'} = $archive;
$package{'ext'} = $ext;
$package{'filetype'} = $filetype;
( run in 2.590 seconds using v1.01-cache-2.11-cpan-13bb782fe5a )