Result:
found more than 191 distributions - search limited to the first 2001 files matching your query
( run in 1.081 )
API-Plesk
view release on metacpan or search on metacpan
lib/API/Plesk.pm view on Meta::CPAN
init_components(
# new
customer => [['1.6.3.0', 'Customer']],
webspace => [['1.6.3.0', 'Webspace']],
site => [['1.6.3.0', 'Site']],
subdomain => [['1.6.3.0', 'Subdomain']],
site_alias => [['1.6.3.0', 'SiteAlias']],
sitebuilder => [['1.6.3.0', 'SiteBuilder']],
ftp_user => [['1.6.3.0', 'FTPUser']],
service_plan => [['1.6.3.0', 'ServicePlan']],
service_plan_addon => [['1.6.3.0', 'ServicePlanAddon']],
lib/API/Plesk.pm view on Meta::CPAN
Accounts => [['1.5.0.0', 'Accounts']],
Domains => [['1.5.0.0', 'Domains']],
);
# constructor
sub new {
my $class = shift;
$class = ref ($class) || $class;
my $self = {
username => '',
lib/API/Plesk.pm view on Meta::CPAN
return bless $self, $class;
}
# sends request to Plesk API
sub send {
my ( $self, $operator, $operation, $data, %params ) = @_;
confess "Wrong request data!" unless $data && ref $data;
my $xml = { $operator => { $operation => $data } };
lib/API/Plesk.pm view on Meta::CPAN
response => $response,
error => $error,
);
}
sub bulk_send { confess "Not implemented!" }
# Send xml request to plesk api
sub xml_http_req {
my ($self, $xml) = @_;
# HTTP::Request undestends only bytes
utf8::encode($xml) if utf8::is_utf8($xml);
lib/API/Plesk.pm view on Meta::CPAN
$ua->ssl_opts(verify_hostname => 0) if $ua->can('ssl_opts');
warn $req->as_string if defined $self->{debug} && $self->{debug} > 1;
my $res = eval {
local $SIG{ALRM} = sub { die "connection timeout" };
alarm $self->{timeout};
$ua->request($req);
};
alarm 0;
lib/API/Plesk.pm view on Meta::CPAN
('', $res->status_line);
}
# renders xml packet for request
sub render_xml {
my ($self, $hash) = @_;
my $xml = _render_xml($hash);
$xml = qq|<?xml version="1.0" encoding="UTF-8"?><packet version="$self->{api_version}">$xml</packet>|;
$xml;
}
# renders xml from hash
sub _render_xml {
my ( $hash ) = @_;
return $hash unless ref $hash;
my $xml = '';
lib/API/Plesk.pm view on Meta::CPAN
$xml;
}
# initialize components
sub init_components {
my ( %c ) = @_;
my $caller = caller;
for my $alias ( keys %c ) {
my $classes = $c{$alias};
my $sub = sub {
my( $self ) = @_;
$self->{"_$alias"} ||= $self->load_component($classes);
return $self->{"_$alias"} || confess "Not implemented!";
};
no strict 'refs';
*{"$caller\::$alias"} = $sub;
}
}
# loads component package and creates object
sub load_component {
my ( $self, $classes ) = @_;
my $version = version->parse($self->{api_version});
for my $item ( @$classes ) {
API-PleskExpand
view release on metacpan or search on metacpan
lib/API/PleskExpand.pm view on Meta::CPAN
=head1 DESCRIPTION
At present the module provides interaction with Plesk Expand 2.2.4 (API 2.2.4.1). Complete support of operations with Accounts, partial support of work with domains. Support of addition of domains to user Accounts.
API::PleskExpand module gives the convenient interface for addition of new functions. Extensions represent modules in a folder Plesk with definitions of demanded functions. Each demanded operation is described by two functions: op and op_response_par...
For example, here the set of subs in the Accounts module is those.
create / create_response_parse
modify / modify_response_parse
delete / delete_response_parse
get / get_response_parse
lib/API/PleskExpand.pm view on Meta::CPAN
=cut
sub new {
(undef) = shift @_;
my $self = __PACKAGE__->SUPER::new(@_);
$self->{package_name} = __PACKAGE__;
unless ($self->{api_version}) {
lib/API/PleskExpand.pm view on Meta::CPAN
Example:
my $res = $expand_client->Func_Module->operation_type(%params);
# Func_Module -- module in API/PleskExpand folder
# operation_type -- sub which defined in Func_Module.
# params hash used as @_ for operation_type sub.
=back
=cut
# OVERRIDE, INSTANCE(xml_request)
sub _execute_query {
my ($self, $xml_request) = @_;
# packet version override for
my $packet_version = $self->{'api_version'};
API-PureStorage
view release on metacpan or search on metacpan
lib/API/PureStorage.pm view on Meta::CPAN
our %ENV;
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
my $debug = 0;
sub new {
my $class = shift @_;
my $self = {
cookie_file => '/tmp/cookies.txt',
host => $_[0],
token => $_[1]
lib/API/PureStorage.pm view on Meta::CPAN
my $ret = $self->_api_post("/api/$api_version/auth/session", { api_token => $self->{token} });
return $self;
}
sub DESTROY {
my $self = shift @_;
my $ret = $self->{client}->DELETE("/api/$self->{api_version}/auth/session") if defined $self->{api_version};
unlink $self->{cookie_file};
}
### Methods
sub array_info {
my $self = shift @_;
my $ref = $self->_api_get("/api/$self->{api_version}/array?space=true");
return wantarray ? @$ref : $ref;
}
sub volume_detail {
my $self = shift @_;
my $name = shift @_;
my $ref = $self->_api_get("/api/$self->{api_version}/volume/".$name);
return wantarray ? @$ref : $ref;
}
sub volume_info {
my $self = shift @_;
my $ref = $self->_api_get("/api/$self->{api_version}/volume?space=true");
return wantarray ? @$ref : $ref;
}
sub version {
my $self = shift @_;
my $ref = $self->_api_get('/api/api_version');
return wantarray ? @{$ref->{version}} : $ref->{version};
}
### Subs
sub _api_get {
my $self = shift @_;
my $url = shift @_;
my $ret = $self->{client}->GET($url);
my $num = $ret->responseCode();
my $con = $ret->responseContent();
lib/API/PureStorage.pm view on Meta::CPAN
}
print 'DEBUG: GET ', $url, ' -> ', $num, ":\n", Dumper(from_json($con)), "\n" if $debug;
return from_json($con);
}
sub _api_post {
my $self = shift @_;
my $url = shift @_;
my $data = shift @_;
my $ret = $self->{client}->POST($url, to_json($data));
my $num = $ret->responseCode();
API-ReviewBoard
view release on metacpan or search on metacpan
ReviewBoard.pm view on Meta::CPAN
print "*****************************************************\n";
print " UnitTest to exercise ReviewBoard Class API's \n";
print " Author: chetang\@cpan.org \n";
print "*****************************************************\n\n";
my $submitter = $rb->getSubmitter(changenum => '13638134');
print "Review Submitted by:\n", @$submitter, "\n\n";
my $reviewlink = $rb->getReviewBoardLink(changenum => '13027232');
print "Review Board Link:\n",$reviewlink,"\n\n";
my $description = $rb->getReviewDescription(changenum => '13027232');
ReviewBoard.pm view on Meta::CPAN
print "No of outgoing Review Requests by user 'users':\n",$outgoingreviews,"\n\n";
my $reviewsbydate = $rb->getOutgoingReviewsCountByDate(user => 'users', startdate => '2011-03-01', enddate => '2011-03-30');
print "No of outgoing Review Requests by user 'users' during time interval:\n", $reviewsbydate, "\n\n";
my $reviewsbystatus = $rb->getOutgoingReviewsCountByStatus(user => 'users', status => 'submitted');
print "No of outgoing Review Requests by user 'users' in state submitted:\n", $reviewsbystatus, "\n\n";
my $incomingreviews = $rb->getIncomingReviewsCount(user => 'users');
print "No of incoming review requests made to user:\n", $incomingreviews, "\n\n";
=head1 DESCRIPTION
C<API::ReviewBoard> provides an interface to work with the exported ReviewBoard 2.0 APIs.
You can choose to either subclass this module, and thus using its
accessors on your own module, or to store an C<API::ReviewBoard>
object inside your own object, and access the accessors from there.
See the C<SYNOPSIS> for examples.
=head1 METHODS
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
}
=head2 $rb->getSubmitter(changenum => '112345');
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
$self->{_cookie_jar}->add_cookie_header($request);
my $response = $self->{_useragent}->simple_request($request);
my $xml = $response->as_string;
$xml =~ m/.*"submitter": (.*), "screenshots".*/;
my $name = $1;
my @arr;
my $count = @arr = $name =~ /"title": "(\w+)"/g;
my $submitter = \@arr;
return ($submitter);
}
=head2 $rb->getSummary(changenum => '112345');
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
}
=head2 $rb->getOutgoingReviewsCountByStatus(user => 'abdcde', status => 'all | pending |submitted | discarded' );
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
lib/API/Stripe.pm view on Meta::CPAN
The refunds method returns a new instance representative of the API
I<Refunds> resource requested. This method accepts a list of path
segments which will be used in the HTTP request. The following documentation
can be used to find more information. L<https://stripe.com/docs/api#refunds>.
=head2 subscriptions
$stripe->subscriptions;
The subscriptions method returns a new instance representative of the API
I<Subscriptions> resource requested. This method accepts a list of path
segments which will be used in the HTTP request. The following documentation
can be used to find more information. L<https://stripe.com/docs/api#subscriptions>.
=head2 tokens
$stripe->tokens;
API-Trello
view release on metacpan or search on metacpan
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
accompany that operating system.
4. You may not copy, modify, sublicense, distribute or transfer the
Program except as expressly provided under this General Public License.
Any attempt otherwise to copy, modify, sublicense, distribute or transfer
the Program is void, and will automatically terminate your rights to use
the Program under this License. However, parties who have received
copies, or rights to use copies, from you under this General Public
License will not have their licenses terminated so long as such parties
remain in full compliance.
on the Program) you indicate your acceptance of this license to do so,
and all its terms and conditions.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the original
licensor to copy, distribute or modify the Program subject to these
terms and conditions. You may not impose any further restrictions on the
recipients' exercise of the rights granted herein.
7. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
6. The scripts and library files supplied as input to or produced as output
from the programs of this Package do not automatically fall under the copyright
of this Package, but belong to whomever generated them, and may be sold
commercially, and may be aggregated with this Package.
7. C or perl subroutines supplied by you and linked into this Package shall not
be considered part of this Package.
8. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
API-Twitter
view release on metacpan or search on metacpan
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
accompany that operating system.
4. You may not copy, modify, sublicense, distribute or transfer the
Program except as expressly provided under this General Public License.
Any attempt otherwise to copy, modify, sublicense, distribute or transfer
the Program is void, and will automatically terminate your rights to use
the Program under this License. However, parties who have received
copies, or rights to use copies, from you under this General Public
License will not have their licenses terminated so long as such parties
remain in full compliance.
on the Program) you indicate your acceptance of this license to do so,
and all its terms and conditions.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the original
licensor to copy, distribute or modify the Program subject to these
terms and conditions. You may not impose any further restrictions on the
recipients' exercise of the rights granted herein.
7. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
6. The scripts and library files supplied as input to or produced as output
from the programs of this Package do not automatically fall under the copyright
of this Package, but belong to whomever generated them, and may be sold
commercially, and may be aggregated with this Package.
7. C or perl subroutines supplied by you and linked into this Package shall not
be considered part of this Package.
8. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
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
lib/API/Wunderlist.pm view on Meta::CPAN
The reminders method returns a new instance representative of the API
I<Reminder> resource requested. This method accepts a list of path
segments which will be used in the HTTP request. The following documentation
can be used to find more information. L<https://developer.wunderlist.com/documentation/endpoints/reminder>.
=head2 subtasks
$wunderlist->subtasks;
The subtasks method returns a new instance representative of the API
I<Subtask> resource requested. This method accepts a list of path
segments which will be used in the HTTP request. The following documentation
can be used to find more information. L<https://developer.wunderlist.com/documentation/endpoints/subtask>.
=head2 task_comments
$wunderlist->task_comments;
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
$Data::Dumper::Indent = 1;
=head1 NAME
APP::REST::ParallelMyUA -
provide a subclassed UserAgent to override on_connect, on_failure and
on_return methods
=head1 VERSION
Version 0.03
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
#-------------------------------------------------------------
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
foreach my $key (keys %INC) {
inc/Module/Install.pm view on Meta::CPAN
local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{'inc/Module/Install.pm'};
delete $INC{'Module/Install.pm'};
# Save to the singleton
$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});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
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(@_);
return $self;
}
## 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' }
lib/ARGV/OrDATA.pm view on Meta::CPAN
input is usually small and I don't want to waste time by saving it
into a file.
=head1 EXPORT
Nothing. There are 2 subroutines you can call via their fully qualified names,
though:
=over 4
=item ARGV::OrDATA::is_using_argv()
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);
push @$list, $substruct->{ struct };
@args = @{ $substruct->{ leftover } };
} elsif($token eq '{') {
my $substruct = $self->_parse_hash(@args);
push @$list, $substruct->{ struct };
@args = @{ $substruct->{ leftover } };
} elsif ($token eq ']') {
return { struct => $list, leftover => [ @args ] };
} else {
push @$list, $token;
}
}
die "Unclosed list";
};
sub _parse_hash {
my ($self, @args) = @_;
my $hash = {};
while (my $token = shift @args) {
if ($token eq '}') {
return { struct => $hash, leftover => [ @args ] };
}
my ($k, $v) = ($token, shift @args);
substr($k,-1,1) = '' if (substr($k,-1,1) eq ':');
die "Repeated $k in hash" if (exists $hash->{ $k });
die "Key $k doesn't have a value" if (not defined $v);
if ($v eq '{'){
my $substruct = $self->_parse_hash(@args);
$hash->{ $k } = $substruct->{ struct };
@args = @{ $substruct->{ leftover } };
} elsif ($v eq '[') {
my $substruct = $self->_parse_list(@args);
$hash->{ $k } = $substruct->{ struct };
@args = @{ $substruct->{ leftover } };
} else {
$hash->{ $k } = $v;
}
}
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;';
lib/ARS/Simple.pm view on Meta::CPAN
else
{
if (defined $config{user})
{
my $s = pack('H*', $config{user});
my $x = substr($k, 0, length($s));
my $u = $s ^ $x;
$self->{persistant}{user} = $u;
}
else
{
lib/ARS/Simple.pm view on Meta::CPAN
else
{
if (defined $config{password})
{
my $s = pack('H*', $config{password});
my $x = substr($k, 0, length($s));
my $u = $s ^ $x;
$self->{persistant}{password} = $u;
}
else
{
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
# ,'fieldLbll'=>label localised
# ,'fieldLblc'=>label catenation/comment
# ,'fieldLbv' =>labels of values
# ,'fieldLbvl'=>labels of values localised
# ,'indexUnique'
# ,'strOut'|'strIn'=>sub(self,form,{field},$_=val){}
#,-meta-min # Used in 'arsmetamin' operation
#,-meta-sql # 'arsmetasql': {tableName}->{-cols}->{sqlName}=>{fieldName, sqlName,...}
# {tableName}->{-fields}->{fieldName}=>sqlName
# {tableName}->{-ids}->{fieldId}=>sqlName
# {-forms}->{formName}->{tableName}
lib/ARSObject.pm view on Meta::CPAN
,-metax => # Exclude field schema parameters from '-meta'
['displayInstanceList','permissions']
,-metaid => {} # Commonly used fields with common names and value translation
,-metadn => {} # {fieldId | fieldName =>
# {fieldName=>'name',FieldId=>id
# ,strIn=>sub(self,form,{field},$_=val){}
# ,strOut=>sub(self,form,{field},$_=val){}
# },...}
,-maxRetrieve => 0 # ARS::ars_GetListEntry(maxRetrieve)
,-entryNo => undef # Logical number of entry inserted
,-strFields => 1 # Translate fields data using 'strIn'/'strOut'/'-meta'?
# 1 - 'enumLimits', 2 - 'fieldLbvl' before 'enumLimits'
,-cmd =>'' # Command running, for err messages, script local $s->{-cmd}
,-die =>undef # Error die/warn, 'Carp' or 'CGI::Carp...'
# ,-diemsg => undef #
,-warn=>undef # , see set() and connect() below
# ,-warnmsg => undef #
,-cpcon=>undef # Translation to console codepage sub{}(self, args) -> translated
,-echo=>0 # Echo printout switch
,-dbi=>undef # DBI object, by dbiconnect()
,-dbiconnect =>undef #
,-cgi=>undef # CGI object, by cgi()
,-smtp=>undef
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_/;
$m =~s/^ars/ARS::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
eval('use ' .$a{-die} .';');
$s->{-die} =\&CGI::Carp::confess;
$s->{-warn}=\&CGI::Carp::carp;
if ($s->{-diemsg}) {
my $dm =$s->{-diemsg};
CGI::Carp::set_message(sub{&$dm(@_); $s->disconnect() if $s;})
}
}
elsif ($a{-die} =~/^CGI::Die/) {
eval('use Carp;');
$s->{-die} =\&Carp::confess;
$s->{-warn}=\&Carp::carp;
my $sigdie =$SIG{__DIE__};
$SIG{__DIE__} =sub{
return if ineval();
if ($s && $s->{-diemsg}) {
&{$s->{-diemsg}}(@_)
}
else {
lib/ARSObject.pm view on Meta::CPAN
$s =undef;
# $SIG{__DIE__} =$sigdie;
# &$sigdie(@_) if ref($sigdie) eq 'CODE';
# CORE::die($_[0]);
};
$SIG{__WARN__} =sub{
return if !$^W ||ineval();
if ($s && $s->{-warnmsg}) {
&{$s->{-warnmsg}}(@_)
}
else {
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 $_;
my ($r, @r);
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]) {
if (ref($_[2]) eq 'CODE') {
local $_;
local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
."vfdata('$_[1]', sub{})";
my ($rr, $v);
if (ref($_[0]->{$_[1]}) eq 'ARRAY') {
$rr =[];
for(my $i=0; $i<=$#{$_[0]->{$_[1]}}; $i++) {
if (!defined(eval{$v =&{$_[2]}($_[0], $_[1], $i, $_ =$_[0]->{$_[1]}->[$i])}) && $@) {
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,...}
my($s, $f, $k, $v, $e) =@_;
return(&{$s->{-die}}($s->efmt('Key name needed',undef,undef,'vfhash',$f))) if !$k;
$s->vfload($f, 1) if !$s->{$f} ||(ref($s->{$f}) eq 'CODE');
my $kk ="$f/$k";
if (!$s->{$kk}) {
lib/ARSObject.pm view on Meta::CPAN
}
if (ref($v) eq 'CODE') {
my ($rh, $t) =({});
local $_;
local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
."vfhash('$f', '$k', sub{})";
foreach my $ke (keys %{$s->{$kk}}) {
if (!defined(eval{$t =&$v($s, $f, $k, $_ =$s->{$kk}->{$ke})}) && $@) {
last if $@ =~/^last[\r\n]*$/;
next if $@ =~/^next[\r\n]*$/;
return(&{$s->{-die}}($s->efmt($@,$s->{-cmd})));
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 $_;
local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
."vfdistinct('$f', '$k', sub{})";
$s->vfload($f, 1) if !$s->{$f} ||(ref($s->{$f}) eq 'CODE');
if (ref($s->{$f}) eq 'ARRAY') {
for(my $i=0; $i<=$#{$s->{$f}}; $i++) {
if (!defined($s->{$f}->[$i]->{$k})) {
}
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');
}
else {
($n, $nn) =$v =~/^(.+?)_([A-Z]+)$/ ? ($1, $2) : ($v, '');
$nn ='_' .(!$nn ? 'A' : substr($nn,-1,1) eq 'Z' ? $nn .'A' : (substr($nn,0,-1) .chr(ord(substr($nn,-1,1)) +1)));
}
$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}
: $s->{-meta}->{$f}->{-fields}->{$ff};
$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
# Syntax:
# 'fieldId' || 'fieldName' - fields
lib/ARSObject.pm view on Meta::CPAN
#
# -fields => [{fieldId=>1, columnWidth=>9, separator=>"\t"},...
# ,[{fieldName=>name, width=>9},...
# ,[{field=>name|id, width=>9},...] # 128 bytes limit strings
# ||-fields => [fieldId | fieldName,...] # using ars_GetListEntryWithFields()
# ||-fields => '*' | 1 | '*-$', -xfields=>sub{} || [fieldName| fieldId,...]
# ||-fetch => '*' | 1 | [fieldId|fieldName,...] # using ars_GetEntry() for each record
# -order ||-sort => [fieldId, (1||2),...] # 1 - asc, 2 - desc
# [..., fieldName, field=>'desc', field=>'asc',...]
# -limit ||-max => maxRetrieve
# -first ||-start => firstRetrieve
# -for ||-foreach => sub(self, form, id|string, ?{record}){die "last\n", die "next\n"} -> self
# ?-echo=>1
#
# ars_GetListEntry(ctrl, schema, qualifier, maxRetrieve=0, firstRetrieve=0,...)
# ..., getListFields, sortList,...
# ars_LoadQualifier(ctrl, schema, qualifier string)
lib/ARSObject.pm view on Meta::CPAN
else {@r=($x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId},1); $x=undef if /^(asc|1)$/}
@r} @$v)
: ();
push @fs, $x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId}, 1
if $x}
my $q =$s->_qsubst('',$a{-qual} ||$a{-query} ||$a{-where}, $f);
$s->{-cmd} .=": subst(-from=>'$f'"
.(@$fl ? ',-fields=>' .join(', ', map {ref($_) ? "'" .$_->{fieldId} ."'(" .$_->{columnWidth} .")" : "'$_'"
} @$fl) : '')
.($q ? ",-where=>$q" : '')
.(@fs ? ',-order=>' .join(', ', map {"'$_'"} @fs) : '')
.")"
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 .=$1;
$q =$3;
if (!defined($q)) {
$q =''
}
elsif (substr($2,0,1) eq "'") {
if ($q =~/^([^']+)'(.*)/) {
$q =$2;
my $n =$1;
$r .="'" .($n =~/^\d+$/ ? $n : schdn($s,$f,$n)->{fieldId}) ."'";
}
else {
$r .="'"
}
}
else {
$r .=_qsubst($s, $2, $q, $f)
}
}
$r .=$q if defined($q);
}
elsif ($c eq '(') {
$r =$c;
while ($q =~/^(.*?)([()'"])(.*)/) {
$q =$3;
$r .=$1;
if ($2 eq ')') {$r .=$2; last}
else {$r .=_qsubst($s, $2, $q, $f)}
}
$_[2] =$q;
}
elsif ($c =~/['"]/) {
my $cq =$s->strquot($c);
$cq =substr($cq,1,-1);
$r =$c;
while ($q =~/^(.*?)(\Q$c\E|\Q$cq\E)(.*)/) {
$q =$3;
$r .=$1 .$2;
last if $2 eq $c;
lib/ARSObject.pm view on Meta::CPAN
if ($2 eq $c) {
push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r);
$r ='';
}
else {
$r .=_qsubst($s, $2, $q, $f);
}
}
$r .=$q;
push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r) if $r ne '';
return(@r)
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
$rw->{$f->{fieldName}} =!defined($r->{$f->{fieldName}})
? $r->{$f->{fieldName}}
: $f->{TYPE_NAME} eq 'datetime'
? strtime($s, $r->{$f->{fieldName}})
: ($f->{dataType} =~/^(?:char)$/) && $f->{COLUMN_SIZE}
? substr($r->{$f->{fieldName}}, 0, $f->{COLUMN_SIZE_DB} ||$f->{COLUMN_SIZE})
: $r->{$f->{fieldName}};
$rd->{$f->{COLUMN_NAME}} =$1
if $rd
&& defined($rd->{$f->{COLUMN_NAME}})
&& ($f->{TYPE_NAME} =~/^(?:datetime|float)$/)
lib/ARSObject.pm view on Meta::CPAN
? $1
: $rd->{$f->{COLUMN_NAME}}
if $rd
&& defined($rd->{$f->{COLUMN_NAME}})
&& ($f->{TYPE_NAME} eq 'float');
$rd->{$f->{COLUMN_NAME}} =substr($rd->{$f->{COLUMN_NAME}}, 0, $f->{COLUMN_SIZE_DB} ||$f->{COLUMN_SIZE})
if $rd
&& defined($rd->{$f->{COLUMN_NAME}})
&& ($f->{dataType} =~/^(?:char)$/) && $f->{COLUMN_SIZE};
$ru =1 if $rd
&& (defined($rd->{$f->{COLUMN_NAME}})
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...
return($sf);
}
my $qs =$s->{-dbi}->quote('w') =~/^([^w]+)w/ ? $1 : "'";
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
.$s->{-cgi}->popup_menu(%a
, $a{-labels} && !$a{-values}
? (-values => do{use locale; [sort {$a{-labels}->{$a} cmp $a{-labels}->{$b}} keys %{$a{-labels}}]})
: ()
, $cs
? (-onchange => '{window.document.forms[0].' .$a{-name} .'__C_.value="1"; window.document.forms[0].submit(); return(false)}')
: ()
)
.( $cs && ($a{-onchange}=~/^\d/) && $s->{-cgi}->param($a{-name} .'__C_')
? '<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_";
my $av=sub{ return($a{-values}) if $a{-values};
use locale;
$a{-values} =[
$a{-labels0}
? sort {(defined($a{-labels0}->{$a}) ? $a{-labels0}->{$a} : '')
cmp (defined($a{-labels0}->{$b}) ? $a{-labels0}->{$b} : '')
lib/ARSObject.pm view on Meta::CPAN
: $s->{-cgi}->param($n);
$v =&$av()->[0]
if $a{-strict} && (!defined($v) || !grep /^\Q$v\E$/, @{&$av()});
$s->{-cgi}->param($n, defined($v) ? $v : '');
my $ek =$s->{-cgi}->user_agent('MSIE') ? 'window.event.keyCode' : 'event.which';
my $fs =sub{
'{var k;'
."var l=window.document.forms[0].$nl;"
."if(l.style.display=='none'){"
.($_[0] eq '4' ? '' : 'return(true)') .'}else{'
.(!$_[0] # onkeypess - input
lib/ARSObject.pm view on Meta::CPAN
? "if (String.fromCharCode($ek) ==\"\\r\") {${n}__S_.focus(); ${n}__S_.click(); return(true)}; window.document.forms[0].$n.focus(); k=window.document.forms[0].$n.value =String.fromCharCode($ek); "
: $_[0] eq '2' # onkeypess - list -> prompt (selected char)
# ? "k=prompt('Enter search string',String.fromCharCode($ek));"
? "if (String.fromCharCode($ek) ==\"\\r\") {${n}__S_.focus(); ${n}__S_.click(); return(true)}; k =String.fromCharCode($ek); for (var i=0; i <l.length; ++i) {if (l.options.item(i).value.toLowerCase().indexOf(k)==0 || l.options.item(i).text....
: $_[0] eq '3' # button - '..'
? "k=prompt('Enter search substring',''); $nl.focus();"
: $_[0] eq '4' # onload - document
? "k=window.document.forms[0].$n.value; window.document.forms[0].$nl.focus();"
: ''
)
.'if(k){'
lib/ARSObject.pm view on Meta::CPAN
, ($a{-strict} && !$s->{-cgi}->param("${n}__O_")
? (-readonly=>1) # ,-hidefocus=>0, -disabled=>0
: ())
)
.($s->{-cgi}->param("${n}__O_")
? ("<input type=\"submit\" name=\"${n}__X_\" value=\"X\" title=\"close\"$ac$as />"
."<input type=\"hidden\" name=\"${n}__P_\" value=\"" .(defined($v) ? $s->{-cgi}->escapeHTML($v) : '') ."\"$ac$as />\n"
."<br />\n"
."<select name=\"${n}__L_\" title=\"select value\" size=\"10\""
."$ac$as"
." ondblclick=\"{${n}__S_.focus(); ${n}__S_.click(); return(true)}\""
lib/ARSObject.pm view on Meta::CPAN
.' value="' .$s->{-cgi}->escapeHTML(defined($_) ? $_ : '') .'">'
.$s->{-cgi}->escapeHTML(
!defined($_)
? ''
: !$a{-labels}
? (length($_) > $aw ? substr($_,0,$aw) .'...' : $_)
: defined($a{-labels}->{$_})
? (length($a{-labels}->{$_}) > $aw ? substr($a{-labels}->{$_},0,$aw) .'...' : $a{-labels}->{$_})
: '') ."</option>\n"
} @{&$av()})
."</select>\n"
."<input type=\"submit\" name=\"${n}__S_\" value=\"<\" title=\"set\"$ac$as />"
.$s->{-cgi}->button(-value=>'...', -title=>'find', -onClick=>&$fs(3))
."<input type=\"submit\" name=\"${n}__X_\" value=\"X\" title=\"close\"$ac$as />"
."</div>\n"
."<script for=\"window\" event=\"onload\">{window.document.forms[0].${n}__L_.focus()}</script>"
)
: ("<input type=\"submit\" name=\"${n}__O_\" value=\"...\" title=\"open\"$ac$as />"
.($s->{-cgi}->param("${n}__C_") ||$s->{-cgi}->param("${n}__X_")
? "<script for=\"window\" event=\"onload\">{window.document.forms[0].${n}__O_.focus()}</script>"
: ''
))
)
}
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};
local $s->{-smtpdomain} =$s->{-smtpdomain}
|| ($s->{-smtphost} && $s->smtp(sub{$_[1]->domain()}))
|| 'nothing.net';
$a{-from} =$a{-from} ||$a{-sender} ||$ENV{REMOTE_USER} ||$ENV{USERNAME};
$a{-from} =&{$a{-from}}($s,\%a) if ref($a{-from}) eq 'CODE';
$a{-to} =&{$a{-to}}($s,\%a) if ref($a{-to}) eq 'CODE';
$a{-to} =[grep {$_} split /\s*[,;]\s*/, ($a{-to} =~/^\s*(.*)\s*$/ ? $1 : $a{-to})]
lib/ARSObject.pm view on Meta::CPAN
if $a{-recipient} && ref($a{-recipient}) && ($a{-recipient} =~/[,;]/);
return(&{$s->{-die}}("SMTP e-mail recipients not defined"))
if !$a{-recipient};
if (!defined($a{-data})) {
my $koi =(($a{-charset}||$s->charset()||'') =~/1251/);
$a{-subject} = ref($a{-subject}) eq 'CODE'
? &{$a{-subject}}($s,\%a)
: 'ARSObject'
if ref($a{-subject}) ||!defined($a{-subject});
$a{-data} ='';
$a{-data} .='From: ' .($koi ? $s->cptran('ansi','koi',$a{-from})
: $a{-from})
."\cM\cJ";
$a{-data} .='Subject: '
.($koi
? $s->cptran('ansi','koi',$a{-subject})
: $a{-subject}) ."\cM\cJ";
$a{-data} .='To: '
.($koi
? $s->cptran('ansi','koi', ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to})
: (ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}))
."\cM\cJ"
if $a{-to};
foreach my $k (keys %a) {
next if $k =~/^-(data|subject|html|text|from|to|sender|recipient)$/;
next if !defined($a{$k});
my $n =$k =~/^-(.+)/ ? ucfirst($1) .':' : $k;
$a{-data} .=$n .' ' .$a{$k} ."\cM\cJ";
}
$a{-data} .="MIME-Version: 1.0\cM\cJ";
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] || []
# empty run command - only soon command will be scheduled
# empty soon command - sleep(minutes*60) will be used
# !defined(minutes) - soon command will be deleted from schedule
# and run command will be executed once
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
}
if (exists($f->{-used}) ||exists($f->{-unused})) {
}
elsif ($ak && ($f->{-action}||$f->{-preact})
&& (($f->{-action}||$f->{-preact}) =~/^(?:entryUpd|entryDel|entry|vfentry|vfhash)$/)) {
$f->{-used} =sub{$_[0]->cgipar($ak)}
}
else {
$f->{-used} =1
}
$f->{-widget} =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 : {};
my $ae=ref($act) eq 'HASH' ? $act->{$ord} : $act;
my $frm =$f->{-formdb}|| $af->{-formdb} ||'';
my $frn =$f->{-record}|| $af->{-record} ||'';
my $frk =undef;
my $ffc =sub{ my $f =$_[1];
!ref($f)
|| !$f->{-namedb} || $f->{-key}
|| !$f->{-formdb} || ($f->{-formdb} ne $frm)
|| (($f->{-record}||'') ne $frn)
};
my $vy =0;
my $fvu =sub{ return(undef)
if (ref($_[1]->{-values}) eq 'ARRAY')
&& !scalar(@{$_[1]->{-values}});
my $v =cfpvv(@_);
$v =undef if defined($_[1]->{-undef}) && defined($v) && ($_[1]->{-undef} eq $v);
$vy=1 if defined($v) && ($v ne '') && (!$_[1]->{-master} ||$_[1]->{-key});
lib/ARSObject.pm view on Meta::CPAN
my $fs =$f->{-vfname} ||$af->{-vfname};
my $fn =undef;
my $fv =undef;
if ($frk && $fs && ($fn =$frk->{-namedb}) && defined($fv=cfpv($s, $frk->{-master}))) {
$s->{-fpbv} =$f->{-namedb}
? $s->vfdata($fs, sub{defined($_->{$fn}) && ($_->{$fn} eq $fv)})
: [];
$r =shift @{$s->{-fpbv}} if $s->{-fpbv} && scalar(@{$s->{-fpbv}});
$r ={} if !$r;
}
elsif ($fs) {
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
: ($s->{-lang} ||'') =~/^ru/i
? {'Error'=>'Îøèáêà', 'Warning'=>'Ïðåäóïðåæäåíèå', 'Success'=>'Óñïåøíî'
,'Executing'=>'Âûïîëíåíèå', 'Done'=>'Âûïîëíåíî'}
: {};
$cmsg =sub{"\n<br /><font style=\"font-weight: bolder\""
.($_[1] =~/^(?:Error|Warning)/ ? ' color="red"' : '')
.'>'
.(defined($_[1]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[1]} ||$_[1]) : 'undef')
.": "
.(defined($_[2]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[2]} ||$_[2]) : 'undef')
."</font>"
# 'Error', 'Warning',
# 'Executing', 'Done'('Success', 'Error')
}
if !$cmsg || (ref($cmsg) ne 'CODE');
my $emsg =sub{
$CGI::Carp::CUSTOM_MSG
? &$CGI::Carp::CUSTOM_MSG($_[1])
: print(&$cmsg($_[0], 'Error', $_[1]))
};
$cfld =sub{"\n<tr><th align=\"left\" valign=\"top\">"
. ($_[1]->{-namehtml}
? &{$_[1]->{-namehtml}}(@_)
: $_[0]->{-cgi}->escapeHTML($_[1]->{-namelbl}||''))
. "</th>\n<td align=\"left\" valign=\"top\">"
. $_[2]
lib/ARSObject.pm view on Meta::CPAN
: ref($f->{-widget}) eq 'CODE'
? &{$f->{-widget}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
: !$f->{-namecgi}
? ''
: ref($f->{-widget}) eq 'HASH'
? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, %{$f->{-widget}})
: $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, map {defined($f->{$_}) ? ($_=>$f->{$_}) : ()} qw(-class -style));
next
}
elsif ($bb) {
print &$cfld($s, {}, $bb);
lib/ARSObject.pm view on Meta::CPAN
: $f->{-rows}
? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, %{$f->{-widget}})
: $f->{-action} ||$f->{-preact}
? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, -id => $f->{-namecgi}
, %{$f->{-widget}})
: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, %{$f->{-widget}})
lib/ARSObject.pm view on Meta::CPAN
? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
defined($v) ? ($_=>$v) : ()} qw(-rows -columns -maxlength -readonly -class -style))
: $f->{-action} ||$f->{-preact}
? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, -id => $f->{-namecgi}
, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
defined($v) ? ($_=>$v) : ()} qw(-class -style))
: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
ARSperl
view release on metacpan or search on metacpan
# itself) for a full description.
#
# Official Home Page:
# http://www.arsperl.org
#
# Mailing List (must be subscribed to post):
# arsperl@arsperl.org
#
# 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( @_ );
}
# ROUTINE
# ars_simpleMenu(menuItems, prepend)
#
# DESCRIPTION
# merges all sub-menus into a single level menu. good for web
# interfaces.
#
# RETURNS
# array of menu items.
sub ars_simpleMenu {
my($m) = shift;
my($prepend) = shift;
my(@m) = @$m;
my(@ret, @submenu);
my($name, $val);
while (($name, $val, @m) = @m) {
if (ref($val)) {
@submenu = ars_simpleMenu($val, $name);
@ret = (@ret, @submenu);
} else {
if ($prepend) {
@ret = (@ret, "$prepend/$name", $val);
} else {
@ret = (@ret, $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
$suffix = reverse $_suffix;
$extentie = reverse $_extentie;
($datum, $restant) = split(/\-/, $suffix, 2);
if (defined $restant) {
$datum = substr($datum, 0, 8);
if ( $extentie ) {
if ( $extentie eq 'htm' ) {
if ($datum le get_yearMonthDay($gzipDebugEpoch)) {
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
print "\n";
}
if (defined $restant) {
$datum = substr($datum, 0, 8);
if ($extentie eq 'pdf') {
if ($datum le get_yearMonthDay($removeReportsEpoch)) {
if ($debug) {
print "RP-<$datum><".get_yearMonthDay($removeReportsEpoch)."><$reportPath><$reportFilename>\n";
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)
applications/archive.pl view on Meta::CPAN
L(ong) : long screendebugging on
-V, --version
-h, --help
Send email to $SENDEMAILTO if you have questions regarding
use of this software. To submit patches or suggest improvements, send
email to $SENDEMAILTO
";
}
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
ASP::NextLink is NOT functionally equivalent to MSWC.NextLink.
Whereas each method of MSWC.NextLink takes a file argument,
ASP::NextLink takes a file argument ONLY in the constructor
( ASP::NextLink->new("linkfile") ). new() parses the linkfile
given; the information derived from this linkfile is subsequently
available only through the object returned by new().
Attempts to call object methods on a class and attempts to call
class methods on an object will both trigger an exception.
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
$Request->ServerVariables are only stuffed into %ENV on Win32
platforms, as Apache::ASP already provides this.
ASP.pm also exports the $ScriptingNamespace symbol (Win32 only).
This symbol allows PerlScript to call subs/functions written in
another script language. For example:
<%@ language=PerlScript %>
<%
use ASP qw(:strict);
=head1 USE
=head2 use ASP qw(:basic);
Exports basic subs: Print, Warn, die, exit, param, param_count. Same
as C<use ASP;>
=head2 use ASP qw(:strict);
Allows the use of the ASP objects under C<use strict;>.
NOTE: This is not the only way to accomplish this, but I think it's
the cleanest, most convenient way.
=head2 use ASP qw(:all);
Exports all subs except those marked 'not exported'.
=head2 use ASP ();
Overloads print() and warn() and provides the $ASP::ASPOUT object.
C<warn> (or more specifically, the __WARN__ signal) has been re-routed to
output to the browser.
FYI: When implemented, this tweak led to the removal of the prototypes
Matt placed on his subs.
=head2 Warn LIST
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,
Optimized and debugged.
=item Version 0.77
Overloaded warn() and subsequently removed prototypes.
Exported $ScriptingNamespace object.
Added methods escape(), unescape(), escapeHTML(), unescapeHTML().
Thanks to Bill Odom for pointing these out!
ASP4-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
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
}
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
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});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
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
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
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
}
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
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});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
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 1.081 second using v1.01-cache-2.11-cpan-7add2cbd662 )