our
(
$VERSION
);
$VERSION
= 0.66;
sub
has_cpan {
my
$has_config
= 0;
if
(
$ENV
{HOME}) {
eval
'CPAN'
,
'MyConfig.pm'
);};
$has_config
= 1
unless
$@;
}
unless
(
$has_config
) {
my
$dir
;
unless
(WIN32) {
$dir
=
$INC
{
'CPAN/Config.pm'
};
}
$has_config
= 1
unless
($@ or (
$dir
and not -w
$dir
));
}
require
CPAN
if
$has_config
;
return
$has_config
;
}
sub
has_ppm {
my
$has_ppm
= 0;
$has_ppm
= 1
unless
$@;
return
$has_ppm
;
}
sub
has_mb {
my
$has_mb
= 0;
$has_mb
= 1
unless
$@;
return
$has_mb
;
}
our
(
@EXPORT_OK
,
%EXPORT_TAGS
,
$protocol
,
$ext
,
$src_dir
,
$build_dir
,
$ERROR
);
$protocol
=
qr{^(http|ftp)://}
;
$ext
=
qr{\.(tar\.gz|tgz|tar\.Z|zip)}
;
my
@exports
=
qw(load_cs verifyMD5 html_escape parse_version $ERROR
is_core trim version which parse_ppd parse_ppm
ppd2cpan_version cpan2ppd_version tempfile what_have_you
mod_search dist_search file_to_dist ppm_search fetch_readme
fetch_file WIN32 HAS_CPAN HAS_PPM HAS_MB fix_path
package_status module_status fetch_nmake install_package)
;
%EXPORT_TAGS
= (
all
=> [
@exports
]);
@EXPORT_OK
= (
@exports
);
my
@path_ext
= ();
path_ext()
if
WIN32;
src_and_build();
my
@url_list
= url_list();
my
%Escape
= (
'&'
=>
'amp'
,
'>'
=>
'gt'
,
'<'
=>
'lt'
,
'"'
=>
'quot'
);
my
%dists
;
my
(
$soap
);
sub
fix_path {
my
$path
=
shift
;
$path
= Win32::GetShortPathName(
$path
);
$path
=~ s!\\!/!g;
$path
=~ s!/$!!;
return
$path
;
}
sub
load_cs {
my
$cs
=
shift
;
open
(
my
$fh
,
$cs
);
unless
(
$fh
) {
$ERROR
=
qq{Could not open "$cs": $!}
;
return
;
}
local
($/);
my
$eval
= <
$fh
>;
close
$fh
;
$eval
=~ s/\015?\012/\n/g;
my
$comp
= Safe->new();
my
$cksum
=
$comp
->reval(
$eval
);
if
($@) {
$ERROR
=
qq{eval of "$cs" failed: $@}
;
return
;
}
return
$cksum
;
}
sub
verifyMD5 {
my
(
$cksum
,
$file
) =
@_
;
my
(
$is
,
$should
);
open
(
my
$fh
,
$file
);
unless
(
$fh
) {
$ERROR
=
qq{Cannot open "$file": $!}
;
return
;
}
binmode
(
$fh
);
unless
(
$is
= Digest::MD5->new->addfile(
$fh
)->hexdigest) {
$ERROR
=
qq{Could not compute checksum for "$file": $!}
;
close
$fh
;
return
;
}
close
$fh
;
if
(
$should
=
$cksum
->{
$file
}->{md5}) {
my
$test
= (
$is
eq
$should
);
printf
qq{ Checksum for "$file" is %s\n}
,
(
$test
) ?
'OK.'
:
'NOT OK.'
;
return
$test
;
}
else
{
$ERROR
=
qq{Checksum data for "$file" not present.}
;
return
;
}
}
sub
html_escape {
local
$_
=
shift
;
s/([<>\"&])(?!\w+;)/\
&$Escape
{$1};/mg;
$_
;
}
sub
is_core {
my
$m
=
shift
;
$m
=~ s!::|-!/!g;
$m
.=
'.pm'
;
my
$is_core
;
foreach
(
@INC
) {
if
(-f
"$_/$m"
) {
$is_core
++
if
(
$_
!~ /site/);
last
;
}
}
return
$is_core
;
}
sub
trim {
local
$_
=
shift
;
s/^\s*//;
s/\s*$//;
return
$_
;
}
sub
file_to_dist {
my
$cpan_file
=
shift
;
return
unless
$cpan_file
;
my
(
$file
,
$path
,
$suffix
) = fileparse(
$cpan_file
,
$ext
);
my
(
$dist
,
$version
) = version(
$file
);
unless
(
$dist
and
$version
) {
$ERROR
=
qq{Could not find distribution name from $cpan_file.}
;
return
;
}
return
wantarray
? (
$dist
,
$version
) :
$dist
;
}
sub
ppd2cpan_version {
local
$_
=
shift
;
s/(,0)*$//;
tr
/,/./;
return
$_
;
}
sub
cpan2ppd_version {
local
$_
=
shift
;
return
join
','
, (
split
(/\./,
$_
), (0)x4)[0..3];
}
sub
version {
local
(
$_
) =
@_
;
s/
$ext
$//;
s!.*/(.*)!$1!;
s/([-_\d])(a|b|alpha|beta|src)$/$1/;
s/@\d.\d+//;
s/-v(\d)/$1/;
s/([-_\d\.])([a-z])([\d\._])/
sprintf
"$1%02d$3"
,
ord
(
lc
$2) -
ord
(
'a'
) /ei;
s/([-_\d\.])([a-z])$/
sprintf
"$1%02d"
,
ord
(
lc
$2) -
ord
(
'a'
) /ei;
s/(\d+)b/($1-1).
'.'
/e;
s/(\d+)a/($1-2).
'.'
/e;
s/-pre([\.\d])/-0.$1/;
s/\.\././g;
s/(\d)_(\d)/$1$2/g;
s/\W$//;
s/\@/./;
if
(s/[-_]?(\d+)\.(0\d+)\.(\d+)$//) {
return
(
$_
, $1 +
"0.$2"
+ $3 / 1000000);
}
elsif
(s/[-_]?(\d+)\.(\d+)\.(\d+)$//) {
return
(
$_
, $1 + $2/1000 + $3 / 1000000);
}
elsif
(s/[-_]?(\d+\.[\d_]+)$//) {
return
(
$_
, $1);
}
elsif
(s/[-_]?([\d_]+)$//) {
return
(
$_
, $1);
}
elsif
(s/-(\d+.\d+)-/-/) {
return
(
$_
, $1);
}
else
{
if
(
$_
=~ /\d/) {
return
(
$_
,
undef
);
}
else
{
return
(
$_
, 0);
}
}
}
sub
path_ext {
if
(
$ENV
{PATHEXT}) {
push
@path_ext
,
split
';'
,
$ENV
{PATHEXT};
for
my
$extention
(
@path_ext
) {
$extention
=~ s/^\.*(.+)$/$1/;
}
}
else
{
push
@path_ext
,
qw(com exe bat)
;
}
}
sub
which {
my
$program
=
shift
;
return
undef
unless
$program
;
my
@results
= ();
for
my
$base
(
map
{ File::Spec->catfile(
$_
,
$program
) } File::Spec->path()) {
if
(
$ENV
{HOME} and not WIN32) {
$base
=~ s/~/
$ENV
{HOME}/o;
}
return
$base
if
-x
$base
;
if
(WIN32) {
for
my
$extention
(
@path_ext
) {
return
"$base.$extention"
if
-x
"$base.$extention"
;
}
}
}
}
sub
parse_ppd {
my
$file
=
shift
;
unless
(-e
$file
) {
$ERROR
=
qq{$file not found.}
;
return
;
}
my
$p
= XML::Parser->new(
Style
=>
'Subs'
,
Handlers
=> {
Char
=> \
&ppd_char
,
Start
=> \
&ppd_start
,
End
=> \
&ppd_end
,
Init
=> \
&ppd_init
,
Final
=> \
&ppd_final
,
},
);
my
$d
=
$p
->parsefile(
$file
);
return
$d
;
}
sub
ppd_init {
my
$self
=
shift
;
$self
->{_mydata} = {
SOFTPKG
=> {
NAME
=>
''
,
VERSION
=>
''
},
TITLE
=>
''
,
AUTHOR
=>
''
,
ABSTRACT
=>
''
,
OS
=> {
NAME
=>
''
},
ARCHITECTURE
=> {
NAME
=>
''
},
CODEBASE
=> {
HREF
=>
''
},
DEPENDENCY
=> [],
INSTALL
=> {
EXEC
=>
''
,
SCRIPT
=>
''
},
wanted
=> {
TITLE
=> 1,
ABSTRACT
=> 1,
AUTHOR
=> 1},
_current
=>
''
,
};
}
sub
ppd_start {
my
(
$self
,
$tag
,
%attrs
) =
@_
;
my
$internal
=
$self
->{_mydata};
$internal
->{_current} =
$tag
;
SWITCH: {
(
$tag
eq
'SOFTPKG'
) and
do
{
$internal
->{SOFTPKG}->{NAME} =
$attrs
{NAME};
$internal
->{SOFTPKG}->{VERSION} =
$attrs
{VERSION};
last
SWITCH;
};
(
$tag
eq
'CODEBASE'
) and
do
{
$internal
->{CODEBASE}->{HREF} =
$attrs
{HREF};
last
SWITCH;
};
(
$tag
eq
'OS'
) and
do
{
$internal
->{OS}->{NAME} =
$attrs
{NAME};
last
SWITCH;
};
(
$tag
eq
'ARCHITECTURE'
) and
do
{
$internal
->{ARCHITECTURE}->{NAME} =
$attrs
{NAME};
last
SWITCH;
};
(
$tag
eq
'INSTALL'
) and
do
{
$internal
->{INSTALL}->{EXEC} =
$attrs
{EXEC};
last
SWITCH;
};
(
$tag
eq
'DEPENDENCY'
) and
do
{
push
@{
$internal
->{DEPENDENCY}},
{
NAME
=>
$attrs
{NAME},
VERSION
=>
$attrs
{VERSION}};
last
SWITCH;
};
}
}
sub
ppd_char {
my
(
$self
,
$string
) =
@_
;
my
$internal
=
$self
->{_mydata};
my
$tag
=
$internal
->{_current};
if
(
$tag
and
$internal
->{wanted}->{
$tag
}) {
$internal
->{
$tag
} .= html_escape(
$string
);
}
elsif
(
$tag
and
$tag
eq
'INSTALL'
) {
$internal
->{INSTALL}->{SCRIPT} .=
$string
;
}
else
{
}
}
sub
ppd_end {
my
(
$self
,
$tag
) =
@_
;
delete
$self
->{_mydata}->{_current};
}
sub
ppd_final {
my
$self
=
shift
;
return
$self
->{_mydata};
}
sub
parse_ppm {
my
$file
=
$PPM::PPMdat
;
unless
(-e
$file
) {
$ERROR
=
qq{$file not found.}
;
return
;
}
my
$p
= XML::Parser->new(
Style
=>
'Subs'
,
Handlers
=> {
Char
=> \
&ppm_char
,
Start
=> \
&ppm_start
,
End
=> \
&ppm_end
,
Init
=> \
&ppm_init
,
Final
=> \
&ppm_final
,
},
);
my
$d
=
$p
->parsefile(
$file
);
return
$d
;
}
sub
ppm_init {
my
$self
=
shift
;
$self
->{_mydata} = {
PPMVER
=>
''
,
OPTIONS
=> {
BUILDDIR
=>
''
,
CLEAN
=>
''
},
wanted
=> {
PPMVER
=> 1},
_current
=>
''
,
};
}
sub
ppm_start {
my
(
$self
,
$tag
,
%attrs
) =
@_
;
my
$internal
=
$self
->{_mydata};
$internal
->{_current} =
$tag
;
SWITCH: {
(
$tag
eq
'OPTIONS'
) and
do
{
$internal
->{OPTIONS}->{BUILDDIR} =
$attrs
{BUILDDIR};
$internal
->{OPTIONS}->{CLEAN} =
$attrs
{CLEAN};
last
SWITCH;
};
}
}
sub
ppm_char {
my
(
$self
,
$string
) =
@_
;
my
$internal
=
$self
->{_mydata};
my
$tag
=
$internal
->{_current};
if
(
$tag
and
$internal
->{wanted}->{
$tag
}) {
$internal
->{
$tag
} .= html_escape(
$string
);
}
}
sub
ppm_end {
my
(
$self
,
$tag
) =
@_
;
delete
$self
->{_mydata}->{_current};
}
sub
ppm_final {
my
$self
=
shift
;
return
$self
->{_mydata};
}
sub
make_soap {
$ERROR
=
"SOAP::Lite is unavailable to make remote call."
;
return
;
}
return
SOAP::Lite
->uri(
$soap_uri
)
->proxy(
$soap_proxy
,
options
=> {
compress_threshold
=> 10000})
->on_fault(
sub
{
my
(
$soap
,
$res
) =
@_
;
warn
"SOAP Fault: "
,
(
ref
$res
?
$res
->faultstring
:
$soap
->transport->status),
"\n"
;
return
undef
;
});
}
sub
src_and_build {
return
if
(
$src_dir
and
$build_dir
);
SWITCH: {
HAS_CPAN and
do
{
$src_dir
=
$CPAN::Config
->{keep_source_where};
$build_dir
=
$CPAN::Config
->{build_dir};
last
SWITCH
if
(
$src_dir
and
$build_dir
);
};
HAS_PPM and
do
{
my
$d
= parse_ppm();
$src_dir
=
$d
->{OPTIONS}->{BUILDDIR};
$build_dir
=
$src_dir
;
last
SWITCH
if
(
$src_dir
and
$build_dir
);
};
$src_dir
= File::Spec->tmpdir() ||
'.'
;
$build_dir
=
$src_dir
;
}
}
sub
fetch_readme {
my
$search
=
shift
;
$soap
||= make_soap() or
return
;
my
$result
=
$soap
->get_readme(
$search
);
defined
$result
&&
defined
$result
->result or
do
{
$ERROR
=
"No results returned"
;
return
;
};
my
$text
=
$result
->result();
return
$text
eq
'1'
?
undef
:
$text
;
}
sub
tempfile {
my
$rand
=
int
(
rand
$$);
return
File::Spec->catfile(File::Spec->tmpdir(),
'ppm-make.'
.
$rand
);
}
sub
dist_search {
my
(
$query
,
%args
) =
@_
;
$query
=~ s!::!-!g;
my
$dists
;
foreach
my
$match
(CPAN::Shell->expand(
'Distribution'
,
qq{/$query/}
)) {
my
$string
=
$match
->as_string;
my
$cpan_file
;
if
(
$string
=~ /id\s*=\s*(.*?)\n/m) {
$cpan_file
= $1;
next
unless
$cpan_file
;
}
my
(
$dist
,
$version
) = file_to_dist(
$cpan_file
);
unless
(
$args
{no_case}) {
next
unless
$dist
=~ /
$query
/;
}
unless
(
$args
{partial}) {
if
(
$args
{no_case}) {
next
unless
$dist
=~ /^
$query
$/i;
}
else
{
next
unless
$dist
eq
$query
;
}
}
$dists
->{
$dist
}->{cpan_file} =
$cpan_file
;
$dists
->{
$dist
}->{version} =
$version
;
if
(
$string
=~ /\s+CPAN_USERID.*\s+\((.*)\)\n/m) {
$dists
->{
$dist
}->{author} = $1;
}
my
$mod
;
if
(
$string
=~ /\s+CONTAINSMODS\s+(\S+)/m) {
$mod
= $1;
}
next
unless
$mod
;
my
$module
= CPAN::Shell->expand(
'Module'
,
$mod
);
if
(
$module
) {
my
$desc
=
$module
->description;
$dists
->{
$dist
}->{abstract} =
$desc
if
$desc
;
}
}
return
$dists
;
}
sub
mod_search {
my
(
$query
,
%args
) =
@_
;
$query
=~ s!-!::!g;
my
$mods
;
my
@objs
= (not
$args
{partial} and not
$args
{no_case}) ?
CPAN::Shell->expand(
'Module'
,
$query
) :
CPAN::Shell->expand(
'Module'
,
qq{/$query/}
);
unless
(
@objs
> 0) {
$ERROR
=
"No results found for $query"
;
return
;
}
foreach
my
$obj
(
@objs
) {
my
$string
=
$obj
->as_string;
my
$mod
;
if
(
$string
=~ /id\s*=\s*(.*?)\n/m) {
$mod
= $1;
next
unless
$mod
;
}
unless
(
$args
{no_case}) {
next
unless
$mod
=~ /
$query
/;
}
unless
(
$args
{partial}) {
if
(
$args
{no_case}) {
next
unless
$mod
=~ /^
$query
$/i;
}
else
{
next
unless
$mod
eq
$query
;
}
}
if
(
my
$v
=
$obj
->cpan_version) {
$mods
->{
$mod
}->{version} =
$v
;
}
if
(
$string
=~ /\s+DESCRIPTION\s+(.*?)\n/m) {
$mods
->{
$mod
}->{abstract} = $1;
}
if
(
$string
=~ /\s+CPAN_USERID.*\s+\((.*)\)\n/m) {
$mods
->{
$mod
}->{author} = $1;
}
if
(
$string
=~ /\s+CPAN_FILE\s+(\S+)\n/m) {
$mods
->{
$mod
}->{cpan_file} = $1;
}
}
return
$mods
;
}
sub
ppm_search {
my
(
$searchRE
,
%args
) =
@_
;
$searchRE
=~ s!::!-!g;
eval
{
$searchRE
=~ /
$searchRE
/ };
if
($@) {
$ERROR
=
qq{"$searchRE" is not a valid regular expression.}
;
return
;
}
$searchRE
=
"(?i)$searchRE"
if
$args
{no_case};
$searchRE
=
"^$searchRE\$"
unless
$args
{partial};
my
$searchtag
;
for
my
$type
(
qw(AUTHOR ABSTRACT)
) {
$searchtag
=
$type
if
$args
{
$type
};
}
my
%reps
= PPM::ListOfRepositories();
my
@locations
=
$args
{location} ||
values
%reps
;
my
$packages
;
foreach
my
$loc
(
@locations
) {
my
%summary
;
if
(
defined
$searchRE
&&
(
%summary
= ServerSearch(
location
=>
$loc
,
searchRE
=>
$searchRE
,
searchtag
=>
$searchtag
))) {
foreach
my
$package
(
keys
%{
$summary
{
$loc
}}) {
$packages
->{
$loc
}->{
$package
} = \%{
$summary
{
$loc
}{
$package
}};
}
next
;
}
%summary
= RepositorySummary(
location
=>
$loc
);
if
(
%summary
) {
foreach
my
$package
(
keys
%{
$summary
{
$loc
}}) {
next
if
(
defined
$searchtag
&&
$summary
{
$loc
}{
$package
}{
$searchtag
} !~ /
$searchRE
/);
next
if
(!
defined
$searchtag
&&
defined
$searchRE
&&
$package
!~ /
$searchRE
/);
$packages
->{
$loc
}->{
$package
} = \%{
$summary
{
$loc
}{
$package
}};
}
}
else
{
my
%ppds
= PPM::RepositoryPackages(
location
=>
$loc
);
foreach
my
$package
(@{
$ppds
{
$loc
}}) {
my
%package_details
=
RepositoryPackageProperties(
package
=>
$package
,
location
=>
$loc
);
next
unless
%package_details
;
next
if
(
defined
$searchtag
&&
$package_details
{
$searchtag
} !~ /
$searchRE
/);
next
if
(!
defined
$searchtag
&&
defined
$searchRE
&&
$package
!~ /
$searchRE
/);
$packages
->{
$loc
}->{
$package
} = \
%package_details
;
}
}
}
unless
(
$packages
) {
$ERROR
=
qq{No packages found.}
;
return
;
}
my
$results
;
foreach
my
$location
(
keys
%{
$packages
}) {
foreach
my
$pack
(
keys
%{
$packages
->{
$location
}}) {
$results
->{
$pack
}->{abstract} =
$packages
->{
$location
}->{
$pack
}->{ABSTRACT};
$results
->{
$pack
}->{author} =
$packages
->{
$location
}->{
$pack
}->{AUTHOR};
$results
->{
$pack
}->{version} =
$packages
->{
$location
}->{
$pack
}->{VERSION};
push
@{
$results
->{
$pack
}->{repository}},
$location
;
}
}
return
$results
;
}
sub
fetch_file {
my
(
$dist
,
$no_case
) =
@_
;
my
$to
;
if
(
$dist
=~ m!
$protocol
!) {
(
$to
=
$dist
) =~ s!.*/(.*)!$1!;
print
"Fetching $dist ....\n"
;
my
$rc
= is_success(getstore(
$dist
,
$to
));
unless
(
$rc
) {
$ERROR
=
qq{Fetch of $dist failed.}
;
return
;
}
return
$to
;
}
unless
(
$dist
=~ /
$ext
$/) {
my
$mod
=
$dist
;
$mod
=~ s!-!::!g;
my
$results
= mod_search(
$mod
,
no_case
=>
$no_case
,
partial
=> 0);
unless
(
$dist
=
$results
->{
$mod
}->{cpan_file}) {
$ERROR
=
qq{Cannot get distribution name of $mod.}
;
return
;
}
}
my
$id
= dirname(
$dist
);
$to
= basename(
$dist
,
$ext
);
my
$src
= HAS_CPAN ?
File::Spec->catdir(
$src_dir
,
'authors/id'
,
$id
) :
$src_dir
;
my
$CS
=
'CHECKSUMS'
;
my
$get_cs
= 0;
for
my
$file
( (
$to
,
$CS
)) {
my
$local
= File::Spec->catfile(
$src
,
$file
);
if
(-e
$local
and
$src_dir
ne
$build_dir
and not
$get_cs
) {
copy(
$local
,
'.'
) or
do
{
$ERROR
=
"Cannot copy $local: $!"
;
return
;
};
next
;
}
else
{
my
$from
;
$get_cs
= 1;
foreach
my
$url
(
@url_list
) {
$url
=~ s!/$!!;
$from
=
$url
.
'/authors/id/'
.
$id
.
'/'
.
$file
;
print
"Fetching $from ...\n"
;
last
if
is_success(getstore(
$from
,
$file
));
}
unless
(-e
$file
) {
$ERROR
=
"Fetch of $file from $from failed"
;
return
;
}
if
(
$src_dir
ne
$build_dir
) {
unless
(-d
$src
) {
mkpath(
$src
) or
do
{
$ERROR
=
"Cannot mkdir $src: $!"
;
return
;
};
}
copy(
$file
,
$src
) or
warn
"Cannot copy $to to $src: $!"
;
}
}
}
return
$to
unless
$to
=~ /
$ext
$/;
my
$cksum
;
unless
(
$cksum
= load_cs(
$CS
)) {
$ERROR
=
qq{Checksums check disabled - cannot load $CS file.}
;
return
;
}
unless
(verifyMD5(
$cksum
,
$to
)) {
$ERROR
=
qq{Checksums check for "$to" failed.}
;
return
;
}
unlink
$CS
or
warn
qq{Cannot unlink "$CS": $!\n}
;
return
$to
;
}
sub
url_list {
my
@urls
;
if
(HAS_CPAN) {
push
@urls
, @{
$CPAN::Config
->{urllist}};
}
return
@urls
;
}
sub
module_status {
my
(
$module
,
$desired_version
) =
@_
;
my
(
$present
,
$installed_version
) = have_module(
$module
);
return
-1
if
not
$present
;
return
0
if
(
$desired_version
and not
$installed_version
);
return
1
if
(not
$desired_version
);
my
$status
= vcmp_cpan(
$installed_version
,
$desired_version
);
return
$status
== -1 ? 0 : 1;
}
sub
package_status {
my
(
$pack
,
$desired_version
) =
@_
;
$pack
=~ s!::!-!g;
my
(
$present
,
$installed_version
) = have_package(
$pack
);
return
-1
if
not
$present
;
return
0
if
(
$desired_version
and not
$installed_version
);
return
1
if
(not
$desired_version
);
my
$status
= vcmp_ppd(
$installed_version
,
$desired_version
);
return
$status
== -1 ? 0 : 1;
}
sub
have_module {
my
$mod
=
shift
;
$mod
=~ s!-!::!g;
(
my
$file
=
$mod
) =~ s!::!/!g;
$file
.=
'.pm'
;
my
$parsefile
;
foreach
(
@INC
) {
next
if
$_
eq
'.'
;
my
$candidate
= File::Spec->catfile(
$_
,
$file
);
if
(-e
$candidate
) {
$parsefile
=
$candidate
;
last
;
}
}
unless
(
$parsefile
) {
$ERROR
=
qq{Cannot find pm file corresponding to $mod.}
;
return
;
}
my
$version
= parse_version(
$parsefile
);
return
(1,
$version
);
}
sub
parse_version {
my
$parsefile
=
shift
;
my
$version
;
local
$/ =
"\n"
;
my
$fh
;
unless
(
open
(
$fh
,
$parsefile
)) {
$ERROR
=
"Could not open '$parsefile': $!"
;
return
;
}
my
$inpod
= 0;
while
(<
$fh
>) {
$inpod
= /^=(?!cut)/ ? 1 : /^=cut/ ? 0 :
$inpod
;
next
if
$inpod
|| /^\s*\
chop
;
next
unless
/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
my
$eval
=
qq{
package ExtUtils::MakeMaker::_version;
no strict;
local $1$2;
\$$2=undef; do {
$_
}
; \$$2
};
local
$^W = 0;
$version
=
eval
(
$eval
);
warn
"Could not eval '$eval' in $parsefile: $@"
if
$@;
last
;
}
close
$fh
;
return
$version
;
}
sub
have_package {
my
$package
=
shift
;
$package
=~ s!::!-!g;
my
$version
;
my
%installed
= PPM::InstalledPackageProperties();
if
(
my
$pkg
= (
grep
{/^
$package
$/}
keys
%installed
)[0]) {
$version
=
$installed
{
$pkg
}{
'VERSION'
};
}
else
{
$ERROR
=
qq{Could not determine version of $package}
;
return
;
}
return
(1,
$version
);
}
sub
vcmp_ppd {
my
(
$s1
,
$s2
) =
@_
;
my
@installed
=
split
(
','
,
$s1
);
my
@compare
=
split
(
','
,
$s2
);
my
$available
;
foreach
(0..3) {
next
if
$installed
[
$_
] ==
$compare
[
$_
];
$available
--
if
$installed
[
$_
] <
$compare
[
$_
];
$available
++
if
$installed
[
$_
] >
$compare
[
$_
];
last
;
}
return
$available
;
}
sub
vcmp_cpan {
my
(
$l
,
$r
) =
@_
;
local
($^W) = 0;
return
0
if
$l
eq
$r
;
return
(
$l
ne
"undef"
) <=> (
$r
ne
"undef"
) ||
$l
<=>
$r
||
$l
cmp
$r
;
}
sub
fetch_nmake {
my
(
$exe
,
$err
) = (
'nmake.exe'
,
'nmake.err'
);
if
(
my
$p
= which(
$exe
)) {
warn
qq{You already have $exe as "$p". Fetch aborted.}
;
return
$p
;
}
my
$nmake
=
'nmake15.exe'
;
unless
(is_success(getstore(
$r
,
$nmake
))) {
$ERROR
=
"Could not fetch $nmake"
;
return
;
}
unless
(-e
$nmake
) {
$ERROR
=
"Getting $nmake failed"
;
return
;
}
my
@args
= (
$nmake
);
system
(
@args
);
unless
(-e
$exe
and -e
$err
) {
$ERROR
=
"Extraction of $exe and $err failed"
;
return
;
}
my
$dir
= prompt(
'Which directory on your PATH should I copy the files to?'
,
$Config
{bin});
unless
(-d
$dir
) {
my
$ans
= prompt(
qq{$dir doesn\'t exist. Create it?}
, 'yes');
if
(
$ans
=~ /^y/i) {
mkdir
$dir
or
do
{
$ERROR
=
"Could not create $dir: $!"
;
return
;
};
}
else
{
$ERROR
=
"Will not create $dir"
;
return
;
}
}
for
(
$exe
,
$err
,
'README.TXT'
) {
move(
$_
,
$dir
) or
do
{
$ERROR
=
"Moving $_ to $dir failed: $!"
;
return
;
};
}
unlink
$nmake
or
warn
"Unlink of $nmake failed: $!"
;
return
which(
$exe
);
}
sub
prompt {
my
(
$mess
,
$def
) =
@_
;
die
"prompt() called without a prompt message"
unless
@_
;
my
$INTERACTIVE
= -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT));
(
$def
,
my
$dispdef
) =
defined
$def
? (
$def
,
"[$def] "
) : (
''
,
' '
);
{
local
$|=1;
print
"$mess $dispdef"
;
}
my
$ans
;
if
(
$INTERACTIVE
) {
$ans
= <STDIN>;
if
(
defined
$ans
) {
chomp
$ans
;
}
else
{
print
"\n"
;
}
}
unless
(
defined
(
$ans
) and
length
(
$ans
)) {
print
"$def\n"
;
$ans
=
$def
;
}
return
$ans
;
}
sub
install_package {
my
(
$package
,
%args
) =
@_
;
my
$version
=
$args
{version};
die
"Please specify a version"
unless
$version
;
my
$upgrade
=
$args
{upgrade};
my
$location
=
$args
{location};
unless
(
$location
) {
$ERROR
=
"Please specify a location"
;
return
;
}
my
$status
=
package_status(
$package
,
$version
);
if
(
$status
== 1) {
$ERROR
=
"Version $version of $package is already installed"
;
return
;
}
if
(
$status
== 0 and not
$upgrade
) {
$ERROR
=
qq{Specify the upgrade switch to upgrade $package.}
;
return
;
}
print
"Installing $package ...\n"
;
if
(
$status
== -1) {
PPM::InstallPackage(
package
=>
$package
,
location
=>
$location
)
or
do
{
$ERROR
=
"Could not install $package: $PPM::PPMERR"
;
return
;
};
}
else
{
PPM::UpgradePackage(
package
=>
$package
,
location
=>
$location
)
or
do
{
$ERROR
=
"Could not install $package: $PPM::PPMERR"
;
return
;
};
}
return
1;
}
sub
what_have_you {
my
(
$progs
,
$arch
,
$os
) =
@_
;
my
%has
;
if
(
defined
$progs
->{tar} and
defined
$progs
->{gzip}) {
$has
{tar} =
$progs
->{tar};
$has
{gzip} =
$progs
->{gzip};
}
elsif
((not WIN32 and
(not
$os
or
$os
=~ /Win32/i or not
$arch
or
$arch
=~ /Win32/i))) {
$has
{tar} =
$Config
{tar} || which(
'tar'
) ||
$CPAN::Config
->{tar};
$has
{gzip} =
$Config
{gzip} || which(
'gzip'
) ||
$CPAN::Config
->{gzip};
}
else
{
if
($@) {
$has
{tar} =
$Config
{tar} || which(
'tar'
) ||
$CPAN::Config
->{tar};
$has
{gzip} =
$Config
{gzip} || which(
'gzip'
) ||
$CPAN::Config
->{gzip};
}
else
{
$has
{tar} =
'Archive::Tar'
;
$has
{gzip} =
'Compress::Zlib'
;
}
}
if
(
defined
$progs
->{zip} and
defined
$progs
->{unzip}) {
$has
{zip} =
$progs
->{zip};
$has
{unzip} =
$progs
->{unzip};
}
else
{
if
($@) {
$has
{zip} =
$Config
{zip} || which(
'zip'
) ||
$CPAN::Config
->{zip};
$has
{unzip} =
$Config
{unzip} || which(
'unzip'
) ||
$CPAN::Config
->{unzip};
}
else
{
my
$zipv
=
$Archive::Zip::VERSION
+ 0;
if
(
$zipv
>= 1.02) {
$has
{zip} =
'Archive::Zip'
;
$has
{unzip} =
'Archive::Zip'
;
}
else
{
$has
{zip} =
$Config
{zip} || which(
'zip'
) ||
$CPAN::Config
->{zip};
$has
{unzip} =
$Config
{unzip} || which(
'unzip'
) ||
$CPAN::Config
->{unzip};
}
}
}
my
$make
= WIN32 ?
'nmake'
:
'make'
;
$has
{make} =
$progs
->{make} ||
$Config
{make} || which(
$make
) ||
$CPAN::Config
->{make};
if
(WIN32 and not
$has
{make}) {
$has
{make} = fetch_nmake();
}
$has
{perl} =
$Config
{perlpath} || which(
'perl'
);
foreach
(
qw(tar gzip make perl)
) {
unless
(
$has
{
$_
}) {
$ERROR
=
"Cannot find a '$_' program"
;
return
;
}
print
"Using $has{$_} ....\n"
;
}
return
\
%has
;
}
1;