[ Avaa Bypassed ]




Upload:

Command:

hmhc3928@18.118.26.128: ~ $
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.9138";

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 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

{   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;


        ### 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;

            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:

Filemanager

Name Type Size Permission Actions
Constants Folder 0755
Source Folder 0755
Utils Folder 0755
Constants.pm File 16.45 KB 0644
Extract.pm File 7.45 KB 0644
Fetch.pm File 15.72 KB 0644
Report.pm File 22.17 KB 0644
Search.pm File 11.85 KB 0644
Source.pm File 41.42 KB 0644
Utils.pm File 16.84 KB 0644