Result:
found more than 265 distributions - search limited to the first 2001 files matching your query
( run in 0.934 )
API-ReviewBoard
view release on metacpan or search on metacpan
ReviewBoard.pm view on Meta::CPAN
username => 'user',
password => 'passwd' );
Creates a new API::ReviewBoard object.
=cut
sub new {
my $class = shift;
my %args = @_;
my $self;
%args = validate(
@_,
ReviewBoard.pm view on Meta::CPAN
=head2 $rb->getReviewBoardLink(changenum => '112345');
Gets the review board link for a ACTIVE change request number.
=cut
sub getReviewBoardLink {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
=head2 $rb->getReviewDescription(changenum => '112345');
The new review request description from ACTIVE change request.
=cut
sub getReviewDescription {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
=head2 $rb->getReviewDateAdded(changenum => '112345');
Gets the date on which ACTIVE change request was added.
=cut
sub getReviewDateAdded {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
=head2 $rb->getReviewLastUpdated(changenum => '112345');
Gets the date on which change request was last updated.
=cut
sub getReviewLastUpdated {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
Gets the name of the reviewers assigned for ACTIVE change request number.
The function returns an ARRAYREF to the user.
=cut
sub getReviewers {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
Gets the name of the submitter who submitted the ACTIVE change request.
=cut
sub getSubmitter {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
The review request's brief summary of ACTIVE change request.
=cut
sub getSummary {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
Get the list of bugs closed or referenced by the ACTIVE change request.
=cut
sub getBugIds {
my $self = shift;
my %args = validate(
@_,
{ changenum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
=head2 $rb->getReviewCommentsCount(reviewnum => '41080');
Gets the count of comments received for an ACTIVE change request.
=cut
sub getReviewCommentsCount {
my $self = shift;
my %args = validate(
@_,
{ reviewnum => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
=head2 $rb->getOutgoingReviewsCount(user => 'abdcde');
Gets the count of review requests made by a user.
=cut
sub getOutgoingReviewsCount {
my $self = shift;
my %args = validate(
@_,
{ user => { type => SCALAR, optional => 0 },
}
ReviewBoard.pm view on Meta::CPAN
Gets the count of review requests made by a user during time interval.
=cut
sub getOutgoingReviewsCountByDate {
my $self = shift;
my %args = validate(
@_,
{ user => { type => SCALAR, optional => 0 },
startdate => { type => SCALAR, optional => 0 },
ReviewBoard.pm view on Meta::CPAN
Gets the count of review requests made by a user with status in [all | pending |submitted | discarded].
=cut
sub getOutgoingReviewsCountByStatus {
my $self = shift;
my %args = validate(
@_,
{ user => { type => SCALAR, optional => 0 },
status => { type => SCALAR, optional => 0 },
ReviewBoard.pm view on Meta::CPAN
Gets the count of review requests made to a user.
=cut
sub getIncomingReviewsCount {
my $self = shift;
my %args = validate(
@_,
{ user => { type => SCALAR, optional => 0 },
}
API-Stripe
view release on metacpan or search on metacpan
requires "API::Client" => "0.03";
requires "Data::Object" => "0.57";
requires "Mojolicious" => "6.22";
requires "perl" => "v5.14.0";
on 'test' => sub {
requires "perl" => "v5.14.0";
};
on 'configure' => sub {
requires "ExtUtils::MakeMaker" => "0";
};
API-Trello
view release on metacpan or search on metacpan
requires "API::Client" => "0.03";
requires "Data::Object" => "0.57";
requires "Mojolicious" => "6.22";
requires "perl" => "v5.14.0";
on 'test' => sub {
requires "perl" => "v5.14.0";
};
on 'configure' => sub {
requires "ExtUtils::MakeMaker" => "0";
};
API-Twitter
view release on metacpan or search on metacpan
requires "Data::Object" => "0.57";
requires "Mojolicious" => "6.22";
requires "Net::OAuth" => "0.28";
requires "perl" => "v5.14.0";
on 'test' => sub {
requires "perl" => "v5.14.0";
};
on 'configure' => sub {
requires "ExtUtils::MakeMaker" => "0";
};
API-Vultr
view release on metacpan or search on metacpan
lib/API/Vultr.pm view on Meta::CPAN
use URI qw();
use LWP::UserAgent ();
our $VERSION = '0.003';
sub _make_uri {
my ( $self, $path, %query ) = @_;
my $uri = URI->new( 'https://api.vultr.com/v2' . $path );
if (%query) {
$uri->query_form(%query);
}
return $uri->as_string;
}
sub _request {
my ( $self, $method, $uri, $body ) = @_;
if ( not( defined $body ) ) {
my $lc_method = lc $method;
return $self->ua->$lc_method( $uri,
lib/API/Vultr.pm view on Meta::CPAN
$request->content($body);
return $self->ua->request($request);
}
}
sub api_key {
my ( $self, $setter ) = @_;
if ( defined $setter ) {
return $self->{api_key} = $setter;
}
return $self->{api_key};
}
sub ua {
my ( $self, $setter ) = @_;
if ( defined $setter ) {
return $self->{ua} = $setter;
}
return $self->{ua};
}
sub new {
my ( $class, %args ) = @_;
croak
qq{You must specify an API key when creating an instance of API::Vultr}
unless exists $args{api_key};
lib/API/Vultr.pm view on Meta::CPAN
return bless( $self, __PACKAGE__ );
}
# ACCOUNT #
sub get_account_info {
my $self = shift;
return $self->_request( 'get', $self->_make_uri('/account') );
}
# APPLICATIONS #
sub get_applications {
my $self = shift;
return $self->_request( 'get', $self->_make_uri('/applications') );
}
# BACKUPS #
sub get_backups {
my ( $self, %query ) = @_;
return $self->_request( 'get', $self->_make_uri( '/backups', %query ) );
}
sub get_backup_by_id {
my ( $self, $id ) = @_;
return $self->_request( 'get', $self->_make_uri( '/backups/' . $id ) );
}
# INSTANCES #
sub list_instances {
my ( $self, %query ) = @_;
return $self->_request( 'get', $self->_make_uri( '/instances', %query ) );
}
sub create_instance {
my ( $self, %body ) = @_;
return $self->_request( 'post', $self->_make_uri('/instances'), {%body} );
}
sub get_instance_by_id {
my ( $self, $id ) = @_;
croak qq{ID cannot be undefined when calling get_instance_by_id.}
unless defined $id;
return $self->_request( 'get', $self->_make_uri( '/instances/' . $id ) );
}
sub delete_instance_by_id {
my ( $self, $id ) = @_;
croak qq{ID cannot be undefined when calling get_instance_by_id.}
unless defined $id;
return $self->_request( 'delete', $self->_make_uri( '/instances/' . $id ) );
}
sub halt_instances {
my ( $self, @ids ) = @_;
croak qq{Expected list of ids, instead got undef.}
unless @ids;
lib/API/Vultr.pm view on Meta::CPAN
$self->_make_uri('/instances/halt'),
{ instance_ids => [@ids] }
);
}
sub reboot_instances {
my ( $self, @ids ) = @_;
croak qq{Expected list of ids, instead got undef.}
unless @ids;
lib/API/Vultr.pm view on Meta::CPAN
$self->_make_uri('/instances/reboot'),
{ instance_ids => [@ids] }
);
}
sub start_instances {
my ( $self, @ids ) = @_;
croak qq{Expected list of ids, instead got undef.}
unless @ids;
lib/API/Vultr.pm view on Meta::CPAN
$self->_make_uri('/instances/start'),
{ instance_ids => [@ids] }
);
}
sub get_instance_bandwidth {
my ( $self, $id, %query ) = @_;
croak qq{Expected scalar id as second argument, instead got $id.}
unless defined $id;
return $self->_request( 'get',
$self->_make_uri( '/instances/' . $id . '/bandwidth', %query ) );
}
sub get_instance_neighbours {
my ( $self, $id ) = @_;
croak qq{Expected scalar id as second argument, instead got $id.}
unless defined $id;
return $self->_request( 'get',
$self->_make_uri( '/instances/' . $id . '/neighbours' ) );
}
sub get_instance_iso_status {
my ( $self, $id ) = @_;
croak qq{Expected scalar id as second argument, instead got $id.}
unless defined $id;
return $self->_request( 'get',
$self->_make_uri( '/instances/' . $id . '/iso' ) );
}
sub detach_iso_from_instance {
my ( $self, $id ) = @_;
croak qq{Expected scalar id as second argument, instead got $id.}
unless defined $id;
return $self->_request( 'post',
$self->_make_uri( '/instances/' . $id . '/iso/detach' ) );
}
sub attach_iso_to_instance {
my ( $self, $id, $iso_id ) = @_;
croak qq{Expected scalar id as second argument, instead got $id.}
unless defined $id;
lib/API/Vultr.pm view on Meta::CPAN
);
}
# ISO #
sub get_isos {
my ( $self, %query ) = @_;
return $self->_request( $self->_make_uri( '/iso', %query ) );
}
sub create_iso {
my ( $self, %body ) = @_;
return $self->_request( $self->_make_uri('/iso'), {%body} );
}
1;
API-Wunderlist
view release on metacpan or search on metacpan
requires "API::Client" => "0.03";
requires "Data::Object" => "0.57";
requires "Mojolicious" => "6.22";
requires "perl" => "v5.14.0";
on 'test' => sub {
requires "perl" => "v5.14.0";
};
on 'configure' => sub {
requires "ExtUtils::MakeMaker" => "0";
};
APISchema
view release on metacpan or search on metacpan
lib/APISchema/DSL.pm view on Meta::CPAN
our @DIRECTIVES = (qw(include filter resource title description), keys %METHODS);
our @EXPORT = @DIRECTIVES;
my $_directive = {};
sub process (&) {
my $dsl = shift;
my $schema = APISchema::Schema->new;
local $_directive->{include} = sub {
my ($file) = @_;
-r $_[0] or Carp::croak(sprintf 'No such file: %s', $file);
my $content = file($file)->slurp;
my $with_utf8 = "use utf8;\n" . $content;
eval $with_utf8;
Carp::croak($@) if $@;
};
local $_directive->{title} = sub {
$schema->title(@_);
};
local $_directive->{description} = sub {
$schema->description(@_);
};
my @filters;
local $_directive->{filter} = sub {
push @filters, $_[0];
};
local $_directive->{resource} = sub {
$schema->register_resource(@_);
};
local @$_directive{keys %METHODS} = map {
my $m = $_;
sub {
my ($path, @args) = @_;
for my $filter (reverse @filters) {
local $Carp::CarpLevel += 1;
@args = $filter->(@args);
}
lib/APISchema/DSL.pm view on Meta::CPAN
$dsl->();
return $schema;
}
# dispatch directives to the definitions
sub include ($) { $_directive->{include}->(@_) }
sub title ($) { $_directive->{title}->(@_) }
sub description ($) { $_directive->{description}->(@_) }
sub filter (&) { $_directive->{filter}->(@_) }
sub resource ($@) { $_directive->{resource}->(@_) }
for my $method (keys %METHODS) {
no strict 'refs';
*$method = sub ($@) { goto \&{ $_directive->{$method} } };
}
# disable the global definitions
@$_directive{@DIRECTIVES} = (sub {
Carp::croak(sprintf(
q(%s should be called inside 'process {}' block),
join '/', @DIRECTIVES
));
}) x scalar @DIRECTIVES;
APNS-Agent
view release on metacpan or search on metacpan
lib/APNS/Agent.pm view on Meta::CPAN
private_key
sandbox
debug_port
/],
ro_lazy => {
on_error_response => sub {
sub {
my $self = shift;
my %d = %{$_[0]};
warnf "identifier:%s\tstate:%s\ttoken:%s", $d{identifier}, $d{state}, $d{token} || '';
}
},
disconnect_interval => sub { 60 },
send_interval => sub { 0.01 },
_sent_cache => sub { Cache::LRU->new(size => 10000) },
_queue => sub { [] },
__apns => '_build_apns',
_sent => sub { 0 },
},
rw => [qw/_last_sent_at _disconnect_timer/],
);
sub to_app {
my $self = shift;
my $router = Router::Boom::Method->new;
$router->add(POST => '/' => '_do_main');
$router->add(GET => '/monitor' => '_do_monitor');
sub {
my $env = shift;
my ($target_method) = $router->match(@$env{qw/REQUEST_METHOD PATH_INFO/});
return [404, [], ['NOT FOUND']] unless $target_method;
my $req = Plack::Request->new($env);
$self->$target_method($req);
};
}
sub _do_main {
my ($self, $req) = @_;
my $token = $req->param('token') or return [400, [], ['Bad Request']];
my $payload;
lib/APNS/Agent.pm view on Meta::CPAN
$self->_connect_to_apns;
}
return [200, [], ['Accepted']];
}
sub _do_monitor {
my ($self, $req) = @_;
my $result = {
sent => $self->_sent,
queued => scalar( @{ $self->_queue } ),
lib/APNS/Agent.pm view on Meta::CPAN
'Content-Type' => 'application/json; charset=utf-8',
'Content-Length' => length($body),
], [$body]];
}
sub _build_apns {
my $self = shift;
AnyEvent::APNS->new(
certificate => $self->certificate,
private_key => $self->private_key,
sandbox => $self->sandbox,
on_error => sub {
my ($handle, $fatal, $message) = @_;
my $t; $t = AnyEvent->timer(
after => 0,
interval => 10,
cb => sub {
undef $t;
infof "event:reconnect";
$self->_connect_to_apns;
},
);
warnf "event:error\tfatal:$fatal\tmessage:$message";
},
on_connect => sub {
infof "event:on_connect";
$self->_disconnect_timer($self->_build_disconnect_timer);
if (@{$self->_queue}) {
$self->_sending;
}
},
on_error_response => sub {
my ($identifier, $state) = @_;
my $data = $self->_sent_cache->get($identifier) || {};
$self->on_error_response->($self, {
identifier => $identifier,
state => $state,
lib/APNS/Agent.pm view on Meta::CPAN
},
($self->debug_port ? (debug_port => $self->debug_port) : ()),
);
}
sub _apns {
my $self = shift;
my $apns = $self->__apns;
$apns->connect unless $apns->connected;
$apns;
}
sub _connect_to_apns { goto \&_apns }
sub _build_disconnect_timer {
my $self = shift;
if (my $interval = $self->disconnect_interval) {
AnyEvent->timer(
after => $interval,
interval => $interval,
cb => sub {
if ($self->{__apns} && (time - ($self->_last_sent_at || 0) > $interval)) {
delete $self->{__apns};
delete $self->{_disconnect_timer};
infof "event:close apns";
}
lib/APNS/Agent.pm view on Meta::CPAN
);
}
else { undef }
}
sub _sending {
my $self = shift;
$self->{_send_timer} ||= AnyEvent->timer(
after => $self->send_interval,
interval => $self->send_interval,
cb => sub {
my $msg = shift @{ $self->_queue };
if ($msg) {
$self->_send(@$msg);
}
else {
lib/APNS/Agent.pm view on Meta::CPAN
}
},
);
}
sub _send {
my ($self, $token, $payload) = @_;
local $@;
my $identifier;
eval {
lib/APNS/Agent.pm view on Meta::CPAN
$self->{_sent}++;
$identifier;
}
}
sub parse_options {
my ($class, @argv) = @_;
require Getopt::Long;
require Pod::Usage;
require Hash::Rename;
lib/APNS/Agent.pm view on Meta::CPAN
sandbox!
debug-port=i
/) or Pod::Usage::pod2usage();
Pod::Usage::pod2usage() if !$opt{certificate} || !$opt{'private-key'};
Hash::Rename::hash_rename(\%opt, code => sub {tr/-/_/});
(\%opt, \@argv);
}
sub run {
my $self = shift;
my %args = @_ == 1 ? %{$_[0]} : @_;
if (!$args{listen} && !$args{port} && !$ENV{SERVER_STARTER_PORT}) {
$args{port} = 4905;
}
APP-REST-RestTestSuite
view release on metacpan or search on metacpan
lib/APP/REST/ParallelMyUA.pm view on Meta::CPAN
Object Constructor
=cut
sub new {
my ( $proto, %args ) = @_;
my $class = ref($proto) || $proto;
my $self;
$self = bless $proto->SUPER::new(%args), $class;
lib/APP/REST/ParallelMyUA.pm view on Meta::CPAN
redefine methods: on_connect gets called whenever we're about to
make a a connection
=cut
sub on_connect {
my ( $self, $request, $response, $entry ) = @_;
#print time,"Connecting to ", $request->url, "\n";
print STDERR ".";
$entry->{tick}->{start} = time;
lib/APP/REST/ParallelMyUA.pm view on Meta::CPAN
on_failure since the response from the server will be a well
formed HTTP response!
=cut
sub on_failure {
my ( $self, $request, $response, $entry ) = @_;
print "Failed to connect to ", $request->url, "\n\t", $response->code, ", ",
$response->message, "\n"
if $response;
}
lib/APP/REST/ParallelMyUA.pm view on Meta::CPAN
any successfully terminated HTTP connection! This does not imply
that the response sent from the server is a success!
=cut
sub on_return {
my ( $self, $request, $response, $entry ) = @_;
print ".";
#print time,"Response got from ", $request->url, "\n";
APR-Emulate-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
inc/Module/Install.pm view on Meta::CPAN
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
inc/Module/Install.pm view on Meta::CPAN
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_NEW
sub _read {
local *FH;
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
inc/Module/Install.pm view on Meta::CPAN
return $string;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
END_NEW
sub _write {
local *FH;
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
inc/Module/Install.pm view on Meta::CPAN
}
END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
inc/Module/Install.pm view on Meta::CPAN
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp ($$) {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
APR-HTTP-Headers-Compat
view release on metacpan or search on metacpan
inc/MyBuilder.pm view on Meta::CPAN
package MyBuilder;
use base qw( Module::Build );
sub create_build_script {
my ( $self, @args ) = @_;
$self->_auto_mm;
return $self->SUPER::create_build_script( @args );
}
sub _auto_mm {
my $self = shift;
my $mm = $self->meta_merge;
my @meta = qw( homepage bugtracker MailingList repository );
for my $meta ( @meta ) {
next if exists $mm->{resources}{$meta};
inc/MyBuilder.pm view on Meta::CPAN
$mm->{resources}{$meta} = $av if defined $av;
}
$self->meta_merge( $mm );
}
sub _auto_repository {
my $self = shift;
if ( -d '.svn' ) {
my $info = `svn info .`;
return $1 if $info =~ /^URL:\s+(.+)$/m;
}
inc/MyBuilder.pm view on Meta::CPAN
return $url;
}
return;
}
sub _auto_bugtracker {
'http://rt.cpan.org/NoAuth/Bugs.html?Dist=' . shift->dist_name;
}
sub ACTION_testauthor {
my $self = shift;
$self->test_files( 'xt/author' );
$self->ACTION_test;
}
sub ACTION_critic {
exec qw( perlcritic -1 -q -profile perlcriticrc lib/ ), glob 't/*.t';
}
sub ACTION_tags {
exec(
qw(
ctags -f tags --recurse --totals
--exclude=blib
--exclude=.svn
inc/MyBuilder.pm view on Meta::CPAN
t/ lib/
)
);
}
sub ACTION_tidy {
my $self = shift;
my @extra = qw( Build.PL );
my %found_files = map { %$_ } $self->find_pm_files,
ARCv2
view release on metacpan or search on metacpan
$Contact = "Patrick Boettcher <patrick.boettcher\@desy.de>, Wolfgang Friebel <wolfgang.friebel\@desy.de>";
my @syslog_arr = ('emerg','alert','crit','err','warning','notice','info','debug');
# package member vars
sub members
{
return {
# private:
# protected:
_error => undef, # contains the error message
};
}
## Constructor.
## Initializes the object and returns it blessed.
## For all sub classes, please override C<_Init> to check the
## parameter which are passed to the C<new> function. This
## is necessary because you are not able to call the the new method of a
## parent class, when having a class name (new $class::SUPER::new, does not work.).
##in> %hash, key => val, ...
##out> blessed object of the class
##eg> my $this = new Arc::Class ( key => value, key2 => value2 );
sub new
{
my $this = shift;
my $class = ref($this) || $this;
my $self = bless { },$class;
$self->_Init(@_);
## Init function (initializes class context)
## Module dependent initialization, every subclass shall override it
## and call the _Init of its SUPER class. This method is called by the new method of C<Arc>.
##in> %hash, key => val, ...
##out> true, if all passed values are in their definition scope, otherwise false
##eg> see source code of any non-abstract sub class of Arc
sub _Init
{
my $this = shift;
my (%values) = @_;
my $members = $this->members;
## Debug function.
## Logs messages with "DEBUG"
##in> ... (message)
##out> always false
##eg> $this->_Debug("hello","world"); # message will be "hello world"
sub _Debug
{
my $this = shift;
$this->Log(LOG_DEBUG,@_);
}
## requested by the user.
## Commonly used for logging errors from application level.
##in> $facility, ... (message)
##out> always false
##eg> return $arc->Log(LOG_ERR,"Message");
sub Log
{
my $this = shift;
my $pr = shift;
my $ll = $this->{loglevel};
my $lev = 1;
## Use this function for setting an error from class level. Users should use IsError
## to get the message if a function failed.
##in> ... (message)
##out> always false
##eg> return $this->_SetError("User is not allowed to do this."); # breaks when an error occured
sub _SetError
{
my $this = shift;
$this->Log(LOG_ERR,@_);
my $errstr = "";
}
## User function to get the error msg.
##out> the error message if any otherwise undef
##eg> unless (my $err = $arc->IsError()) { .. } else { print STDERR $err; }
sub IsError
{
my $this = shift;
my $ret = $this->{_error};
$this->{_error} = undef;
return $ret;
}
## Destructor
sub DESTROY {
my $this = shift;
closelog() if $this->{_syslog};
}
1;
ARGV-Abs
view release on metacpan or search on metacpan
lib/ARGV/Abs.pm view on Meta::CPAN
}
use File::Spec;
sub import
{
# Base directory for resolving paths
my $base = $_[1];
unless (defined $base) {
require Cwd;
ARGV-ENV
view release on metacpan or search on metacpan
lib/ARGV/ENV.pm view on Meta::CPAN
$ARGV::ENV::VERSION = '1.00';
}
use Text::ParseWords ();
sub import
{
shift;
foreach (@_) {
if (defined $ENV{$_} && $ENV{$_} ne '') {
unshift @ARGV, Text::ParseWords::shellwords($ENV{$_});
ARGV-JSON
view release on metacpan or search on metacpan
lib/ARGV/JSON.pm view on Meta::CPAN
our $VERSION = '0.01';
our $JSON = JSON->new->utf8;
our @Data;
sub import {
local $/;
while (local $_ = <>) {
$JSON->incr_parse($_);
lib/ARGV/JSON.pm view on Meta::CPAN
package
ARGV::JSON::Handle;
use Tie::Handle;
use parent -norequire => 'Tie::StdHandle';
sub READLINE {
if (wantarray) {
return splice @ARGV::JSON::Data;
} else {
return shift @ARGV::JSON::Data;
}
ARGV-OrDATA
view release on metacpan or search on metacpan
lib/ARGV/OrDATA.pm view on Meta::CPAN
=cut
our $VERSION = '0.005';
sub import {
my ($package) = $_[1] || caller;
{ no strict 'refs';
no warnings 'once';
*ORIG = *ARGV;
*ARGV = *{$package . '::DATA'} unless @ARGV || ! -t;
}
}
sub unimport {
my $package = shift;
*ARGV = *ORIG;
{ no strict 'refs';
delete ${$package . '::'}{ORIG};
}
undef *ORIG;
}
sub is_using_argv {
! is_using_data()
}
sub is_using_data {
my ($package) = caller;
$package = caller 1 if 'ARGV::OrDATA' eq $package;
return do {
no strict 'refs';
*ARGV eq *{$package . '::DATA' }
ARGV-Struct
view release on metacpan or search on metacpan
lib/ARGV/Struct.pm view on Meta::CPAN
our $VERSION = '0.06';
has argv => (
is => 'ro',
isa => ArrayRef,
default => sub { [ @ARGV ] },
);
sub argcount {
my $self = shift;
return scalar(@{ $self->argv });
}
sub arg {
my ($self, $i) = @_;
return $self->argv->[ $i ];
}
sub args {
my $self = shift;
return @{ $self->argv };
}
sub parse {
my ($self) = @_;
my $substruct = $self->_parse_argv($self->args);
die "Trailing values after structure" if (scalar(@{ $substruct->{ leftover } }));
return $substruct->{ struct };
}
sub _parse_list {
my ($self, @args) = @_;
my $list = [];
while (my $token = shift @args) {
if ($token eq '[') {
my $substruct = $self->_parse_list(@args);
lib/ARGV/Struct.pm view on Meta::CPAN
}
}
die "Unclosed list";
};
sub _parse_hash {
my ($self, @args) = @_;
my $hash = {};
while (my $token = shift @args) {
if ($token eq '}') {
return { struct => $hash, leftover => [ @args ] };
lib/ARGV/Struct.pm view on Meta::CPAN
}
}
die "Unclosed hash";
}
sub _parse_argv {
my ($self, @args) = @_;
my $token = shift @args;
if ($token eq '[') {
ARGV-URL
view release on metacpan or search on metacpan
lib/ARGV/URL.pm view on Meta::CPAN
package ARGV::URL;
{
$ARGV::URL::VERSION = '0.93';
}
sub import
{
# Inspired from L<perlopentut>
@ARGV = map { m#^[a-z]{2,}://# ? qq#lwp-request -m GET "$_" |# : $_ } @ARGV;
}
ARGV-readonly
view release on metacpan or search on metacpan
lib/ARGV/readonly.pm view on Meta::CPAN
use 5.00001;
$VERSION = '0.01';
sub import{
# Tom Christiansen in Message-ID: <24692.1217339882@chthon>
# reccomends essentially the following:
for (@ARGV){
s/^(\s+)/.\/$1/; # leading whitespace preserved
s/^/< /; # force open for input
ARS-Simple
view release on metacpan or search on metacpan
lib/ARS/Simple.pm view on Meta::CPAN
carp "Error in $cfg : $@";
}
}
}
sub new
{
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
lib/ARS/Simple.pm view on Meta::CPAN
$self->_init(@_);
return $self;
}
sub DESTROY
{
my $self = shift;
if ($self->{ctl})
{
ars_Logoff($self->{ctl});
}
}
sub _check_initialised
{
my $self = shift;
unless ($self->{ctl})
{
lib/ARS/Simple.pm view on Meta::CPAN
}
return 1;
}
sub get_list
{
my ($self, $args) = @_; # Expect args keys of 'form', 'query', optionally 'max_returns'
# Check ARSystem initailised
return unless $self->_check_initialised();
lib/ARS/Simple.pm view on Meta::CPAN
}
my %results = ( numMatches => scalar(@entryIds), eids => \@entryIds );
return \%results;
}
sub _load_qualifier
{
my ($self, $args) = @_;
my $qual = ars_LoadQualifier($self->{ctl}, $args->{form}, $args->{query});
lib/ARS/Simple.pm view on Meta::CPAN
}
return $qual;
}
sub get_data_by_label
{
my ($self, $args) = @_;
my $form = $args->{form};
my $query = $args->{query};
lib/ARS/Simple.pm view on Meta::CPAN
}
return \%entryList;
}
sub get_SQL
{
my ($self, $args) = @_;
# Set the limit
$self->set_max_entries($args->{max_returns});
lib/ARS/Simple.pm view on Meta::CPAN
}
return $m;
}
sub set_max_entries
{
my ($self, $max) = @_;
if (defined $max)
{
lib/ARS/Simple.pm view on Meta::CPAN
$self->_carp("set_max_entries() - Could not set the AR_SERVER_INFO_MAX_ENTRIES to $max:\n$ars_errstr\n");
}
}
}
sub _reset_max_entries
{
my $self = shift;
if (defined $self->{reset_limit})
{
$self->set_max_entries($self->{reset_limit});
}
}
sub get_fields
{
my ($self, $form) = @_;
# Check required args
unless ($form)
lib/ARS/Simple.pm view on Meta::CPAN
$self->_carp("get_fields() error: $ars_errstr\n") unless (%fids);
return \%fids;
}
sub update_record
{
my ($self, $args) = @_;
my $eID = $args->{eid};
my $form = $args->{form};
my %lvp = %{$args->{lvp}};
lib/ARS/Simple.pm view on Meta::CPAN
carp($msg);
}
return $rv;
}
sub get_ctl
{
my $self = shift;
return $self->{ctl};
}
sub _carp
{
my $self = shift;
my $msg = join('', @_);
carp $msg;
$self->{log}->exp($msg) if ($self->{log});
}
sub _init
{
my ($self, $args) = @_;
# Did we have any of the persistant variables passed
my $k = '5Jv@sI9^bl@D*j5H3@:7g4H[2]d%Ks314aNuGeX;';
ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
my $fretry =8;
1;
sub new { # New ARS object
# (-param=>value,...) -> ARS object
my $c=shift;
my $s ={'' => ''
,-ctrl => undef # ARS control struct from ars_Login()
,-srv => undef # Server name
lib/ARSObject.pm view on Meta::CPAN
$s->{-storable} =eval('use Storable; 1') if !exists($s->{-storable});
$s
}
sub AUTOLOAD { # Use self->arsXXX() syntax for ars_XXX(ctrl,...) calls
my $m =substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
return(&{$_[0]->{-die}}($_[0]->efmt("Called name without 'ars'", $_[0]->{-cmd}, undef, 'AUTOLOAD',$m)))
if $m !~/^ars/;
$m =~s/^ars/ars_/
if $m !~/^ars_/;
lib/ARSObject.pm view on Meta::CPAN
no strict;
&$m($_[0]->{-ctrl}, @_[1..$#_])
}
sub DESTROY {
my $s =shift;
$s->{-die} =undef;
$s->{-warn}=undef;
$s->{-ctrl} && eval{ars_Logoff($s->{-ctrl})};
$s->{-ctrl}=undef;
lib/ARSObject.pm view on Meta::CPAN
$s->{-diemsg} =undef;
$s->{-warnmsg} =undef;
}
sub set { # Set/Get parameters
# () -> (parameters)
# (-param) -> value
# (-param => value,...) -> self
return(keys(%{$_[0]})) if scalar(@_) ==1;
return($_[0]->{$_[1]}) if scalar(@_) ==2;
lib/ARSObject.pm view on Meta::CPAN
}
$s
}
sub ineval { # is inside eval{}?
# for PerlEx and mod_perl
# see CGI::Carp::ineval comments and errors
return $^S if !($ENV{GATEWAY_INTERFACE}
&& ($ENV{GATEWAY_INTERFACE} =~/PerlEx/))
&& !$ENV{MOD_PERL};
lib/ARSObject.pm view on Meta::CPAN
$^S
}
# error message form ??? use ???
# (err/var, command, operation, function, args)
sub efmt {
efmt1(@_)
}
sub efmt0 {
my ($s, $e, $c, $o, $f, @a) =@_;
cpcon($s
,join(': '
,($c ? $c : ())
,($f ? $f .'(' .join(',', map {$s->dsquot($_)} @a) .')' : ())
lib/ARSObject.pm view on Meta::CPAN
)
.($e && ($e eq '$!') && $^E ? (' -> ' .$! .' / ' .$^E) : ( ' -> ' .($e || 'unknown error')))
)
}
sub efmt1 {
my ($s, $e, $c, $o, $f, @a) =@_;
cpcon($s
,join(' # '
,($e && ($e eq '$!') && $^E ? ($! .' / ' .$^E) : ($e || 'unknown error'))
,($o ? $o : ())
lib/ARSObject.pm view on Meta::CPAN
)
)
}
sub strquot { # Quote and Escape string enclosing in ''
my $v =$_[1]; # (string) -> escaped
return('undef') if !defined($v);
$v =~s/([\\'])/\\$1/g;
$v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg;
$v =~/^\d+$/ ? $v : ('\'' .$v .'\'');
}
sub strquot2 { # Quote and Escape string enclosing in ""
my $v =$_[1]; # (string) -> escaped
return('undef') if !defined($v);
$v =~s/([\\"])/\\$1/g;
$v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg;
$v =~/^\d+$/ ? $v : ('"' .$v .'"');
}
sub arsquot { # Quote string for ARS
return('NULL') if !defined($_[1]);
my $v =$_[1];
$v =~s/"/""/g;
$v =~/^\d+$/ ? $v : ('"' .$v .'"');
}
sub dsquot { # Quote data structure
$#_ <2 # (self, ?'=>', data struct)
? dsquot($_[0],'=> ',$_[1])
: !ref($_[2]) # (, hash delim, value) -> stringified
? strquot($_[0],$_[2])
: ref($_[2]) eq 'ARRAY'
lib/ARSObject.pm view on Meta::CPAN
} sort keys %{$_[2]}) .'}'
: strquot($_[0],$_[2])
}
sub dsquot1 { # Quote data structure, defined elements only
$#_ <2 # (self, ?'=>', data struct)
? dsquot1($_[0],'=> ',$_[1])
: !ref($_[2]) # (, hash delim, value) -> stringified
? strquot($_[0],$_[2])
: ref($_[2]) eq 'ARRAY'
lib/ARSObject.pm view on Meta::CPAN
} sort keys %{$_[2]}) .'}'
: strquot($_[0],$_[2])
}
sub dsdump { # Data structure dump to string
my ($s, $d) =@_; # (data structure) -> dump string
eval('use Data::Dumper');
my $o =Data::Dumper->new([$d]);
$o->Indent(1);
$o->Deepcopy(1);
$o->Dump();
}
sub dsparse { # Data structure dump string to perl structure
my ($s, $d) =@_; # (string) -> data structure
eval('use Safe; 1')
&& Safe->new()->reval($d)
}
sub dscmp { # Compare data structures
my($s, $ds1, $ds2) =@_;
return(1) if (defined($ds1) && !defined($ds2)) ||(defined($ds2) && !defined($ds1));
return(0) if !defined($ds1) && !defined($ds2);
return(1) if (ref($ds1) ||'') ne (ref($ds2) ||'');
return($ds1 cmp $ds2) if !ref($ds1);
lib/ARSObject.pm view on Meta::CPAN
return(dsquot($s,$ds1) cmp dsquot($s,$ds2)) if ref($ds1) eq 'HASH';
$ds1 cmp $ds2
}
sub dsunique { # Unique list
my %h =(map {defined($_) ? ($_ => 1) : ()} @_[1..$#_]);
use locale;
sort keys %h
}
sub dsmerge { # Merge arrays or hashes
my $r;
if (ref($_[1]) eq 'ARRAY') {
$r =[];
for (my $i=1; $i <=$#_; $i++) {
for (my $j=0; $j <=$#{$_[$i]}; $j++) {
lib/ARSObject.pm view on Meta::CPAN
}
$r
}
sub strtime { # Stringify Time
my $s =shift;
if (scalar(@_) && !defined($_[0])) {
&{$s->{-warn}}('Not defined time in strtime()') if $^W;
return(undef)
}
lib/ARSObject.pm view on Meta::CPAN
# if !defined($r);
$r
}
sub timestr { # Time from String
my $s =shift;
if (scalar(@_) && !defined($_[0])) {
&{$s->{-warn}}('Not defined time in timestr()') if $^W;
return(undef)
}
lib/ARSObject.pm view on Meta::CPAN
# if !defined($r);
$r
}
sub timeadd { # Adjust time to years, months, days,...
my $s =$_[0];
if (!defined($_[1])) {
&{$s->{-warn}}('Not defined time in timeadd()') if $^W;
return(undef)
}
lib/ARSObject.pm view on Meta::CPAN
#eval('use POSIX');
POSIX::mktime(@t[0..5],0,0,$t[8])
}
sub charset {
$_[0]->{-charset} && ($_[0]->{-charset} =~/^\d/)
? 'windows-' .$_[0]->{-charset}
: ($_[0]->{-charset} || ($_[0]->{-cgi} && $_[0]->{-cgi}->charset())
|| eval('!${^ENCODING}') && eval('use POSIX; POSIX::setlocale(POSIX::LC_CTYPE)=~/\\.([^.]+)$/ ? "cp$1" : "cp1252"'))
}
sub cptran { # Translate strings between codepages
my ($s,$f,$t,@s) =@_; # (from, to, string,...) -> string,...
if (($] >=5.008) && eval("use Encode; 1")) {
map {$_= /oem|866/i ? 'cp866'
: /ansi|1251/i ? 'cp1251'
: /koi/i ? 'koi8-r'
lib/ARSObject.pm view on Meta::CPAN
}
@s >1 ? @s : $s[0];
}
sub cpcon { # Translate to console codepage
$_[0] && $_[0]->{-cpcon}
? &{$_[0]->{-cpcon}}(@_)
: $#_ <2
? $_[1]
: (@_[1..$#_])
}
sub sfpath { # self file path
# () -> script's dir
# (subpath) -> dir/subpath
my $p =$0 =~/[\\\/]/ ? $0 : $^O eq 'MSWin32' ? Win32::GetFullPathName($0) : '';
$_[1]
? (($p =~/^(.+?[\\\/])[^\\\/]+$/ ? $1 : '') .$_[1])
: ($p =~/^(.+?)[\\\/][^\\\/]+$/ ? $1 : '')
}
sub fopen { # Open file
my $s =shift; # ('-b',filename) -> success
my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
my $f =$_[0]; $f ='<' .$f if $f !~/^[<>]/;
eval('use IO::File');
my $h =IO::File->new($f) || return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open file','fopen',$f)));
$h->binmode() if $h && ($o =~/b/);
$h
}
sub fdirls { # Directory listing
my $s =shift; # ('-',pathname, ?filter sub{}(self, path, $_=entry), ? []) -> (list) || [list]
my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
my ($f, $cf, $cs) =@_;
local *FILE; opendir(FILE, $f) || return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open dir','fdirls',$f)));
local $_;
lib/ARSObject.pm view on Meta::CPAN
return @r;
}
}
sub fstore { # Store file
my $s =shift; # ('-b',filename, strings) -> success
my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
my $f =$_[0]; $f ='>' .$f if $f !~/^[<>]/;
print "fstore('$f')\n" if $s->{-echo};
# local $SIG{'TERM'} ='IGNORE';
lib/ARSObject.pm view on Meta::CPAN
close(FILE);
$r || &{$s->{-die}}($s->efmt('$!',undef,'Cannot write file','fstore',$f))
}
sub fload { # Load file
my $s =shift; # ('-b',filename) -> content
my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
my($f,$f0) =($_[0],$_[0]);
if ($f =~/^[<>]+/) {$f0 =$'}
else {$f ='<' .$f}
lib/ARSObject.pm view on Meta::CPAN
close(FILE);
defined($r) ? $b : &{$s->{-die}}($s->efmt('$!',undef,'Cannot read file','fload',$f))
}
sub vfname { # Name of variables file
# (varname|-slot) -> pathname
return($_[0]->{-vfbase}) if !$_[1];
my $v =$_[1]; $v =~s/[\s.,:;|\/\\?*+()<>\]\["']/_/g;
$_[0]->{-vfbase} .($v =~/^-(.+)/ ? ($1 .($_[2] ||'.var')) : ($v .($_[2] ||'.var')))
}
sub vfstore { # Store variables file
# (varname, {data}) -> success
# (-slot) -> success
my($s,$n,$d)=@_;
$d =$s->{$n} if !$d && ($n =~/^-/);
my $f =$s->vfname($n, '.new');
lib/ARSObject.pm view on Meta::CPAN
}
$r
}
sub vfload { # Load variables file
# (varname|-slot, ?{use default} | load default, ?renew | renew seconds) -> {data}
my($s,$f,$d,$nn) =@_; # -slot-calc, -slot-store
my $k =($f =~/^-/ ? $f : undef);
$f =$s->vfname($f);
if ($nn && $nn >1) {
lib/ARSObject.pm view on Meta::CPAN
$r
}
sub vfrenew { # Renew variables file
my($s,$f,$nn) =@_; # (-slot, ?period seconds) -> vfload
return(1) if $f !~/^-/;
vfload($s,$f,1,$nn ||1);
}
sub vfclear { # Clear vfdata() and vfhash()
my($s,$f) =@_; # (-slot, ?period seconds) -> vfload
return(1) if $f !~/^-/;
delete($s->{$f});
foreach my $k (keys %$s) {
next if $k !~/^\Q$f\E[\/].+/;
lib/ARSObject.pm view on Meta::CPAN
}
1;
}
sub vfdata { # Access to array data from variables file
# automatically load using vfload().
# (-slot) -> [array]
# (-slot, filter sub{}(self, -slot, index, $_=value)) -> [array]
vfload($_[0], $_[1], 1) if !$_[0]->{$_[1]} || (ref($_[0]->{$_[1]}) eq 'CODE');
if ($_[2]) {
lib/ARSObject.pm view on Meta::CPAN
}
$_[0]->{$_[1]}
}
sub vfhash { # Access to hash of array data from variables file
# automatically formed in memory using vfdata().
# (-slot, key name) -> {hash from vfdata()}
# (-slot, key name => key value) -> {key=>value,...}
# (-slot, key name => key value => elem name ) -> elem value
# (-slot, key name => filter sub{}(self, -slot, key, $_ = value)) -> {key=>value,...}
lib/ARSObject.pm view on Meta::CPAN
: $s->{$kk}->{$v}
}
sub vfdistinct {# Distinct values from vfdata() field.
# (-slot, key name) -> [keys %{vfhash(...)}]
# (-slot, key name => filter sub{}(self, -slot, key, $_ = value)) -> [keys %{vfhash(...)}]
my($s, $f, $k, $v) =@_;
my(%rh, $t);
local $_;
lib/ARSObject.pm view on Meta::CPAN
return([sort {$a cmp $b} keys %rh])
}
sub connect { # Connect to ARS server
eval('use ARS'); # (-param=>value,...) -> self
my $s =shift; # -srv, -usr, -pswd, -lang
$s->set(@_);
$s->set(-die=>'Carp') if !$s->{-die};
local $s->{-cmd} ="connect()";
lib/ARSObject.pm view on Meta::CPAN
$s->arsmeta();
$s
}
sub disconnect { # Disconnect data servers
my $s =shift;
$s->{-ctrl} && eval{ars_Logoff($s->{-ctrl})};
$s->{-ctrl}=undef;
$s->{-dbi} && eval{$s->{-dbi}->disconnect()};
$s->{-dbi} =undef;
}
sub arsmeta { # Load/refresh ARS metadata
my $s =shift; # -srv, -usr, -pswd, -lang
$s->set(@_);
local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')
.($s->{-schgen} ? "dumper('" .$s->vfname('meta') ."')" : 'arsmeta()');
if (ref($s->{-schgen})
lib/ARSObject.pm view on Meta::CPAN
}
$s->arsmetaix() if $s->{-meta};
}
sub arsmetaix { # Index ARS metadata
my $s =shift;
if ($s->{-meta}) {
foreach my $f (keys %{$s->{-meta}}){
next if $f =~/^-/;
$s->{-meta}->{$f}->{-fldids} ={}
lib/ARSObject.pm view on Meta::CPAN
# print $s->cpcon($s->dsdump($s->{-metaid})), "\n"; exit(0);
}
}
sub arsmetamin { # Minimal ARS metadata ('-meta-min' varfile)
my $s =shift; # refresh after 'arsmeta'/'connect'
$s->set(@_); # load instead of 'arsmeta'/'connect'
local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')
.($s->{-schgen} ? "dumper('" .$s->vfname('meta-min') ."')" : 'arsmetamin()');
if (ref($s->{-schgen})
lib/ARSObject.pm view on Meta::CPAN
delete $s->{'-meta-min'};
$s;
}
sub arsmetasql { # SQL ARS metadata ('-meta-sql' varfile)
my $s =shift; # refresh after 'arsmeta'/'connect'
$s->set(@_); # !!! 'enum' texts
local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')
.($s->{-schgen} ? "dumper('" .$s->vfname('meta-sql') ."')" : 'arsmetasql()');
if (ref($s->{-schgen})
lib/ARSObject.pm view on Meta::CPAN
$s;
}
sub sqlnesc { # SQL name escaping, default for '-sqlname', '-sqlntbl', '-sqlncol'
my $v =lc($_[1]); # (self, name) -> escaped
$v =~s/[^a-zA-Z0-9_]/_/g;
$v =substr($v,0,64) if length($v) >64;
$v
}
sub sqlninc { # SQL name incrementing, default for '-sqlninc'
my $v =$_[1]; # (self, name) -> incremented
my ($n, $nn);
if (0) {
($n, $nn) =$v =~/^(.+?)_([1-9]+)$/ ? ($1, '_' .($2 +1)) : ($v, '_1');
}
lib/ARSObject.pm view on Meta::CPAN
$v =$n .$nn;
length($v) >64 ? substr($n, 0, 64 -length($nn)) .$nn : $v
}
sub sqlname { # SQL name from ARS name
# (formName, ?fieldName, ?force update meta) -> SQL name
# -sqlname, -sqlntbl, -sqlncol, -sqlninc
my($s,$f,$ff,$fu) =@_;
return(undef)
if !$f;
lib/ARSObject.pm view on Meta::CPAN
}
$tc
}
sub ars_errstr {# Last ARS error
$ARS::ars_errstr
}
sub schema { # Schema by form name
# (schema) -> {schema descr}
# () -> {schemaName=>{descr}}
$_[1]
? $_[0]->{-meta}->{ref($_[1]) ? $_[1]->{schemaName} : $_[1]}
: $_[0]->{-meta};
}
sub schfld { # Schema of field
# (schema, field) -> {field descr}
# ({schemaName=>name, fieldName=>name}) -> {field descr}
# (schema) -> {field=>descr}
ref($_[1])
? $_[0]->{-meta}->{$_[1]->{schemaName}}->{-fields}->{$_[1]->{fieldName}}
lib/ARSObject.pm view on Meta::CPAN
? $_[0]->{-meta}->{$_[1]}->{-fields}->{$_[2]}
: $_[0]->{-meta}->{$_[1]}->{-fields}
}
sub schid { # Schema info by field id
# (schema, fieldId) -> {fieldName=>'name', FieldId=>id}
# () -> rearranged self
$_[0]->{-metaid}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}
|| &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schid',$_[1],$_[2]))
}
sub schdn { # Schema info by field distiguished name
# (schema, fieldName) -> {fieldName=>'name', FieldId=>id}
(($_[2] =~/^\d+$/)
&& ($_[0]->{-metaid}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}))
|| $_[0]->{-metadn}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fields}->{$_[2]}
|| &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schdn',$_[1],$_[2]))
}
sub schdi { # Schema info by field Id
# (schema, fieldId) -> {fieldName=>'name', FieldId=>id} || undef
$_[0]->{-metaid}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}
}
sub schlbls { # Enum field {values => labels}
# (schema, fieldId) -> {value=>label,...}
my($s,$f,$ff) =@_;
$ff =ref($ff) ? $ff
: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
lib/ARSObject.pm view on Meta::CPAN
$ff && $ff->{-hashOut}
}
sub schlblsl { # Enum field {values => labels localised}
# (schema, fieldId) -> {value=>localised label,...}
my($s,$f,$ff) =@_;
$ff =ref($ff) ? $ff
: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
lib/ARSObject.pm view on Meta::CPAN
$ff->{fieldLbvl} ? {split /\\+/, substr($ff->{fieldLbvl},1)} : schlbls($s,$f,$ff)
}
sub schvals { # Enum field [values]
# (schema, fieldId) -> [value,...]
my($s,$f,$ff) =@_;
$ff =ref($ff) ? $ff
: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
lib/ARSObject.pm view on Meta::CPAN
$ff && $ff->{-listVals}
}
sub strOut { # Convert field value for output, using '-meta'
# (schema, fieldId, fieldValue) -> fieldValue
my($s,$f,$ff,$v) =@_;
$ff =ref($ff) ? $ff : $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff} : $s->{-meta}->{$f}->{-fields}->{$ff};
if (!defined($v) ||!$ff ||!$s->{-strFields}) {
}
lib/ARSObject.pm view on Meta::CPAN
}
$v
}
sub strIn { # Convert input field value to internal, using '-meta'
# (schema, fieldId, fieldValue) -> fieldValue
my($s,$f,$ff,$v) =@_;
$ff =ref($ff) ? $ff : $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff} : $s->{-meta}->{$f}->{-fields}->{$ff};
if (!defined($v) ||!$ff ||!$s->{-strFields}) {
}
lib/ARSObject.pm view on Meta::CPAN
}
$v
}
sub lsflds { # List fields from '-meta'
# (additional field options)
my ($s, @a) =@_;
@a =('fieldLblc') if !@a;
unshift @a, 'fieldName', 'fieldId', 'dataType', 'option', 'createMode';
map { my $f =$_;
lib/ARSObject.pm view on Meta::CPAN
} sort keys %{$s->{-meta}->{$f}->{-fields}}
} sort keys %{$s->{-meta}}
}
sub query { # ars_GetListEntry / ars_LoadQualifier
# (-clause=>val) -> list
# (...-for=>sub{}) -> self
# Field Ids translated using -metadn/-metaid
# -from ||-form ||-schema => schema name
# -where || -query ||-qual => search condition
lib/ARSObject.pm view on Meta::CPAN
return(())
}
}
sub _qsubst { # query condition string substitutions
# (''|char, expr string, form) -> translated
my ($s, $c, $q, $f) =@_;
return($q) if !defined($q) ||($q eq '');
my $r ='';
if (!$c) {
lib/ARSObject.pm view on Meta::CPAN
}
$r
}
sub entry { # ars_GetEntry
# (-from=>form, -id=>entryId, ?-for=>{}, ?-fields=>[internalId,...])
# -> {fieldName => value}
# # Field Ids translated using -schdn/-schid
# -from ||-form ||-schema => schema name
# -id => entryId
lib/ARSObject.pm view on Meta::CPAN
? &{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'entry',-form=>$f,-id=>$a{-id}))
: {})
}
sub entryOut { # Format entry hash ref for output
# (schema, entry, ?sample) -> entry
my ($s, $f, $r, $rr) =@_;
if ($rr) {
undef(@{$rr}{keys %$rr}) if %$rr;
}
lib/ARSObject.pm view on Meta::CPAN
}
$rr
}
sub entryDif { # Diff hash refs
# ({old}, {new}, exclude empty) -> {to update}
my($s, $ds1, $ds2, $ee) =@_;
return(undef) if (ref($ds1) ||'') ne (ref($ds2) ||'');
return(undef) if (ref($ds1) ||'') ne 'HASH';
my ($r, $rr) =({});
lib/ARSObject.pm view on Meta::CPAN
}
$rr ? $r : undef
}
sub entryNew { # New {field => value}
# (-form=>form, field=>value,...) -> {field=>value,...}
# ?'Incident Number'=>1 for 'HPD:Help Desk'
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-into} ||$a{-for};
delete @a{qw(-schema -form -from -into -for)};
lib/ARSObject.pm view on Meta::CPAN
}
\%a
}
sub entryIns { # ars_CreateEntry
# (-form=>form, field=>value) -> id
# ?-echo=>1
# ?'Incident Number'=>1 for 'HPD:Help Desk'
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-into};
lib/ARSObject.pm view on Meta::CPAN
}
$r ||$s
}
sub entryUpd { # ars_SetEntry(ctrl,schema,entry_id,getTime,...)
# (-form=>form, -id=>entryId, field=>value) -> id
# ?-echo=>1
#
# ??? ARMergeEntry()/ars_MergeEntry(ctrl, schema, mergeType, ...)
# ??? ars_EncodeDiary(diaryEntryHash1, ... diaryEntryHashN)
lib/ARSObject.pm view on Meta::CPAN
if !$r && $ARS::ars_errstr;
$id
}
sub entryDel { # ars_DeleteEntry
# (-form=>form, -id=>entryId) -> id
# ?-echo=>1
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-from} ||$a{-into};
my $id=$a{-id};
lib/ARSObject.pm view on Meta::CPAN
if !$r && $ARS::ars_errstr;
$id
}
sub entryBLOB { # BLOB field retrieve/update
# (-form=>form, -id=>entryId, -field=>fieldId|fieldName
# ,?-set=>data
# ,?-file=>filePath, ?-set=>boolean
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-from} ||$a{-into};
lib/ARSObject.pm view on Meta::CPAN
return(!$a{-file} ? $r : $r ? $a{-id} : $r)
}
}
sub dbi { # DBI connection object
return($_[0]->{-dbi}) if $_[0]->{-dbi};
dbiconnect(@_)
}
sub dbiconnect {# DBI connect to any database
# (-dbiconnect=>[]) -> dbi object
set(@_);
set($_[0],-die=>'Carp') if !$_[0]->{-die};
print $_[0]->cpcon("dbiconnect()\n")
if $_[0]->{-echo};
lib/ARSObject.pm view on Meta::CPAN
$_[0]->{-dbi} =DBI->connect(ref($_[0]->{-dbiconnect}) ? @{$_[0]->{-dbiconnect}} : $_[0]->{-dbiconnect})
|| &{$_[0]->{-die}}($_[0]->efmt(DBI->errstr,undef,undef,'dbiconnect') ."\n");
}
sub dbiquery { # DBI query
# (dbi query args) -> dbi cursor object
# (-echo=>1,...)
my($s, @q) =@_;
my(%a); while ($#q && ($q[0] =~/^-/)) {$a{$q[0]} =$q[1]; shift @q; shift @q};
print $s->cpcon("dbiquery($q[0])\n")
lib/ARSObject.pm view on Meta::CPAN
|| return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbiexecute',@q)));
$op;
}
sub dbido { # DBI do
# (dbi do args) -> dbi cursor object
# (-echo=>1,...)
my($s, @q) =@_;
my(%a); while ($#q && ($q[0] =~/^-/)) {$a{$q[0]} =$q[1]; shift @q; shift @q};
print $s->cpcon("dbiquery($q[0])\n")
lib/ARSObject.pm view on Meta::CPAN
$s->{-dbi}->do(@q)
|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbido',@q));
}
sub dbierrstr { # Last DBI error
$_[0]->{-dbi}->errstr
}
sub dbitables { # DBI tables array
my ($s, $sch, $tbl) =@_;
my @t =$s->dbi()->tables('',$sch||$s->{-sqlschema}||'', $tbl||'%');
if (!scalar(@t)
&& (((ref($s->{-dbiconnect}) ? $s->{-dbiconnect}->[0] : $s->{-dbiconnect})||'') =~/^dbi:ADO:/i)) {
$sch =$sch||$s->{-sqlschema};
lib/ARSObject.pm view on Meta::CPAN
}
@t
}
sub dbicols { # DBI table columns
my ($s, $sch, $tbl) =@_;
# my $st =$s->dbiquery('SHOW COLUMNS FROM ' .($sch ? $sch .'.' : '') .$tbl);
my $st =$s->dbi()->column_info('',$sch||$s->{-sqlschema}||'', $tbl||'','%');
@{$st->fetchall_arrayref({})}
}
sub dbitypespc { # DBI column type spec
my ($s, $d) =@_;
($d->{'TYPE_NAME'} ||'unknown')
.($d->{'COLUMN_SIZE'}
? ' (' .join(',', map {defined($d->{$_}) ? $d->{$_} : ()
} 'COLUMN_SIZE', 'DECIMAL_DIGITS') .')'
: '')
}
sub dbidsmetasync { # DBI datastore - sync meta with 'arsmetasql'
my ($s, %arg) =@_; # (-echo)
return(undef) if !$s->{'-meta-sql'};
my $dbt ={map {!$_
? ()
: $_ =~/\."*([^."]+)"*$/
lib/ARSObject.pm view on Meta::CPAN
}
$s;
}
sub dbidsrpl { # DBI datastore - load data from ARS
my ($s, %arg) =@_;
$arg{-form} =$arg{-from} ||$arg{-schema} if !$arg{-form};
$arg{-query} =$arg{-where} ||$arg{-qual} if !$arg{-query};
$arg{-filter}=undef if !$arg{-filter};
$arg{-lim_rf}=300 if !$arg{-lim_rf};
lib/ARSObject.pm view on Meta::CPAN
join(', ', map {$_ ? $_ : ()} $ci && "new $ci", $cu && "upd $cu", $cd && "del $cd")
||'up-to-date'
}
sub dbidsquery { # DBI datastore - query data alike ARS
my ($s, %arg) =@_;
# -form => ARS form || -from => sql table name
# -fields=> ARS fields || -select=>sql select list
# -query=> ARS query || -where => sql where
# -order =>
lib/ARSObject.pm view on Meta::CPAN
}
@r
}
sub dbidsqq { # DBI datastore - quote/parse condition to SQL names
my ($s,$sf,$mh) =@_; # (self, query string, default sql metadata)
if (0) {
my $q =substr($s->{-dbi}->quote_identifier(' '),0,1);
$sf =~s/$q([^$q]+)$q\.$q([^$q]+)$q/!$s->{'-meta-sql'}->{-forms}->{$1} ? "?1$q$1${q}.$q$2$q" : $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$1}}->{-fields}->{$2} ? $s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) .'.' .$s->{-dbi}-...
$sf =~s/$q([^$q]+)$q/$s->{'-meta-sql'}->{-forms}->{$1} ? ($s->{-sqlschema} ? $s->{-dbi}->quote_identifier($s->{-sqlschema}) .'.' : '') .$s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) : $mh->{-fields}->{$1} ? $s->{-dbi}->quote_identi...
lib/ARSObject.pm view on Meta::CPAN
$sr .$sf
}
sub cgi { # CGI object
return($_[0]->{-cgi}) if $_[0]->{-cgi};
cgiconnect(@_)
}
sub cgiconnect {# Connect CGI
my $s =shift;
no warnings;
local $^W =0;
$ENV{HTTP_USER_AGENT} =$ENV{HTTP_USER_AGENT}||'';
$ENV{PERLXS} ='PerlIS' if !$ENV{PERLXS} && ($^O eq 'MSWin32') && $0 =~/[\\\/]perlis\.dll$/i;
lib/ARSObject.pm view on Meta::CPAN
}
$s->{-cgi}
}
sub cgipar { # CGI parameter
$_[0]->{-cgi}->param(@_[1..$#_])
}
sub cgiurl { # CGI script URL
local $^W =0; # $ENV{PATH_INFO}
if ($#_ >0) {
my $v =($_[0]->{-cgi}||$_[0]->cgi)->url(@_[1..$#_]);
if ($v) {}
elsif (!($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {}
lib/ARSObject.pm view on Meta::CPAN
return($v)
}
}
sub cgitext { # CGI textarea field
$_[0]->{-cgi}->textarea(@_[1..$#_])
# -default=>$v, -override=>1
}
sub cgistring { # CGI string field
$_[0]->{-cgi}->textfield(@_[1..$#_])
}
sub cgiselect { # CGI selection field composition
# -onchange=>1 reloads form
my ($s, %a) =@_;
my $cs =$a{-onchange} && (length($a{-onchange}) ==1);
($cs
? '<input type="hidden" name="' .$a{-name} .'__C_" value="" />'
lib/ARSObject.pm view on Meta::CPAN
? '<script for="window" event="onload">window.document.forms[0].' .$a{-name} .'.focus()</script>'
: '')
}
sub cgiddlb { # CGI drop-down listbox field composition
# -strict=> - disable text edit, be alike cgiselect
my ($s, %a) =@_;
$s->cgi();
my $n =$a{-name};
my $nl="${n}__L_";
lib/ARSObject.pm view on Meta::CPAN
))
)
}
sub cgiesc { # escape strings to html
$_[0]->{-cgi}->escapeHTML(@_[1..$#_])
}
sub cgitfrm { # table form layot
# -form =>{form attrs}, -table=>{table attrs}, -tr=>{tr attrs}, -td=>{}, -th=>{}
my ($s, %a) =$_[0];
my $i =1;
while (ref($_[$i]) ne 'ARRAY') {$a{$_[$i]} =$_[$i+1]; $i +=2};
$s->cgi->start_form(-method=>'POST',-action=>'', $a{-form} ? %{$a{-form}} : ())
lib/ARSObject.pm view on Meta::CPAN
} @_[$i..$#_])) ."\n"
.$s->cgi->end_form()
}
sub smtpconnect {# Connect SMTP
set(@_); # (-smtphost) -> self->{-smtp}
set($_[0],-die=>'Carp') if !$_[0]->{-die};
my $s =shift;
no warnings;
local $^W =0;
lib/ARSObject.pm view on Meta::CPAN
if !$s->{-smtp} ||$@;
$s->{-smtp}
}
sub smtp { # SMTP connection object
return($_[0]->{-smtp}) if $_[0]->{-smtp};
smtpconnect(@_)
}
sub smtpsend { # SMTP mail msg send
# -from||-sender, -to||-recipient,
# -data|| -subject + (-text || -html)
my ($s, %a) =@_;
return(&{$s->{-die}}("SMTP host not defined"))
if !$s->{-smtphost};
lib/ARSObject.pm view on Meta::CPAN
||return(&{$s->{-die}}("SMTP dataend -> " .($s->smtp->message()||'?')));
$r ||1;
}
sub soon { # Periodical execution of this script
# (minutes ||sub{}, ?log file, ?run command, ?soon command)
# minutes: undef - clear sched, run once || sub{} -> number
# log file: empty || full file name || var file name
# run command: empty || 'command line' || [command line] || sub{}
# soon command: empty || 'command line' || [command line] || []
lib/ARSObject.pm view on Meta::CPAN
$r
}
sub _sooncl { # soon() command line former
my ($s, $cs, $q) =@_;
my $nc;
my $qry =$cs;
if (ref($cs)) {
return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))
lib/ARSObject.pm view on Meta::CPAN
}
$qry
}
sub _sooncln { # soon() cleaner
my ($s, $mm, $lf, $cr, $cs, $strt) =@_;
$lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);
if (ref($cs) ? scalar(@$cs) : $cs) {
my $nc;
my $qry =_sooncl($s, $cs, 1);
lib/ARSObject.pm view on Meta::CPAN
}
1
}
sub cfpinit { # Field Player: init data structures
my ($s) =@_; # (self) -> self
$s->{-fphc} ={};
$s->{-fphd} ={};
my $dh ={};
my $dp =undef;
lib/ARSObject.pm view on Meta::CPAN
}
$s
}
sub cfpused { # Field Player: field should be used?
# (self, field) -> yes?
my ($s, $f) =@_;
return(map {ref($_) && cfpused($s, $_) ? $_ : ()} @{$s->{-fpl}})
if !$f;
$f =$s->{-fphc}->{$f} ||$s->{-fphd}->{$f}
lib/ARSObject.pm view on Meta::CPAN
: ($f->{-unused} && 1)
)
}
sub cfpn { # Field Player: field name
# (self, field || fieldname) -> cgi field name
ref($_[1])
? $_[1]->{-namecgi}
: (($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]} ||{})->{-namecgi} ||$_[1])
}
sub cfpnd { # Field Player: field name
# (self, field || fieldname) -> db field name
ref($_[1])
? $_[1]->{-namedb}
: (($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]} ||{})->{-namedb} ||$_[1])
}
sub cfpv { # Field Player: field value
# (self, field || fieldname) -> value
my $f =ref($_[1])
? $_[1]
: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
!$f
lib/ARSObject.pm view on Meta::CPAN
: undef)
: $_[0]->{-cgi}->param($f->{-namecgi})
}
sub cfpvl { # Field Player: field values list
# (self, field || fieldname) -> [list]
my $f =ref($_[1])
? $_[1]
: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
!$f
lib/ARSObject.pm view on Meta::CPAN
&{$f->{-values}}($_[0], $f, $_)})
: $f->{-values}
}
sub cfpvv { # Field Player: field value or default
# (self, field || fieldname) -> value
my $v =cfpv(@_);
defined($v) ? $v : cfpvd(@_)
}
sub cfpvd { # Field Player: field default value
# (self, field || fieldname) -> value
my $f =ref($_[1])
? $_[1]
: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
!$f
lib/ARSObject.pm view on Meta::CPAN
? cfpvv($_[0], @{$f->{-value}})
: $f->{-value}
}
sub cfpvp { # Field Player: field previous value
# (self, field || fieldname) -> value
$_[0]->{-cgi}->param((ref($_[1])
? $_[1]->{-namecgi} ||''
: (($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]} ||{})->{-namecgi} ||$_[1])
) .'__PV_')
}
sub cfpvc { # Field Player: field value changed since form open?
# (self, field || fieldname) -> changed?
my ($v1, $v0) =(cfpv(@_), cfpvp(@_));
defined($v1) && defined($v0)
? $v1 ne $v0
: !defined($v1) && !defined($v0)
? 0
: 1
}
sub cfpvcc { # Field Player: field value changed in the last form submit?
# (self, field || fieldname) -> changed?
my $f =ref($_[1])
? $_[1]
: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
my $fn =ref($f) ? $f->{-namecgi} ||'' : '';
lib/ARSObject.pm view on Meta::CPAN
? $_[0]->{-cgi}->param("${fn}__C_") ||!defined($_[0]->{-cgi}->param("${fn}__C_"))
: cfpvc(@_)
}
sub cfpaction { # Field Player: execute action
# (self, {action}||'action'
# , '-preact'||'-action', {key field}) -> success
my ($s, $act, $ord, $rp, $f) =@_;
my $r =1;
my $af=ref($act) eq 'HASH' ? $act : {};
lib/ARSObject.pm view on Meta::CPAN
}
$r
}
sub cfprun { # Field Player: run
# (self, msg sub{}
# , form row sub{}, form top, form bottom) -> success
my ($s, $cmsg, $cfld, $cfld0, $cfld1) =@_;
my $hmsg =ref($cmsg) eq 'HASH'
? $cmsg
ARSperl
view release on metacpan or search on metacpan
# Routines for grabbing the current error message "stack"
# by simply referring to the $ars_errstr scalar.
package ARS::ERRORSTR;
sub TIESCALAR {
bless {};
}
sub FETCH {
my($s, $i) = (undef, undef);
my(%mTypes) = ( 0 => "OK", 1 => "WARNING", 2 => "ERROR", 3 => "FATAL",
4 => "INTERNAL ERROR",
-1 => "TRACEBACK");
for($i = 0; $i < $ARS::ars_errhash{numItems}; $i++) {
# definitions required for backwards compatibility
if (!defined &ARS::AR_IMPORT_OPT_CREATE) {
eval 'sub AR_IMPORT_OPT_CREATE { 0; }';
}
if (!defined &ARS::AR_IMPORT_OPT_OVERWRITE) {
eval 'sub AR_IMPORT_OPT_OVERWRITE { 1; }';
}
bootstrap ARS $ARS::VERSION;
tie $ARS::ars_errstr, ARS::ERRORSTR;
'ESCL_FIELDS_FLTAPI', 73,
'WRITE_RESTRICTED_READ', 74
);
sub new {
require 'ARS/OOform.pm';
require 'ARS/OOmsgs.pm';
require 'ARS/OOsup.pm';
return newObject( @_ );
}
# interfaces.
#
# RETURNS
# array of menu items.
sub ars_simpleMenu {
my($m) = shift;
my($prepend) = shift;
my(@m) = @$m;
my(@ret, @submenu);
my($name, $val);
#
# RETURNS
# a new scalar on success
# undef on error
sub ars_padEntryid {
my($c) = shift;
my($schema) = shift;
my($entry_id) = shift;
my($field);
# $retval[1]->{TIME} = the time that this enum was last selected
#
# You can map from enum values to selection words by using
# arsGetField().
sub ars_decodeStatusHistory {
my ($sval) = shift;
my ($enum) = 0;
my ($pair, $ts, $un);
my (@retval);
#
# RETURNS
# an encoded diary string (scalar) on success
# undef on failure
sub ars_EncodeDiary {
my ($diary_string) = undef;
my ($entry);
foreach $entry (@_) {
$diary_string .= $entry->{timestamp}.pack("c",4).$entry->{user}.pack("c",4).$entry->{value};
$diary_string .= pack("c",3) if ($diary_string);
}
return $diary_string;
}
sub insertValueForCurrentTransaction {
my ($c, $s, $q) = (shift, shift, shift);
die Carp::longmess("Usage: insertValueForCurrentTransaction(ctrl, schema, qualifier, ...)\n")
if(!defined($q));
print "walktree..\n";
walkTree($q);
exit 0;
}
sub walkTree {
my $q = shift;
print "($q) ";
if(defined($q->{'oper'})) {
print "oper: ".$q->{'oper'}."\n";
if($q->{'oper'} eq "not") {
dumpHash ($q->{$_}) if(ref($q->{$_}) eq "HASH");
}
}
}
sub dumpHash {
my $h = shift;
foreach (keys %$h) {
print "key: ", $_,"\n";
print "val: ", $h->{$_},"\n";
dumpHash($h->{$_}) if(ref($h->{$_}) eq "HASH");
# if it's specified:
# menuType must be "query"
# qualifier must compile against the form that the menu
# is written for.
sub ars_GetCharMenuItems {
my ($ctrl, $menuName, $qual) = (shift, shift, shift);
if(defined($qual)) {
my $menu = ars_GetCharMenu($ctrl, $menuName);
die "ars_GetCharMenuItems failed: $ARS::ars_errstr"
return ars_ExpandCharMenu2($ctrl, $menuName, $qual);
}
return ars_ExpandCharMenu2($ctrl, $menuName);
}
sub ars_ExpandCharMenu {
return ars_ExpandCharMenu2(@_);
}
# encodes status history from the same format
# as returned by ars_decodeStatusHistory()
sub ars_encodeStatusHistory {
my @sh = ();
while(my $hr = shift) {
push @sh, $hr->{USER} ? "$hr->{TIME}\cD$hr->{USER}" : "";
}
join "\cC", @sh;
}
sub ars_SetOverlayGroup {
my ($ctrl, $value) = (shift, shift);
ars_SetSessionConfiguration($ctrl, 12, $value);
ars_SetSessionConfiguration($ctrl, 13, $value);
}
sub ars_SwitchToBaseMode {
my $ctrl = shift;
ars_SetOverlayGroup($ctrl, 0);
}
sub ars_SwitchToBestPracticeMode {
my $ctrl = shift;
ars_SetOverlayGroup($ctrl, 1);
}
# As of ARS4.0, these routines (which call ARInitialization and ARTermination)
ASNMTAP
view release on metacpan or search on metacpan
applications/archive.pl view on Meta::CPAN
my $currentEpoch = get_epoch ('today'); # time() or Current epoch date
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub print_help ();
sub print_usage ();
Getopt::Long::Configure('bundling');
GetOptions (
"A:s" => \$opt_A, "archivelist:s" => \$opt_A,
applications/archive.pl view on Meta::CPAN
my ($rc) = send_email_report (*EMAILREPORT, $emailReport, $rvOpen, $prgtext, $debug);
exit;
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub archiveCommentsAndEventsTables {
my ($eventsAgo, $commentsAgo) = @_;
print EMAILREPORT "\nArchive '$SERVERTABLCOMMENTS' and '$SERVERTABLEVENTS' tables:\n--------------------------------------------------\n" unless ( $debug );
# Init parameters
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub checkTableDBI {
my ($dbh, $database, $table, $op, $msg_type, $msg_text) = @_;
print "-> <$database.$table>, <$op>, <$msg_type>, <$msg_text>\n" if ($debug);
my ($Table, $Op, $Msg_type, $Msg_text) = '';
applications/archive.pl view on Meta::CPAN
return ($rv);
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub createCommentsAndEventsArchiveTables {
my ($daysBefore) = @_;
print EMAILREPORT "\nCreate '$SERVERTABLCOMMENTS' and '$SERVERTABLEVENTS' tables when needed:\n--------------------------------------------------\n" unless ( $debug );
# Init parameters
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub doBackupCsvSqlErrorWeekDebugReport {
my ($RESULTSPATH, $DEBUGDIR, $REPORTDIR, $gzipEpoch, $removeAllNokEpoch, $removeGzipEpoch, $removeDebugEpoch, $removeReportsEpoch, $removeWeeksEpoch, $firstDayOfWeekEpoch, $yesterdayEpoch, $currentEpoch) = @_;
print EMAILREPORT "\nDo backup, csv, sql, error, week, and debug files:\n--------------------------------------------------\n" unless ( $debug );
my ($darchivelist, $dtest, $pagedir, $ttest, $command, $rvOpendir, $path, $filename, $debugPath, $debugFilename, $reportPath, $reportFilename, $weekFilename);
my @files = ();
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub removeAllNokgzipCsvSqlErrorWeekFilesOlderThenAndMoveToBackupShare {
my ($gzipEpoch, $removeAllNokEpoch, $removeGzipEpoch, $removeDebugEpoch, $removeWeeksEpoch, $catalogID_uKey, $command, $path, $filename) = @_;
my ($datum, $staart) = split(/\-/, $filename, 2);
if ( $staart ) {
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub catAllCsvFilesYesterdayWeek {
my ($firstDayOfWeekEpoch, $yesterdayEpoch, $catalogID_uKey, $command, $path, $weekFilename, $filename) = @_;
for (my $loop = $firstDayOfWeekEpoch; $loop <= $yesterdayEpoch; $loop += 86400) {
if ($filename eq get_yearMonthDay($loop)."-$command-$catalogID_uKey-csv.txt") {
my $rvOpen = open(CAT, ">>$path/$weekFilename");
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub gzipOrRemoveHttpDumpDebug {
my ($gzipDebugEpoch, $removeDebugEpoch, $debugPath, $debugFilename) = @_;
my ($suffix, $extentie, $datum, $restant);
print "<$debugFilename>\n" if ($debug);
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub removeCgisessFiles {
my ($removeCgisessEpoch) = @_;
my $emailreport = "\nRemove cgisess files:\n---------------------\n";
if ( $debug ) { print "$emailreport"; } else { print EMAILREPORT "$emailreport"; }
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub removeOldReportFiles {
my ($removeReportsEpoch, $removeGzipEpoch, $reportPath, $reportFilename) = @_;
my ($suffix, $prefix, $datum, $plugin, $restant, $extentie);
($suffix, $prefix) = split(/\.pl/, $reportFilename, 2);
($datum, $plugin) = split(/\-/, $suffix, 2) if (defined $suffix);
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub errorTrapDBI {
my ($error_message, $debug) = @_;
print EMAILREPORT " DBI Error:\n", $error_message, "\nERROR: $DBI::err ($DBI::errstr)\n";
return 0;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub print_usage () {
print "Usage: $PROGNAME [-A <archivelist>] [-c F|T] [-r F|T] [-d F|T] [-y <years ago>] [-f F|T] [-D <debug>] [-V version] [-h help]\n";
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub print_help () {
print_revision($PROGNAME, $version);
print "ASNMTAP Archiver for the '$APPLICATION'
-A, --archivelist=<filename>
FILENAME : filename from the archivelist for the html output loop (default undef)
ASP-NextLink
view release on metacpan or search on metacpan
NextLink.pm view on Meta::CPAN
use CGI::Carp;
use vars qw( $VERSION );
$VERSION = '0.11';
sub new {
my $class = shift;
die "Cannot call class method on an object" if ref $class;
my $linkfile = $main::Server->MapPath( shift );
my $self = {};
bless $self, $class;
$self->parse_linkfile( $linkfile );
$self;
}
sub parse_linkfile {
my ($self, $linkfile, $idx) = (shift, shift, 0);
die "Cannot call object method on class" unless ref $self;
open LNX, "<$linkfile" or die "Can't open $linkfile: $!\n";
while ( <LNX> ) {
chomp;
NextLink.pm view on Meta::CPAN
my $count = $nl->GetListCount();
=cut
sub GetListCount {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
$self->{_count};
}
NextLink.pm view on Meta::CPAN
Index of the current page in the link file.
=cut
sub GetListIndex {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
$self->{_url}{$ENV{SCRIPT_FILENAME}}
or die "Current page not found in $self->{_file}";
}
NextLink.pm view on Meta::CPAN
URL of the previous page in the link file.
=cut
sub GetPreviousURL {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex - 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[0] : undef;
NextLink.pm view on Meta::CPAN
Description of the previous page in the link file.
=cut
sub GetPreviousDescription {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex - 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[1] : undef;
NextLink.pm view on Meta::CPAN
URL of the next page in the link file.
=cut
sub GetNextURL {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex + 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[1] : undef;
NextLink.pm view on Meta::CPAN
Description of the next page in the link file.
=cut
sub GetNextDescription {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex + 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[1] : undef;
NextLink.pm view on Meta::CPAN
URL of the nth page in the link file.
NOTE: Index is 1-based, NOT zero-based.
=cut
sub GetNthURL {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = shift;
$self->{_idx}{$idx}[0];
}
NextLink.pm view on Meta::CPAN
Description of the nth page in the link file.
NOTE: Index is 1-based, NOT zero-based.
=cut
sub GetNthDescription {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = shift;
$self->{_idx}{$idx}[1];
}
ASP
view release on metacpan or search on metacpan
my ($APACHE, $WIN32);
$APACHE = $Apache::ASP::VERSION;
$WIN32 = $^O =~ /win/i;
package ASP::IO;
sub TIEHANDLE { shift->new(@_) }
sub PRINT { shift->print(@_) }
sub PRINTF { shift->print(sprintf(@_)) }
sub new { bless {}, shift; }
sub print {
my $self = shift;
ASP::Print(@_);
1;
}
$VERSION='1.07';
$ASPOUT = tie *RESPONSE_FH, 'ASP::IO';
select RESPONSE_FH unless $APACHE;
$SIG{__WARN__} = sub { ASP::Print(@_) };
sub _END { &$_() for @DeathHooks; @DeathHooks = (); 1; }
=head1 NAME
ASP - a Module for ASP (PerlScript) Programming
C<Warn> is an alias for the ASP::Print method described below. The
overloading of C<warn> as described above does not currently work
in Apache::ASP, so this is provided.
=cut
sub Warn { ASP::Print(@_); }
=head2 print LIST
C<print> is overloaded to write to the browser by default. The inherent
behavior of print has not been altered and you can still use an alternate
NB: C<print> calls Print, so you could use either, but
print more closely resembles perl.
=cut
sub Print {
for (@_) {
if ( length($_) > 128000 ) {
ASP::Print( unpack('a128000a*', $_) );
} else {
$main::Response->Write($_);
Output is displayed between HTML comments so the output doesn't
interfere with page aesthetics.
=cut
sub DebugPrint { ASP::Print("<!--\n", @_, "\n-->"); }
=head2 HTMLPrint LIST
The same as C<Print> except the output is HTML-encoded so that
any HTML tags appear as sent, i.e. E<lt> becomes <, E<gt> becomes > etc.
=cut
sub HTMLPrint { map { ASP::Print($main::Server->HTMLEncode($_)) } @_ ; }
=head2 die LIST
Prints the contents of LIST to the browser and then exits. die
automatically calls $Response->End for you, it also executes any
cleanup code you have added with C<AddDeathHook>.
=cut
sub die {
ASP::Print(@_, "</BODY></HTML>");
_END;
$main::Response->End();
CORE::die();
}
Exits the current script. $Response->End is called automatically for you.
Any cleanup code added with C<AddDeathHook> is also called.
=cut
sub exit {
_END;
$main::Response->End();
CORE::exit();
}
Escapes (URL-encodes) a list. Uses ASP object method
$Server->URLEncode().
=cut
sub escape { map { $main::Server->URLEncode($_) } @_; }
=head2 unescape LIST
Unescapes a URL-encoded list. Algorithms ripped from CGI.pm
method of the same name.
=cut
sub unescape {
map {
tr/+/ /;
s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
} @_;
}
If passed an array reference, escapeHTML will return a reference
to the escaped array.
=cut
sub escapeHTML {
my ($flag, @args) = (0, @_);
@args = @{$args[0]} and $flag++ if ref $args[0] eq "ARRAY";
$_ = $main::Server->HTMLEncode($_) for @args;
$flag ? \@args : @args;
}
If passed an array reference, unescapeHTML will return a reference
to the un-escaped array.
=cut
sub unescapeHTML {
my ($flag, @args) = (0, @_);
@args = @{$args[0]} and $flag++ if ref $args[0] eq "ARRAY";
map {
s/&/&/gi;
s/"/"/gi;
NOTE: Under Apache::ASP, param() simply passes the arguments
to CGI::param() because Apache::ASP doesn't support the $obj->{Count}
property used in this function.
=cut
sub param {
if ($APACHE) {
return (wantarray) ? (CGI::param(@_)) : scalar(CGI::param(@_));
}
unless (@_) {
my @keys;
$obj->{Count} property used in this function.
=cut
sub param_count {
if ($APACHE) {
return scalar( @{[ CGI::param($_[0]) ]} );
}
if ($main::Request->ServerVariables('REQUEST_METHOD')->Item eq 'GET') {
return $main::Request->QueryString($_[0])->{Count};
<%
my $conn = Win32::OLE-new('ADODB.Connection');
$conn->Open("MyDSN");
$conn->BeginTrans();
ASP::AddDeathHook( sub { $Conn->Close if $Conn; } );
%>
Death hooks are not executed except by explicitly calling the die() or exit()
methods provided by ASP.pm.
AddDeathHook is not exported.
=cut
sub AddDeathHook { push @DeathHooks, @_; }
# These two functions are ripped from CGI.pm
sub expire_calc {
my($time) = @_;
my(%mult) = ('s'=>1,
'm'=>60,
'h'=>60*60,
'd'=>60*60*24,
ASP4-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
goto &{$self->can('call')};
}
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
ASP4
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
goto &{$self->can('call')};
}
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
ASP4x-Captcha-Imager
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
goto &{$self->can('call')};
}
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
ASP4x-Linker
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
goto &{$self->can('call')};
}
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
ASP4x-Router
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
goto &{$self->can('call')};
}
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
( run in 0.934 second using v1.01-cache-2.11-cpan-a5abf4f5562 )