—
—
—
—
—
—
—
—
—
—

              
package Padre::Util;
HideShow 21 lines of Pod
=pod
=head1 NAME
Padre::Util - Padre non-Wx Utility Functions
=head1 DESCRIPTION
The C<Padre::Util> package is a internal storage area for miscellaneous
functions that aren't really Padre-specific that we want to throw
somewhere convenient so they won't clog up task-specific packages.
All functions are exportable and documented for maintenance purposes,
but except for in the L<Padre> core distribution you are discouraged in the
strongest possible terms from using these functions, as they may be
moved, removed or changed at any time without notice.
=head1 FUNCTIONS
=cut
use 5.010;
use strict;
use warnings;
use Carp            ();
use Exporter        ();
use Cwd             ();
use File::Spec      ();
use List::Util      ();
use Padre::Constant (); ### NO other Padre:: dependencies
### Seriously guys, I fscking mean it.
# If we make $VERSION an 'our' variable the parse_variable() function breaks
use vars qw{ $VERSION $COMPATIBLE };
BEGIN {
        $VERSION    = '1.02';
        $COMPATIBLE = '0.97';
}
our @ISA       = 'Exporter';
our @EXPORT_OK = '_T';
our $DISTRO    = undef;
#####################################################################
# Officially Supported Constants
# Convenience constants for the operating system
# NOTE: They're now in Padre::Constant, if you miss them, please use them from there
#use constant WIN32 => !!( $^O eq 'MSWin32' );
#use constant MAC   => !!( $^O eq 'darwin' );
#use constant UNIX => !( WIN32 or MAC );
# The local newline type
# NOTE: It's now in Padre::Constant, if you miss them, please use it from there
#use constant NEWLINE => Padre::Constant::WIN32 ? 'WIN' : Padre::Constant::MAC ? 'MAC' : 'UNIX';
# Pulled back from Padre::Constant as it wasn't a constant in the first place
sub DISTRO {
        return $DISTRO if defined $DISTRO;
        if (Padre::Constant::WIN32) {
                # Inherit from the main Windows classification
                require Win32;
                $DISTRO = uc Win32::GetOSName();
        } elsif (Padre::Constant::MAC) {
                $DISTRO = 'MAC';
        } else {
                # Try to identify a more specific linux distribution
                local $@;
                eval {
                        if ( open my $lsb_file, '<', '/etc/lsb-release' )
                        {
                                while (<$lsb_file>) {
                                        next unless /^DISTRIB_ID\=(.+?)[\r\n]/;
                                        if ( $1 eq 'Ubuntu' ) {
                                                $DISTRO = 'UBUNTU';
                                        }
                                        last;
                                }
                        }
                };
        }
        $DISTRO ||= 'UNKNOWN';
        return $DISTRO;
}
#####################################################################
# Idioms and Miscellaneous Functions
HideShow 29 lines of Pod
=pod
=head2 C<slurp>
    my $content = Padre::Util::slurp( $file );
    if ( $content ) {
        print $$content;
    } else {
        # Handle errors appropriately
    }
This is a simple slurp implementation, provided as a convenience for
internal Padre use when loading trivial unimportant files for which
we don't need anything more robust.
All file reading is done with C<binmode> enabled, and data is returned by
reference to avoid needless copying.
Returns the content of the file as a SCALAR reference if the file exists
and can be read.
Returns false if loading of the file failed.
This function is only expected to be used in situations where the file
should almost always exist, and thus the reason why reading the file
failed isn't really important.
=cut
sub slurp {
        my $file = shift;
        open my $fh, '<', $file or return '';
        binmode $fh;
        local $/ = undef;
        my $content = <$fh>;
        close $fh;
        return \$content;
}
HideShow 15 lines of Pod
=pod
=head2 C<newline_type>
    my $type = Padre::Util::newline_type( $string );
Returns C<None> if there was not C<CR> or C<LF> in the file.
Returns C<UNIX>, C<Mac> or C<Windows> if only the appropriate newlines
were found.
Returns C<Mixed> if line endings are mixed.
=cut
sub newline_type {
        my $text = shift;
        my $CR   = "\015";
        my $LF   = "\012";
        my $CRLF = "\015\012";
        return "None" if not defined $text;
        return "None" if $text !~ /$LF/ and $text !~ /$CR/;
        return "UNIX" if $text !~ /$CR/;
        return "MAC"  if $text !~ /$LF/;
        $text =~ s/$CRLF//g;
        return "WIN" if $text !~ /$LF/ and $text !~ /$CR/;
        return "Mixed";
}
HideShow 25 lines of Pod
=pod
=head2 C<module_available>
    my $module = Padre::Util::module_available('Module::Name');
     
    if ($module) {
        print "$module->{name} $module->{VERSION} installed\n";
        if ($module->{COMPATIBLE}) {
            print "Back-compatible with $module->{name} $module->{COMPATIBLE}\n";
        }
    }
Determines whether a module is available at run-time via C<require> and finds the
version information (including back-compatibility information) for the module.
Provides information on the loaded version of a module if already loaded, or parses
the information out of the equivalent unloaded module on disk.
If the module is loaded or installed, returns a C<HASH> reference with three elements
as described above (the VERSION and COMPATIBLE values can be C<undef> if the module
does not define them). If the module is not loaded or installed, returns C<undef>.
=cut
sub module_available {
        my $module = shift;
        # We take two different approaches to the capture of the
        # version and compatibility values depending on whether
        # the module has been loaded or not.
        my $version;
        my $compatible;
        require Class::Inspector;
        if ( Class::Inspector->loaded($module) ) {
                no strict 'refs';
                $version    = ${"${module}::VERSION"}    || 0;
                $compatible = ${"${module}::COMPATIBLE"} || 0;
        } else {
                # Find the unloaded file
                my $file = Class::Inspector->resolved_filename($module);
                unless ( defined $file and length $file ) {
                        return undef;
                }
                # Scan the unloaded file ala EU:MakeMaker
                $version    = Padre::Util::parse_variable( $file, 'VERSION' );
                $compatible = Padre::Util::parse_variable( $file, 'COMPATIBLE' );
        }
        # Clean and return
        return {
                name       => $module,
                VERSION    => $version    ne 'undef' ? $version    : 0,
                COMPATIBLE => $compatible ne 'undef' ? $compatible : 0,
        };
}
HideShow 22 lines of Pod
=pod
=head2 C<parse_variable>
    my $version = Padre::Util::parse_variable($file, 'VERSION');
Parse a C<$file> and return what C<$VERSION> (or some other variable) is set to
by the first assignment.
It will return the string C<"undef"> if it can't figure out what C<$VERSION>
is. C<$VERSION> should be for all to see, so C<our $VERSION> or plain
C<$VERSION> are okay, but C<my $VERSION> is not.
C<parse_variable()> will try to C<use version> before checking for
C<$VERSION> so the following will work.
    $VERSION = qv(1.2.3);
Originally based on C<parse_version> from L<ExtUtils::MakeMaker>.
=cut
sub parse_variable {
        my $parsefile = shift;
        my $variable = shift || 'VERSION';
        my $result;
        local $/ = "\n";
        local $_;
        open( my $fh, '<', $parsefile ) #-# no critic (RequireBriefOpen)
                or die "Could not open '$parsefile': $!";
        my $inpod = 0;
        while (<$fh>) {
                $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
                next if $inpod || /^\s*#/;
                chop;
                next if /^\s*(if|unless)/;
                if ( $variable eq 'VERSION' and m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* ;  }x ) {
                        local $^W = 0;
                        $result = $1;
                } elsif (m{(?<!\\) ([\$*]) (([\w\:\']*) \b$variable)\b .* =}x) {
                        my $eval = qq{
                                package # Hide from PAUSE
                                        ExtUtils::MakeMaker::_version;
                                no strict;
                                BEGIN { eval {
                                        # Ensure any version() routine which might have leaked
                                        # into this package has been deleted.  Interferes with
                                        # version->import
                                        undef *version;
                                        require version;
                                        "version"->import;
                                } }
                                local $1$2;
                                \$$2=undef;
                                do {
                                        $_
                                };
                                \$$2;
                        };
                        local $^W = 0;
                        # what policy needs to be disabled here????
                        $result = eval($eval);
                        warn "Could not eval '$eval' in $parsefile: $@" if $@;
                } else {
                        next;
                }
                last if defined $result;
        }
        close $fh;
        $result = "undef" unless defined $result;
        return $result;
}
HideShow 15 lines of Pod
=pod
=head2 C<_T>
The C<_T> function is used for strings that you do not want to translate
immediately, but you will be translating later (multiple times).
The only reason this function needs to exist at all is so that the
translation tools can identify the string it refers to as something that
needs to be translated.
Functionally, this function is just a direct pass-through with no effect.
=cut
# Pasting more background information for people that don't understand
# the POD docs, because at least one person has accidentally broken this
# by changing it (not cxreg, he actually asked first) :)
#15:31 cxreg Alias: er, how it's just "shift" ?
#15:31 Alias cxreg: Wx has a gettext implementation
#15:31 Alias Wx::gettext
#15:31 Alias That's the "translate right now" function
#15:31 Alias But we need a late-binding version, for things that need to be translated, but are kept in memory (for various reasons) as English and only get translated at the last second
#15:32 Alias So in that case, we do a Wx::gettext($string)
#15:32 Alias The problem is that the translation tools can't tell what $string is
#15:32 Alias The translation tools DO, however, recognise _T as a translatable string
#15:33 Alias So we use _T as a silent pass-through specifically to indicate to the translation tools that this string needs translating
#15:34 Alias If we did everything as an up-front translation we'd need to flush a crapton of stuff and re-initialise it every time someone changed languages
#15:35 Alias Instead, we flush the hidden dialogs and rebuild the entire menu
#15:35 Alias But most of the rest we do with the delayed _T strings
#15:37 cxreg i get the concept, it's just so magical
#15:38 Alias It works brilliantly :)
#15:38 cxreg do you replace the _T symbol at runtime?
#15:39 Alias symbol?
#15:39 Alias Why would we do that?
#15:40 cxreg in order to actually instrument the translation, i wasn't sure if you were swapping out the sub behind the _T symbol
#15:40 Alias oh, no
#15:40 Alias _T is ONLY there to hint to the translation tools
#15:40 Alias The PO editors etc
#15:40 Alias my $english = _T('Hello World!'); $gui->set_title( Wx::gettext($english) );
#15:41 Alias It does absolutely nothing inside the code itself
sub _T {
        shift;
}
#####################################################################
# Shared Resources
HideShow 8 lines of Pod
=head2 C<share>
If called without a parameter returns the share directory of Padre.
If called with a parameter (e.g. C<Perl6>) returns the share directory
of L<Padre::Plugin::Perl6>. Uses File::ShareDir inside.
=cut
sub share {
        my $plugin = shift;
        if ( $ENV{PADRE_DEV} ) {
                require FindBin;
                no warnings;
                my $bin = $FindBin::Bin;
                use warnings;
                my $root = File::Spec->rel2abs(
                        File::Spec->catdir(
                                $bin,
                                File::Spec->updir,
                                File::Spec->updir
                        )
                );
                use warnings;
                unless ($plugin) {
                        return File::Spec->catdir( $root, 'Padre', 'share' );
                }
                # two cases: share in the Padre-Plugin-Name/share
                # or share in the Padre-Plugin-Name/lib/Padre/Plugin/Name/share directory
                my $plugin_dir = File::Spec->catdir( $root, "Padre-Plugin-$plugin", 'share' );
                if ( -d $plugin_dir ) {
                        return $plugin_dir;
                }
                $plugin_dir = File::Spec->catdir( $root, "Padre-Plugin-$plugin", 'lib', 'Padre', 'Plugin', $plugin, 'share' );
                return $plugin_dir;
        }
        # Rely on automatic handling of everything
        require File::ShareDir;
        if ($plugin) {
                return File::Spec->rel2abs( File::ShareDir::dist_dir("Padre-Plugin-$plugin") );
        } else {
                return File::Spec->rel2abs( File::ShareDir::dist_dir('Padre') );
        }
}
sub sharedir {
        File::Spec->catdir( share(), @_ );
}
sub sharefile {
        File::Spec->catfile( share(), @_ );
}
sub splash {
        my $original = Padre::Util::sharefile('padre-splash-ccnc.png');
        return -f $original ? $original : Padre::Util::sharefile('padre-splash.png');
}
######################################################################
# Logging and Debugging
# Returns the memory currently used by this application:
sub process_memory {
        if (Padre::Constant::UNIX) {
                open my $meminfo, '<', '/proc/self/stat' or return;
                my $rv = ( split( / /, <$meminfo> ) )[22];
                close $meminfo;
                return $rv;
        } elsif (Padre::Constant::WIN32) {
                require Padre::Util::Win32;
                return Padre::Util::Win32::GetCurrentProcessMemorySize();
        }
        return;
}
HideShow 15 lines of Pod
=pod
=head2 C<run_in_directory>
    Padre::Util::run_in_directory( $command, $directory );
Runs the provided C<command> in the C<directory>. On win32 platforms, executes
the command to provide *true* background process executions without window
popups on each execution. on non-win32 platforms, it runs a C<system>
command.
Returns 1 on success and 0 on failure.
=cut
sub run_in_directory {
        my ( $cmd, $directory ) = @_;
        # Make sure we execute from the correct directory
        if (Padre::Constant::WIN32) {
                require Padre::Util::Win32;
                my $retval = Padre::Util::Win32::ExecuteProcessAndWait(
                        directory  => $directory,
                        file       => 'cmd.exe',
                        parameters => "/C $cmd",
                );
                return $retval ? 1 : 0;
        } else {
                require File::pushd;
                my $pushd  = File::pushd::pushd($directory);
                my $retval = system $cmd;
                return ( $retval == 0 ) ? 1 : 0;
        }
}
HideShow 48 lines of Pod
=pod
=head2 C<run_in_directory_two>
Plugin replacment for perl command qx{...} to avoid black lines in non *inux os
        qx{...};
        run_in_directory_two( cmd => '...');
optional parameters are dir and return type
        run_in_directory_two(cmd => '...', dir => $dir);
        run_in_directory_two(cmd => '...', dir => $dir, option => type);
also
        run_in_directory_two(cmd => '...', option => type);
return type 1 default, returns a string
return type 2 error only for testing
nb you might need to chomp result but thats for you.
return type 0 hash_ref
=over
=item example 1,
        Padre::Util::run_in_directory_two(cmd => 'svn --version --quiet');
        "1.6.12
        "
=item example 2,
        Padre::Util::run_in_directory_two(cmd => 'svn --version --quiet', option => '0');
        \ {
                error    "",
                input    "svn --version --quiet",
                output   "1.6.12
        "
        }
=back
=cut
#######
# function Padre::Util::run_in_directory_two
#######
sub run_in_directory_two {
        my %args = @_;
        #create return hash ioe (input output error)
        my %ret_ioe;
        $ret_ioe{input} = $args{cmd};
        $args{cmd} =~ m/((?:\w+)\s)/;
        my $cmd_app = $1;
        if ( defined $args{option} ) {
                $args{option} = ( $args{option} =~ m/[0|1|2]/ ) ? $args{option} : '1';
        } else {
                $args{option} = 1;
        }
        # Create a temporary file for standard output redirection
        require File::Temp;
        my $std_out = File::Temp->new( UNLINK => 1 );
        # Create a temporary file for standard error redirection
        my $std_err = File::Temp->new( UNLINK => 1 );
        my $temp_dir = File::Temp->newdir();
        my $directory = $args{dir} // $temp_dir;
        my @cmd = (
                $args{cmd},
                '1>' . $std_out->filename,
                '2>' . $std_err->filename,
        );
        # We need shell redirection (list context does not give that)
        # Run command in directory
        Padre::Util::run_in_directory( "@cmd", $directory );
        # Slurp command standard input and output
        $ret_ioe{output} = ${ slurp( $std_out->filename ) };
        chomp $ret_ioe{output};
        # Slurp command standard error
        $ret_ioe{error} = ${ slurp( $std_err->filename ) };
        chomp $ret_ioe{error};
        $ret_ioe{error} = $ret_ioe{error} ne "" ? $ret_ioe{error} : undef;
        if ( $ret_ioe{error} && ( $args{option} eq '1' ) ) {
                $args{option} = '2';
        }
        return $ret_ioe{output} if ( $args{option} eq '1' );
        return $ret_ioe{error}  if ( $args{option} eq '2' );
        return \%ret_ioe;
}
1;
__END__
HideShow 14 lines of Pod
=pod
=head1 COPYRIGHT
Copyright 2008-2016 The Padre development team as listed in Padre.pm.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut
# Copyright 2008-2016 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.