view release on metacpan or search on metacpan
lib/App/SimpleBackuper/DB/FilesTable.pm view on Meta::CPAN
$find_by_parent_id_name_cache_parent_id = $parent_id;
}
return $find_by_parent_id_name_cache{ $name };
}
sub delete {
my $self = shift;
%find_by_parent_id_name_cache = ();
$find_by_parent_id_name_cache_parent_id = 0;
return $self->SUPER::delete(@_);
}
1;
local/lib/perl5/Module/Build/API.pod view on Meta::CPAN
This method returns a hash reference of metadata that can be used to create a
YAML datastream. It is provided for authors to override or customize the fields
of F<META.yml>. E.g.
package My::Builder;
use base 'Module::Build';
sub get_metadata {
my $self, @args = @_;
my $data = $self->SUPER::get_metadata(@args);
$data->{custom_field} = 'foo';
return $data;
}
Valid arguments include:
=over
=item *
local/lib/perl5/Module/Build/Cookbook.pm view on Meta::CPAN
# Build.PL
use Module::Build;
my $class = Module::Build->subclass(
class => "Module::Build::Custom",
code => <<'SUBCLASS' );
sub ACTION_install {
my $self = shift;
# YOUR CODE HERE
$self->SUPER::ACTION_install;
}
SUBCLASS
$class->new(
module_name => 'Your::Module',
# rest of the usual Module::Build parameters
)->create_build_script;
=head2 Adding an action
local/lib/perl5/Module/Build/Platform/MacOS.pm view on Meta::CPAN
$VERSION = eval $VERSION;
use Module::Build::Base;
our @ISA = qw(Module::Build::Base);
use ExtUtils::Install;
sub have_forkpipe { 0 }
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
# $Config{sitelib} and $Config{sitearch} are, unfortunately, missing.
foreach ('sitelib', 'sitearch') {
$self->config($_ => $self->config("install$_"))
unless $self->config($_);
}
# For some reason $Config{startperl} is filled with a bunch of crap.
(my $sp = $self->config('startperl')) =~ s/.*Exit \{Status\}\s//;
$self->config(startperl => $sp);
local/lib/perl5/Module/Build/Platform/MacOS.pm view on Meta::CPAN
my $cmd = MacPerl::Pick("What build command? ('*' requires ToolServer)", @action_list);
return unless defined $cmd;
$cmd =~ s/ \*$//;
$ARGV[0] = ($cmd);
my $args = MacPerl::Ask('Any extra arguments? (ie. verbose=1)', '');
return unless defined $args;
push @ARGV, $self->split_like_shell($args);
}
$self->SUPER::dispatch(@_);
}
sub ACTION_realclean {
my $self = shift;
chmod 0666, $self->{properties}{build_script};
$self->SUPER::ACTION_realclean;
}
# ExtUtils::Install has a hard-coded '.' directory in versions less
# than 1.30. We use a sneaky trick to turn that into ':'.
#
# Note that we do it here in a cross-platform way, so this code could
# actually go in Module::Build::Base. But we put it here to be less
# intrusive for other platforms.
sub ACTION_install {
my $self = shift;
return $self->SUPER::ACTION_install(@_)
if eval {ExtUtils::Install->VERSION('1.30'); 1};
local $^W = 0; # Avoid a 'redefine' warning
local *ExtUtils::Install::find = sub {
my ($code, @dirs) = @_;
@dirs = map { $_ eq '.' ? File::Spec->curdir : $_ } @dirs;
return File::Find::find($code, @dirs);
};
return $self->SUPER::ACTION_install(@_);
}
1;
__END__
=head1 NAME
Module::Build::Platform::MacOS - Builder class for MacOS platforms
=head1 DESCRIPTION
local/lib/perl5/Module/Build/Platform/Unix.pm view on Meta::CPAN
# question "can I execute this file", but I think we want "is this
# file executable".
my ($self, $file) = @_;
return +(stat $file)[2] & 0100;
}
sub _startperl { "#! " . shift()->perl }
sub _construct {
my $self = shift()->SUPER::_construct(@_);
# perl 5.8.1-RC[1-3] had some broken %Config entries, and
# unfortunately Red Hat 9 shipped it like that. Fix 'em up here.
my $c = $self->{config};
for (qw(siteman1 siteman3 vendorman1 vendorman3)) {
$c->{"install${_}dir"} ||= $c->{"install${_}"};
}
return $self;
}
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
=over 4
=item _set_defaults
Change $self->{build_script} to 'Build.com' so @Build works.
=cut
sub _set_defaults {
my $self = shift;
$self->SUPER::_set_defaults(@_);
$self->{properties}{build_script} = 'Build.com';
}
=item cull_args
'@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
people to write '@Build "foo"' we'll dispatch case-insensitively.
=cut
sub cull_args {
my $self = shift;
my($action, $args) = $self->SUPER::cull_args(@_);
my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
die "Ambiguous action '$action'. Could be one of @possible_actions"
if @possible_actions > 1;
return ($possible_actions[0], $args);
}
=item manpage_separator
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
my ($self, $command) = @_;
# a lot of VMS executables have a symbol defined
# check those first
if ( $^O eq 'VMS' ) {
require VMS::DCLsym;
my $syms = VMS::DCLsym->new;
return $command if scalar $syms->getsym( uc $command );
}
$self->SUPER::find_command($command);
}
# _maybe_command copied from ExtUtils::MM_VMS::maybe_command
=item _maybe_command (override)
Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
to check for DCL procedure. If this fails, checks directories in DCL$PATH
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
}
=item oneliner
Override to ensure that we do not quote the command.
=cut
sub oneliner {
my $self = shift;
my $oneliner = $self->SUPER::oneliner(@_);
$oneliner =~ s/^\"\S+\"//;
return "MCR $^X $oneliner";
}
=item rscan_dir
Inherit the standard version but remove dots at end of name.
If the extended character set is in effect, do not remove dots from filenames
with Unix path delimiters.
=cut
sub rscan_dir {
my ($self, $dir, $pattern) = @_;
my $result = $self->SUPER::rscan_dir( $dir, $pattern );
for my $file (@$result) {
if (!_efs() && ($file =~ m#/#)) {
$file =~ s/\.$//;
}
}
return $result;
}
=item dist_dir
Inherit the standard version but replace embedded dots with underscores because
a dot is the directory delimiter on VMS.
=cut
sub dist_dir {
my $self = shift;
my $dist_dir = $self->SUPER::dist_dir;
$dist_dir =~ s/\./_/g unless _efs();
return $dist_dir;
}
=item man3page_name
Inherit the standard version but chop the extra manpage delimiter off the front if
there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
=cut
sub man3page_name {
my $self = shift;
my $mpname = $self->SUPER::man3page_name( shift );
my $sep = $self->manpage_separator;
$mpname =~ s/^$sep//;
return $mpname;
}
=item expand_test_dir
Inherit the standard version but relativize the paths as the native glob() doesn't
do that for us.
=cut
sub expand_test_dir {
my ($self, $dir) = @_;
my @reldirs = $self->SUPER::expand_test_dir( $dir );
for my $eachdir (@reldirs) {
my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
$eachdir = File::Spec->catfile( $reldir, $f );
}
return @reldirs;
}
=item _detildefy
local/lib/perl5/Module/Build/Platform/Windows.pm view on Meta::CPAN
sub _detildefy {
my ($self, $value) = @_;
$value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
if $ENV{HOME};
return $value;
}
sub ACTION_realclean {
my ($self) = @_;
$self->SUPER::ACTION_realclean();
my $basename = basename($0);
$basename =~ s/(?:\.bat)?$//i;
if ( lc $basename eq lc $self->build_script ) {
if ( $self->build_bat ) {
$self->log_verbose("Deleting $basename.bat\n");
my $full_progname = $0;
$full_progname =~ s/(?:\.bat)?$/.bat/i;
local/lib/perl5/Module/Build/Platform/Windows.pm view on Meta::CPAN
close $fh ;
} else {
$self->delete_filetree($self->build_script . '.bat');
}
}
}
sub make_executable {
my $self = shift;
$self->SUPER::make_executable(@_);
foreach my $script (@_) {
# Native batch script
if ( $script =~ /\.(bat|cmd)$/ ) {
$self->SUPER::make_executable($script);
next;
# Perl script that needs to be wrapped in a batch script
} else {
my %opts = ();
if ( $script eq $self->build_script ) {
$opts{ntargs} = q(-x -S %0 --build_bat %*);
$opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
}
my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
if ( $@ ) {
$self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
} else {
$self->SUPER::make_executable($out);
}
}
}
}
sub pl2bat {
my $self = shift;
my %opts = @_;
require ExtUtils::PL2Bat;
return ExtUtils::PL2Bat::pl2bat(%opts);
local/lib/perl5/Module/Build/Platform/cygwin.pm view on Meta::CPAN
# from C<ExtUtils::MM_Unix>.
sub _maybe_command {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i) {
require Module::Build::Platform::Windows;
return Module::Build::Platform::Windows->_maybe_command($file);
}
return $self->SUPER::_maybe_command($file);
}
1;
__END__
=head1 NAME
Module::Build::Platform::cygwin - Builder class for Cygwin platform
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
package Net::SFTP::Foreign::FileHandle;
our @ISA = qw(Net::SFTP::Foreign::Handle IO::File);
sub _new_from_rid {
my $class = shift;
my $sftp = shift;
my $rid = shift;
my $flags = shift;
my $self = $class->SUPER::_new_from_rid($sftp, $rid, $flags, '', '');
}
sub _check_is_file {}
sub _bin { \(*{shift()}{ARRAY}[4]) }
sub _bout { \(*{shift()}{ARRAY}[5]) }
sub WRITE {
my ($self, undef, $length, $offset) = @_;
$self->_check
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
package Net::SFTP::Foreign::DirHandle;
our @ISA = qw(Net::SFTP::Foreign::Handle IO::Dir);
sub _new_from_rid {
my $class = shift;
my $sftp = shift;
my $rid = shift;
my $flags = shift;
my $self = $class->SUPER::_new_from_rid($sftp, $rid, $flags, []);
}
sub _check_is_dir {}
sub _cache { *{shift()}{ARRAY}[4] }
*CLOSEDIR = $gen_proxy_method->('closedir');
*READDIR = $gen_proxy_method->('_readdir');
local/lib/perl5/Net/SFTP/Foreign/Attributes/Compat.pm view on Meta::CPAN
my @fields = qw( flags size uid gid perm atime mtime );
for my $f (@fields) {
no strict 'refs';
*$f = sub { @_ > 1 ? $_[0]->{$f} = $_[1] : $_[0]->{$f} || 0 }
}
sub new {
my ($class, %param) = @_;
my $a = $class->SUPER::new();
if (my $stat = $param{Stat}) {
$a->set_size($stat->[7]);
$a->set_ugid($stat->[4], $stat->[5]);
$a->set_perm($stat->[2]);
$a->set_amtime($stat->[8], $stat->[9]);
}
$a;
}
local/lib/perl5/Net/SFTP/Foreign/Compat.pm view on Meta::CPAN
BEGIN {
my @forbidden = qw( setcwd cwd open opendir sftpread sftpwrite
seek tell eof write flush read getc lstat stat
fstat remove rmdir mkdir setstat fsetstat
close closedir readdir realpath readlink
rename symlink abort get_content join glob
rremove rget rput error die_on_error );
for my $method (@forbidden) {
my $super = "SUPER::$method";
no strict 'refs';
*{$method} = sub {
unless (index((caller)[0], "Net::SFTP::Foreign") == 0) {
croak "Method '$method' is not available from " . __PACKAGE__
. ", use the real Net::SFTP::Foreign if you want it!";
}
shift->$super(@_);
};
}
}
local/lib/perl5/Net/SFTP/Foreign/Compat.pm view on Meta::CPAN
my ($class, $host, %opts) = @_;
my $warn;
if (exists $opts{warn}) {
$warn = delete($opts{warn}) || sub {};
}
else {
$warn = sub { warn(CORE::join '', @_, "\n") };
}
my $sftp = $class->SUPER::new($host, @{$DEFAULTS{new}}, %opts);
$sftp->{_compat_warn} = $warn;
return $sftp;
}
sub _warn {
my $sftp = shift;
if (my $w = $sftp->{_compat_warn}) {
$w->(@_);
}
}
sub _warn_error {
my $sftp = shift;
if (my $e = $sftp->SUPER::error) {
$sftp->_warn($e);
}
}
sub status {
my $status = shift->SUPER::status;
return wantarray ? ($status + 0, "$status") : $status + 0;
}
sub get {
croak '$Usage: $sftp->get($local, $remote, $cb)' if @_ < 2 or @_ > 4;
my ($sftp, $remote, $local, $cb) = @_;
my $save = defined(wantarray);
my @content;
my @cb;
if (defined $cb or $save) {
@cb = ( callback => sub {
my ($sftp, $data, $off, $size) = @_;
$cb->($sftp, $data, $off, $size) if $cb;
push @content, $data if $save
});
}
$sftp->SUPER::get($remote, $local,
@{$DEFAULTS{get}},
dont_save => !defined($local),
@cb)
or return undef;
if ($save) {
return CORE::join('', @content);
}
}
sub put {
croak '$Usage: $sftp->put($local, $remote, $cb)' if @_ < 3 or @_ > 4;
my ($sftp, $local, $remote, $cb) = @_;
$sftp->SUPER::put($local, $remote,
@{$DEFAULTS{put}},
callback => $cb);
$sftp->_warn_error;
!$sftp->SUPER::error;
}
sub ls {
croak '$Usage: $sftp->ls($path, $cb)' if @_ < 2 or @_ > 3;
my ($sftp, $path, $cb) = @_;
if ($cb) {
$sftp->SUPER::ls($path,
@{$DEFAULTS{ls}},
wanted => sub { _rebless_attrs($_[1]->{a});
$cb->($_[1]);
0 } );
return ();
}
else {
if (my $ls = $sftp->SUPER::ls($path, @{$DEFAULTS{ls}})) {
_rebless_attrs($_->{a}) for @$ls;
return @$ls;
}
return ()
}
}
sub do_open { shift->SUPER::open(@_) }
sub do_opendir { shift->SUPER::opendir(@_) }
sub do_realpath { shift->SUPER::realpath(@_) }
sub do_read {
my $sftp = shift;
my $read = $sftp->SUPER::sftpread(@_);
$sftp->_warn_error;
if (wantarray) {
return ($read, $sftp->status);
}
else {
return $read
}
}
sub _gen_do_and_status {
my $method = "SUPER::" . shift;
return sub {
my $sftp = shift;
$sftp->$method(@_);
$sftp->_warn_error;
$sftp->status;
}
}
*do_write = _gen_do_and_status('sftpwrite');
*do_close = _gen_do_and_status('close');
local/lib/perl5/Net/SFTP/Foreign/Compat.pm view on Meta::CPAN
if ($a) {
bless $a, ( $supplant
? "Net::SFTP::Attributes"
: "Net::SFTP::Foreign::Attributes::Compat" );
}
$a;
}
sub _gen_do_stat {
my $name = shift;
my $method = "SUPER::$name";
return sub {
croak '$Usage: $sftp->'.$name.'($local, $remote, $cb)' if @_ != 2;
my $sftp = shift;
if (my $a = $sftp->$method(@_)) {
return _rebless_attrs($a);
}
else {
$sftp->_warn_error;
return undef;
}
local/lib/perl5/Test/Deep/ArrayEach.pm view on Meta::CPAN
my $exp = [ ($self->{val}) x @$got ];
return Test::Deep::descend($got, $exp);
}
sub renderExp
{
my $self = shift;
my $exp = shift;
return '[ ' . $self->SUPER::renderExp($self->{val}) . ', ... ]';
}
1;
__END__
=pod
=encoding UTF-8
local/lib/perl5/Test/Deep/Blessed.pm view on Meta::CPAN
return "blessed($var)"
}
sub renderGot
{
my $self = shift;
my $got = shift;
$self->SUPER::renderGot(blessed($got));
}
1;
__END__
=pod
=encoding UTF-8
local/lib/perl5/Test/Deep/Ignore.pm view on Meta::CPAN
use strict;
use warnings;
package Test::Deep::Ignore 1.204;
use Test::Deep::Cmp;
my $Singleton = __PACKAGE__->SUPER::new;
sub new
{
return $Singleton;
}
sub descend
{
return 1;
}
local/lib/perl5/Test/Deep/ListMethods.pm view on Meta::CPAN
use warnings;
package Test::Deep::ListMethods 1.204;
use base 'Test::Deep::Methods';
sub call_method
{
my $self = shift;
return [$self->SUPER::call_method(@_)];
}
sub render_stack
{
my $self = shift;
my $var = $self->SUPER::render_stack(@_);
return "[$var]";
}
1;
__END__
=pod
local/lib/perl5/Test/Deep/Number.pm view on Meta::CPAN
}
sub renderGot
{
my $self = shift;
my $val = shift;
my $got_string = $self->data->{got_string};
if ("$val" ne "$got_string")
{
$got_string = $self->SUPER::renderGot($got_string);
return "$val ($got_string)"
}
else
{
return $val;
}
}
sub renderExp
{
my $self = shift;
local/lib/perl5/Test/Deep/RefType.pm view on Meta::CPAN
return "reftype($var)";
}
sub renderGot
{
my $self = shift;
my $got = shift;
$self->SUPER::renderGot(reftype($got));
}
1;
__END__
=pod
=encoding UTF-8
local/lib/perl5/Test/Deep/RegexpMatches.pm view on Meta::CPAN
sub render_stack
{
my $self = shift;
my $stack = shift;
$stack = "[$stack =~ $self->{regex}]";
return $stack;
# return $self->SUPER::render_stack($stack);
}
sub reset_arrow
{
return 1;
}
1;
__END__
local/lib/perl5/Test/Deep/Stack.pm view on Meta::CPAN
use Carp qw( confess );
use Scalar::Util;
use Test::Deep::MM qw( new init Stack Arrow );
sub init
{
my $self = shift;
$self->SUPER::init(@_);
$self->setStack([]) unless $self->getStack;
}
sub push
{
my $self = shift;
push(@{$self->getStack}, @_);
}
local/lib/perl5/Test/Spec/Mocks.pm view on Meta::CPAN
{
package Test::Spec::Mocks::Stub;
use base qw(Test::Spec::Mocks::Expectation);
# A stub is a special case of expectation that doesn't actually
# expect anything.
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
$self->at_least(0);
return $self;
}
}
1;
=head1 NAME