764 lines
19 KiB
Perl
764 lines
19 KiB
Perl
package CPANPLUS::Internals::Utils;
|
|
|
|
use strict;
|
|
|
|
use CPANPLUS::Error;
|
|
use CPANPLUS::Internals::Constants;
|
|
|
|
use Cwd qw[chdir cwd];
|
|
use File::Copy;
|
|
use Params::Check qw[check];
|
|
use Module::Load::Conditional qw[can_load];
|
|
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
|
use version;
|
|
|
|
use vars qw[$VERSION];
|
|
$VERSION = "0.9910";
|
|
|
|
local $Params::Check::VERBOSE = 1;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
CPANPLUS::Internals::Utils - convenience functions for CPANPLUS
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $bool = $cb->_mkdir( dir => 'blah' );
|
|
my $bool = $cb->_chdir( dir => 'blah' );
|
|
my $bool = $cb->_rmdir( dir => 'blah' );
|
|
|
|
my $bool = $cb->_move( from => '/some/file', to => '/other/file' );
|
|
my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' );
|
|
|
|
my $cont = $cb->_get_file_contents( file => '/path/to/file' );
|
|
|
|
|
|
my $version = $cb->_perl_version( perl => $^X );
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<CPANPLUS::Internals::Utils> holds a few convenience functions for
|
|
CPANPLUS libraries.
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 $cb->_mkdir( dir => '/some/dir' )
|
|
|
|
C<_mkdir> creates a full path to a directory.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _mkdir {
|
|
my $self = shift;
|
|
|
|
my %hash = @_;
|
|
|
|
my $tmpl = {
|
|
dir => { required => 1 },
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or (
|
|
error(loc( Params::Check->last_error ) ), return
|
|
);
|
|
|
|
unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
|
|
error( loc("Could not use File::Path! This module should be core!") );
|
|
return;
|
|
}
|
|
|
|
eval { File::Path::mkpath($args->{dir}) };
|
|
|
|
if($@) {
|
|
chomp($@);
|
|
error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ ));
|
|
return;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $cb->_chdir( dir => '/some/dir' )
|
|
|
|
C<_chdir> changes directory to a dir.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _chdir {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $tmpl = {
|
|
dir => { required => 1, allow => DIR_EXISTS },
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
unless( chdir $args->{dir} ) {
|
|
error( loc(q[Could not chdir into '%1'], $args->{dir}) );
|
|
return;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $cb->_rmdir( dir => '/some/dir' );
|
|
|
|
Removes a directory completely, even if it is non-empty.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _rmdir {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $tmpl = {
|
|
dir => { required => 1, allow => IS_DIR },
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
|
|
error( loc("Could not use File::Path! This module should be core!") );
|
|
return;
|
|
}
|
|
|
|
eval { File::Path::rmtree($args->{dir}) };
|
|
|
|
if($@) {
|
|
chomp($@);
|
|
error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ ));
|
|
return;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $cb->_perl_version ( perl => 'some/perl/binary' );
|
|
|
|
C<_perl_version> returns the version of a certain perl binary.
|
|
It does this by actually running a command.
|
|
|
|
Returns the perl version on success and false on failure.
|
|
|
|
=cut
|
|
|
|
sub _perl_version {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $perl;
|
|
my $tmpl = {
|
|
perl => { required => 1, store => \$perl },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
my $perl_version;
|
|
### special perl, or the one we are running under?
|
|
if( $perl eq $^X ) {
|
|
### just load the config
|
|
require Config;
|
|
$perl_version = $Config::Config{version};
|
|
|
|
} else {
|
|
my $cmd = $perl .
|
|
' -MConfig -eprint+Config::config_vars+version';
|
|
($perl_version) = (`$cmd` =~ /version='(.*)'/);
|
|
}
|
|
|
|
return $perl_version if defined $perl_version;
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $cb->_version_to_number( version => $version );
|
|
|
|
Returns a proper module version, or '0.0' if none was available.
|
|
|
|
=cut
|
|
|
|
sub _version_to_number {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $version;
|
|
my $tmpl = {
|
|
version => { default => '0.0', store => \$version },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
$version =~ s!_!!g; # *sigh*
|
|
return $version if $version =~ /^\d*(?:\.\d+)?$/;
|
|
if ( my ($vers) = $version =~ /^(v?\d+(?:\.\d+(?:\.\d+)?)?)/ ) {
|
|
return eval { version->parse($vers)->numify };
|
|
}
|
|
return '0.0';
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $cb->_whoami
|
|
|
|
Returns the name of the subroutine you're currently in.
|
|
|
|
=cut
|
|
|
|
sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name }
|
|
|
|
=pod
|
|
|
|
=head2 _get_file_contents( file => $file );
|
|
|
|
Returns the contents of a file
|
|
|
|
=cut
|
|
|
|
sub _get_file_contents {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $file;
|
|
my $tmpl = {
|
|
file => { required => 1, store => \$file }
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
my $fh = OPEN_FILE->($file) or return;
|
|
my $contents = do { local $/; <$fh> };
|
|
|
|
return $contents;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $cb->_move( from => $file|$dir, to => $target );
|
|
|
|
Moves a file or directory to the target.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _move {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $from; my $to;
|
|
my $tmpl = {
|
|
file => { required => 1, allow => [IS_FILE,IS_DIR],
|
|
store => \$from },
|
|
to => { required => 1, store => \$to }
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
if( File::Copy::move( $from, $to ) ) {
|
|
return 1;
|
|
} else {
|
|
error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!));
|
|
return;
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $cb->_copy( from => $file|$dir, to => $target );
|
|
|
|
Moves a file or directory to the target.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _copy {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my($from,$to);
|
|
my $tmpl = {
|
|
file =>{ required => 1, allow => [IS_FILE,IS_DIR],
|
|
store => \$from },
|
|
to => { required => 1, store => \$to }
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
if( File::Copy::copy( $from, $to ) ) {
|
|
return 1;
|
|
} else {
|
|
error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!));
|
|
return;
|
|
}
|
|
}
|
|
|
|
=head2 $cb->_mode_plus_w( file => '/path/to/file' );
|
|
|
|
Sets the +w bit for the file.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _mode_plus_w {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
require File::stat;
|
|
|
|
my $file;
|
|
my $tmpl = {
|
|
file => { required => 1, allow => IS_FILE, store => \$file },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
### set the mode to +w for a file and +wx for a dir
|
|
my $x = File::stat::stat( $file );
|
|
my $mask = -d $file ? 0100 : 0200;
|
|
|
|
if( $x and chmod( $x->mode|$mask, $file ) ) {
|
|
return 1;
|
|
|
|
} else {
|
|
error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!));
|
|
return;
|
|
}
|
|
}
|
|
|
|
=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH );
|
|
|
|
Turns a CPANPLUS::Config style C<host> entry into an URI string.
|
|
|
|
Returns the uri on success, and false on failure
|
|
|
|
=cut
|
|
|
|
sub _host_to_uri {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my($scheme, $host, $path);
|
|
my $tmpl = {
|
|
scheme => { required => 1, store => \$scheme },
|
|
host => { default => 'localhost', store => \$host },
|
|
path => { default => '', store => \$path },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
### it's an URI, so unixify the path.
|
|
### VMS has a special method for just that
|
|
$path = ON_VMS
|
|
? VMS::Filespec::unixify($path)
|
|
: File::Spec::Unix->catdir( File::Spec->splitdir( $path ) );
|
|
|
|
return "$scheme://" . File::Spec::Unix->catdir( $host, $path );
|
|
}
|
|
|
|
=head2 $cb->_vcmp( VERSION, VERSION );
|
|
|
|
Normalizes the versions passed and does a '<=>' on them, returning the result.
|
|
|
|
=cut
|
|
|
|
sub _vcmp {
|
|
my $self = shift;
|
|
my ($x, $y) = @_;
|
|
|
|
$x = $self->_version_to_number(version => $x);
|
|
$y = $self->_version_to_number(version => $y);
|
|
|
|
return $x <=> $y;
|
|
}
|
|
|
|
=head2 $cb->_home_dir
|
|
|
|
Returns the user's homedir, or C<cwd> if it could not be found
|
|
|
|
=cut
|
|
|
|
sub _home_dir {
|
|
|
|
if ( can_load( modules => { 'File::HomeDir' => 0.0 } ) ) {
|
|
if ( defined $ENV{APPDATA} && length $ENV{APPDATA} && !ON_WIN32 ) {
|
|
msg("'APPDATA' env var is set and not on MSWin32, " .
|
|
"please use 'PERL5_CPANPLUS_HOME' instead to change .cpanplus location", 1 );
|
|
}
|
|
return File::HomeDir->my_home if -d File::HomeDir->my_home;
|
|
}
|
|
|
|
my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
|
|
|
|
for my $env ( @os_home_envs ) {
|
|
next unless exists $ENV{ $env };
|
|
next unless defined $ENV{ $env } && length $ENV{ $env };
|
|
return $ENV{ $env } if -d $ENV{ $env };
|
|
}
|
|
|
|
return cwd();
|
|
}
|
|
|
|
=head2 $path = $cb->_safe_path( path => $path );
|
|
|
|
Returns a path that's safe to us on Win32 and VMS.
|
|
|
|
Only cleans up the path on Win32 if the path exists.
|
|
|
|
On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify>
|
|
|
|
=cut
|
|
|
|
sub _safe_path {
|
|
my $self = shift;
|
|
|
|
my %hash = @_;
|
|
|
|
my $path;
|
|
my $tmpl = {
|
|
path => { required => 1, store => \$path },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
if( ON_WIN32 ) {
|
|
### only need to fix it up if there's spaces in the path
|
|
return $path unless $path =~ /\s+/;
|
|
|
|
### clean up paths if we are on win32
|
|
return Win32::GetShortPathName( $path ) || $path;
|
|
|
|
} elsif ( ON_VMS ) {
|
|
### XXX According to John Malmberg, there's an VMS issue:
|
|
### catdir on VMS can not currently deal with directory components
|
|
### with dots in them.
|
|
### Fixing this is a three step procedure, which will work for
|
|
### VMS in its traditional ODS-2 mode, and it will also work if
|
|
### VMS is in the ODS-5 mode that is being implemented.
|
|
### If the path is already in VMS syntax, assume that we are done.
|
|
|
|
### VMS format is a path with a trailing ']' or ':'
|
|
return $path if $path =~ /\:|\]$/;
|
|
|
|
### 1. Make sure that the value to be converted, $path is
|
|
### in UNIX directory syntax by appending a '/' to it.
|
|
$path .= '/' unless $path =~ m|/$|;
|
|
|
|
### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to
|
|
### underscores if needed. The trailing '/' is needed as so that
|
|
### C<vmsify> knows that it should use directory translation instead of
|
|
### filename translation, as filename translation leaves one dot.
|
|
$path = VMS::Filespec::vmsify( $path );
|
|
|
|
### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify(
|
|
### $path . '/') to remove the directory delimiters.
|
|
|
|
### From John Malmberg:
|
|
### File::Spec->catdir will put the path back together.
|
|
### The '/' trick only works if the string is a directory name
|
|
### with UNIX style directory delimiters or no directory delimiters.
|
|
### It is to force vmsify to treat the input specification as UNIX.
|
|
###
|
|
### There is a VMS::Filespec::unixpath() to do the appending of the '/'
|
|
### to the specification, which will do a VMS::Filespec::vmsify()
|
|
### if needed.
|
|
### However it is not a good idea to call vmsify() on a pathname
|
|
### returned by unixify(), and it is not a good idea to call unixify()
|
|
### on a pathname returned by vmsify(). Because of the nature of the
|
|
### conversion, not all file specifications can make the round trip.
|
|
###
|
|
### I think that directory specifications can safely make the round
|
|
### trip, but not ones containing filenames.
|
|
$path = File::Spec->catdir( File::Spec->splitdir( $path ) )
|
|
}
|
|
|
|
return $path;
|
|
}
|
|
|
|
|
|
=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
|
|
|
|
Splits the name of a CPAN package string up into its package, version
|
|
and extension parts.
|
|
|
|
For example, C<Foo-Bar-1.2.tar.gz> would return the following parts:
|
|
|
|
Package: Foo-Bar
|
|
Version: 1.2
|
|
Extension: tar.gz
|
|
|
|
=cut
|
|
|
|
sub _distname_info {
|
|
my $file = shift or return;
|
|
|
|
my ($dist, $version) = $file =~ /^
|
|
((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
|
|
(?:
|
|
[A-Za-z](?=[^A-Za-z]|$)
|
|
|
|
|
\d(?=-)
|
|
)(?<![._-][vV])
|
|
)+)(.*)
|
|
$/xs or return ($file,undef,undef);
|
|
|
|
if ($dist =~ /-undef\z/ and ! length $version) {
|
|
$dist =~ s/-undef\z//;
|
|
}
|
|
|
|
# Remove potential -withoutworldwriteables suffix
|
|
$version =~ s/-withoutworldwriteables$//;
|
|
|
|
if ($version =~ /^(-[Vv].*)-(\d.*)/) {
|
|
|
|
# Catch names like Unicode-Collate-Standard-V3_1_1-0.1
|
|
# where the V3_1_1 is part of the distname
|
|
$dist .= $1;
|
|
$version = $2;
|
|
}
|
|
|
|
if ($version =~ /(.+_.*)-(\d.*)/) {
|
|
# Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
|
|
# part of the distname. However, names like libao-perl_0.03-1.tar.gz
|
|
# should still have 0.03-1 as their version.
|
|
$dist .= $1;
|
|
$version = $2;
|
|
}
|
|
|
|
# Normalize the Dist.pm-1.23 convention which CGI.pm and
|
|
# a few others use.
|
|
$dist =~ s{\.pm$}{};
|
|
|
|
$version = $1
|
|
if !length $version and $dist =~ s/-(\d+\w)$//;
|
|
|
|
$version = $1 . $version
|
|
if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
|
|
|
|
if ($version =~ /\d\.\d/) {
|
|
$version =~ s/^[-_.]+//;
|
|
}
|
|
else {
|
|
$version =~ s/^[-_]+//;
|
|
}
|
|
|
|
my $dev;
|
|
if (length $version) {
|
|
if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
|
|
$dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
|
|
}
|
|
elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
|
|
$dev = 1;
|
|
}
|
|
}
|
|
else {
|
|
$version = undef;
|
|
}
|
|
|
|
($dist, $version, $dev);
|
|
}
|
|
|
|
{ my $del_re = qr/[-_\+]/i; # delimiter between elements
|
|
my $pkg_re = qr/[a-z] # any letters followed by
|
|
[a-z\d]* # any letters, numbers
|
|
(?i:\.pm)? # followed by '.pm'--authors do this :(
|
|
(?: # optionally repeating:
|
|
$del_re # followed by a delimiter
|
|
[a-z] # any letters followed by
|
|
[a-z\d]* # any letters, numbers
|
|
(?i:\.pm)? # followed by '.pm'--authors do this :(
|
|
)*
|
|
/xi;
|
|
|
|
my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters
|
|
(?: # however, some start with a . only :(
|
|
[-._] # followed by a delimiter
|
|
[a-z\d]+ # and more digits and or letters
|
|
)*?
|
|
/xi;
|
|
|
|
my $ext_re = qr/[a-z] # a letter, followed by
|
|
[a-z\d]* # letters and or digits, optionally
|
|
(?:
|
|
\. # followed by a dot and letters
|
|
[a-z\d]+ # and or digits (like .tar.bz2)
|
|
)? # optionally
|
|
/xi;
|
|
|
|
my $ver_ext_re = qr/
|
|
($ver_re+) # version, optional
|
|
(?:
|
|
\. # a literal .
|
|
($ext_re) # extension,
|
|
)? # optional, but requires version
|
|
/xi;
|
|
|
|
### composed regex for CPAN packages
|
|
my $full_re = qr/
|
|
^
|
|
( # the whole thing
|
|
($pkg_re+) # package
|
|
(?:
|
|
$del_re # delimiter
|
|
$ver_ext_re # version + extension
|
|
)?
|
|
)
|
|
$
|
|
/xi;
|
|
|
|
### composed regex for perl packages
|
|
my $perl = PERL_CORE;
|
|
my $perl_re = qr/
|
|
^
|
|
( # the whole thing
|
|
($perl) # package name for 'perl'
|
|
(?:
|
|
$ver_ext_re # version + extension
|
|
)?
|
|
)
|
|
$
|
|
/xi;
|
|
|
|
|
|
sub _split_package_string {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $str;
|
|
my $tmpl = { package => { required => 1, store => \$str } };
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
my ($dpkg,$dver);
|
|
{
|
|
my ($base,$ext);
|
|
if ( $str =~ m,([^/]+)\.(tar\.(?:[gx]?z|bz2)|zip|tbz|tgz|txz)$,i ) {
|
|
$base = $1;
|
|
$ext = $2;
|
|
}
|
|
else {
|
|
$base = $str;
|
|
}
|
|
($dpkg,$dver) = _distname_info($base);
|
|
}
|
|
|
|
### 2 different regexes, one for the 'perl' package,
|
|
### one for ordinary CPAN packages.. try them both,
|
|
### first match wins.
|
|
for my $re ( $full_re, $perl_re ) {
|
|
|
|
### try the next if the match fails
|
|
$str =~ $re or next;
|
|
|
|
my $full = $1 || '';
|
|
my $pkg = $2 || '';
|
|
my $ver = $3 || '';
|
|
my $ext = $4 || '';
|
|
|
|
### this regex resets the capture markers!
|
|
### strip the trailing delimiter
|
|
$pkg =~ s/$del_re$//;
|
|
|
|
### strip the .pm package suffix some authors insist on adding
|
|
$pkg =~ s/\.pm$//i;
|
|
|
|
$pkg = $dpkg if $dpkg && $pkg ne $dpkg;
|
|
$ver = $dver if $dver && $ver ne $dver;
|
|
|
|
return ($pkg, $ver, $ext, $full );
|
|
}
|
|
|
|
return;
|
|
}
|
|
}
|
|
|
|
{ my %escapes = map {
|
|
chr($_) => sprintf("%%%02X", $_)
|
|
} 0 .. 255;
|
|
|
|
sub _uri_encode {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $str;
|
|
my $tmpl = {
|
|
uri => { store => \$str, required => 1 }
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
### XXX taken straight from URI::Encode
|
|
### Default unsafe characters. RFC 2732 ^(uric - reserved)
|
|
$str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g;
|
|
|
|
return $str;
|
|
}
|
|
|
|
|
|
sub _uri_decode {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $str;
|
|
my $tmpl = {
|
|
uri => { store => \$str, required => 1 }
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
### XXX use unencode routine in utils?
|
|
$str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
|
|
|
|
return $str;
|
|
}
|
|
}
|
|
|
|
sub _update_timestamp {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $file;
|
|
my $tmpl = {
|
|
file => { required => 1, store => \$file, allow => FILE_EXISTS }
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
### `touch` the file, so windoze knows it's new -jmb
|
|
### works on *nix too, good fix -Kane
|
|
### make sure it is writable first, otherwise the `touch` will fail
|
|
|
|
my $now = time;
|
|
unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
|
|
error( loc("Couldn't touch %1", $file) );
|
|
return;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
1;
|
|
|
|
# Local variables:
|
|
# c-indentation-style: bsd
|
|
# c-basic-offset: 4
|
|
# indent-tabs-mode: nil
|
|
# End:
|
|
# vim: expandtab shiftwidth=4:
|