Apache-SdnFw
view release on metacpan or search on metacpan
- Chris Sutton <chris@smalldognet.com>
license: unknown
distribution_type: module
configure_requires:
ExtUtils::MakeMaker: 0
build_requires:
ExtUtils::MakeMaker: 0
requires:
Crypt::Blowfish: 0
Crypt::CBC: 0
Data::Dumper: 0
Date::Format: 0
DBD::Pg: 0
DBI: 0
Digest::MD5: 0
Google::SAML::Response: 0
Lingua::EN::Numbers: 0
LWP::UserAgent: 0
MIME::Base64: 0
MIME::QuotedPrint: 0
Net::FTP: 0
Makefile.PL view on Meta::CPAN
'Crypt::CBC' => 0,
'Crypt::Blowfish' => 0,
'XML::Dumper' => 0,
'XML::Simple' => 0,
'Net::SMTP::SSL' => 0,
'Net::FTP' => 0,
'Digest::MD5' => 0,
'MIME::Base64' => 0,
'MIME::QuotedPrint' => 0,
'Date::Format' => 0,
'Data::Dumper' => 0,
'Lingua::EN::Numbers' => 0,
'Google::SAML::Response' => 0,
}, # e.g., Module::Name => 1.1
($] >= 5.005 ? ## Add these new keywords supported since 5.005
(ABSTRACT_FROM => 'lib/Apache/SdnFw.pm', # retrieve abstract from module
AUTHOR => 'Chris Sutton <chris@smalldognet.com>') : ()),
);
lib/Apache/SdnFw.pm view on Meta::CPAN
# try and get a Core object and pass this information to it
# setup our database debug output file
if ($options{env}{DBDEBUG}) {
_start_dbdebug(\%options);
}
my $s;
eval {
$s = Apache::SdnFw::lib::Core->new(%options);
$s->process();
#croak "test".Data::Dumper->Dump([$s]);
};
if ($options{env}{DBDEBUG}) {
_end_dbdebug($s);
}
# so from all that happens below here is what $s->{r} should have
# error => ,
# redirect => ,
# return_code => ,
lib/Apache/SdnFw/bin/run_sql.pl view on Meta::CPAN
#!/usr/bin/perl
use strict;
use Getopt::Std;
use Apache::SdnFw::lib::Core;
use Apache::SdnFw::lib::DB;
use Data::Dumper;
use Carp;
my %args;
getopts('vd:',\%args);
unless($args{d}) {
print STDERR "run_sql.pl -v -d database <command.sql\n";
exit;
}
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
use Crypt::CBC;
use Crypt::Blowfish;
use XML::Dumper;
use XML::Simple;
use Net::SMTP::SSL;
use Net::FTP;
use Digest::MD5 qw(md5_hex);
use MIME::Base64 qw(encode_base64);
use MIME::QuotedPrint qw(encode_qp);
use Date::Format;
use Data::Dumper;
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(mime_type);
BEGIN {
# preload all top level objects
# where the hell are we when we startup?
opendir(ROOT,$ENV{HTTPD_ROOT});
while (my $scode = readdir(ROOT)) {
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
$s->{raw_path} = $1 || '/';
$s->run();
if ($s->{return_code}) {
$s->{r}{return_code} = $s->{return_code};
return;
}
if ($s->{in}{debug} && $s->{env}{DEV}) {
#delete $s->{content};
$s->{content} = Data::Dumper->Dump([$s]);
$s->{content_type} = 'text/plain';
}
# always make the content type xml for api
$s->{content_type} = 'text/xml' if ($s->{api} || $s->{o}{perl_dump});
# move the content type back to the return hash
$s->{r}{content_type} = $s->{content_type};
# set some things for logging purposes
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
my $s = shift;
my %args = @_;
croak "Missing table" unless($args{table});
croak "Missing idfield" unless($args{idfield});
croak "Missing object" unless($args{object});
croak "Missing id" unless($args{id});
croak "Missing existing" unless(defined($args{existing}));
croak "Missing update" unless(defined($args{update}));
#croak "<pre>".Data::Dumper->Dump([\%{$args{update}}])."</pre>";
my %update;
foreach my $k (keys %{$args{update}}) {
if (exists($args{existing}{$k})) {
my $object;
if ($args{update}{$k} =~ m/^(.+):(\d*)$/) {
$object = $1;
$args{update}{$k} = $2;
}
if ($args{update}{$k} ne $args{existing}{$k}) {
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
}
$s->log($args{object},$args{id},
"$args{object} $field changed from [$old] to [$new]");
}
} else {
croak "Existing data for $args{object} field $k not defined";
}
}
#croak "<pre>".Data::Dumper->Dump([\%update])."</pre>";
if (keys %update) {
$s->db_update_key($args{table},$args{idfield},$args{id},\%update);
}
}
sub in_to_hash {
=head2 in_to_hash
my %hash = $s->in_to_hash($identifier,[$noblanks]);
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
my $s = shift;
my $msg = shift;
# make sure we do not report errors to ourself, otherwise we go into a circular loop!
# if this was a croak, it means that we should record this error into the main error
# recording system
my $error = $s->escape($msg);
my $employee = '<employee>'.$s->escape("$s->{employee_id} $s->{employee}{name}").
'</employee>' if ($s->{employee_id});
my $in = $s->escape(Data::Dumper->Dump([\%{$s->{in}}]));
my $env = $s->escape(Data::Dumper->Dump([\%{$s->{env}}]));
my $session = $s->escape(Data::Dumper->Dump([\%{$s->{session_data}}]));
my $uri = $s->escape($s->{uri});
my $xml = <<END;
<?xml version="1.0" encoding="UTF-8"?>
<error>
<message>$error</message>
$employee
<var_in>$in</var_in>
<uri>$uri</uri>
<var_env>$env</var_env>
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
EVAL_PERL => 1,
COMPILE_DIR => '/tmp/tt_cache',
COMPILE_EXT => '.cache',
# remove leading and trailing whitespace and newlines
#PRE_CHOMP => 2,
#POST_CHOMP => 2,
#STAT_TTL => 1,
OUTPUT => \$s->{content},
);
#$s->{content} .= "<pre>".Data::Dumper->Dump([$s])."</pre>"; return;
#$s->{content} .= "<pre>".Data::Dumper->Dump([\@INC])."</pre>"; return;
# if ($s->{raw_path} eq '/logout') {
# return unless($s->_authenticate());
# }
# if we barf below anywhere we do not want to show anything but the raw error so set this
$s->{nomenu} = 1;
# at this point, we need to look for $object
# and from there $function
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
if ($s->{object} eq 'logout') {
$s->_authenticate();
$s->{function} = 'home' if ($s->{function} eq 'list');
$s->redirect(object => $s->{function},
function => 'list');
return;
}
if ($s->{env}{DEV} && $s->{object} eq 'debug') {
$s->{content} = Data::Dumper->Dump([$s]);
$s->{content_type} = 'text/plain';
return;
}
no strict 'refs';
if ($s->{object} ne 'help') {
$s->{obj_base} = $s->{obase}.'::object::'.$s->{object};
my $config = $s->{obj_base}.'::config';
# make sure we can find the object
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
if ($s->{object} eq 'home' && $s->{function} eq 'list' && $s->{api}) {
_api_calls($s);
return;
}
$s->{log_user} = $s->{employee_id} if ($s->{employee_id});
$s->session_load();
#croak "<pre>".Data::Dumper->Dump([$s])."</pre>";
# make sure we actually have functions defined
if ($s->{object} ne 'help') {
unless(defined($s->{o}{functions})) {
$s->alert("Sorry, there were no functions defined for $s->{object}");
return;
}
}
if ($s->{object} eq 'help') {
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
}
if ($s->{object} ne 'help') {
# do any post processing
my $post = $s->{obase}.'::object::config::post';
if (defined(&{$post})) {
&{$post}($s);
}
}
#$s->{content} .= "<pre>".Data::Dumper->Dump([$s])."</pre>";
}
sub call {
my $s = shift;
my $f = shift;
# make sure it's a valid function
unless(defined($s->{o}{functions}{$f})) {
$s->alert("Sorry, $f is not defined for $s->{object}");
return 0;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
$s->alert("Sorry, you can not $f a $s->{object}");
return 0;
}
}
# setup some convience variables so we have to type less
$s->{uof} = "$s->{ubase}/$s->{object}/$s->{function}";
$s->{uo} = "$s->{ubase}/$s->{object}";
if ($s->{o}{log_stderr}) {
my $dd = Data::Dumper->new([\%{$s->{in}}],[qw(data)]);
$dd->Indent(0);
$s->db_insert('object_debug',{
o => $s->{object},
f => $s->{function},
i => $dd->Dump(),
});
}
# actually call the function
eval {
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
my $s = shift;
my $doctype = shift;
my $vendor = shift;
my $data = shift;
# my $function = $s->{obj_base}.'::'.$f;
croak "Unknown vendor code" unless($vendor->{code});
croak "Missing doctype" unless($doctype);
#croak "vendor=".Data::Dumper->Dump([$vendor]);
#croak "data=".Data::Dumper->Dump([$data]);
my $base = $s->{obase} || $s->{env}{OBJECT_BASE};
my $package = $base.'::edimap::'.$vendor->{code}.'::'.$doctype;
no strict 'refs';
eval "use $package";
my $function = $package.'::build';
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
push @{$work{segment}{$segment_code}{elements}}, {
element_code => $ref->{element_code},
element_order => $ref->{element_order},
name => $ref->{name},
element_type => $ref->{element_type},
min_length => $ref->{min_length},
max_length => $ref->{max_length},
};
}
# croak "test".Data::Dumper->Dump([\%work]);
my %loops_completed;
my $output;
foreach my $seg (@{$work{segments}}) {
if ($work{segment}{$seg}{loop}) {
my $loop = $work{segment}{$seg}{loop};
next if (defined($loops_completed{$loop}));
# our segment is within a loop, so lets look in that loop instead
# but only if we have not visited the loop before
next unless(defined($data->{$loop}));
foreach my $loop_ref (@{$data->{$loop}}) {
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
$vendor->{segment_term} = "\n";
}
#print "Input2=$input\n";
my @data;
foreach my $seg (split $vendor->{segment_term}, $input) {
my @e = split $vendor->{element_sep}, $seg;
push @data, [ @e ];
}
#print " ".Data::Dumper->Dump([\@data]);
my %x;
my %work;
unless($vendor->{partner_edi_identifier} && $vendor->{partner_edi_qualifier}) {
croak "Partner $vendor->{partner_id}} has unknown identifier or qualifier";
}
my $dt;
my $i_ref = undef;
my $g_ref = undef;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
#print "Processing $seg->[0]\n" if ($args{v});
unless(defined($i_ref)) {
if ($seg->[0] eq 'ISA') {
%x = _x12_map($s,$vendor->{edi_version_id},'ISA',$seg);
if ($x{error}) {
croak $x{error};
}
$x{groups} = [];
$i_ref = $x{groups};
$x{group_count} = 0;
#print $seg->[0].": ".Data::Dumper->Dump([\%x]) if ($args{v});
next;
} else {
croak "ISA not found";
}
}
if ($seg->[0] eq 'IEA') {
$dt = 'HEAD';
# print $seg->[0].": ".Data::Dumper->Dump([\%tmp]) if ($args{v});
my %tmp = _x12_map($s,$vendor->{edi_version_id},'IEA',$seg);
if ($tmp{error}) {
croak $tmp{error};
} elsif ($tmp{IEA01} != $x{group_count}) {
$x{error} = "Group count in IEA ($tmp{IEA01}) ne groups ($x{group_count})";
} elsif ($tmp{inter_control_num} ne $x{inter_control_num}) {
$x{error} = "IEA control num ne ISA control number";
}
last;
}
if ($seg->[0] eq 'GE') {
$dt = 'HEAD';
# we need to count ourself
#$g_ref->{set_count}++;
my %tmp = _x12_map($s,$vendor->{edi_version_id},'GE',$seg);
#print $seg->[0].": ".Data::Dumper->Dump([\%tmp]) if ($args{v});
if ($tmp{error}) {
$g_ref->{error} = $tmp{error};
} elsif ($tmp{GE01} != $g_ref->{set_count}) {
$g_ref->{error} = "Set count in GE ($tmp{GE01}) ne sets ($g_ref->{set_count})";
} elsif ($tmp{group_control_num} ne $g_ref->{group_control_num}) {
$g_ref->{error} = "GE control num ne GS control number";
}
$g_ref = undef;
next;
}
if ($seg->[0] eq 'SE') {
$dt = 'HEAD';
# we need to count ourself
$s_ref->{segment_count}++;
my %tmp = _x12_map($s,$vendor->{edi_version_id},'SE',$seg);
#print $seg->[0].": ".Data::Dumper->Dump([\%tmp]) if ($args{v});
#print Data::Dumper->Dump([$s_ref]);
if ($tmp{error}) {
$s_ref->{error} = $tmp{error};
} elsif ($tmp{SE01} != $s_ref->{segment_count}) {
$s_ref->{error} = "Segment count in SE ($tmp{SE01}) ne segments ($s_ref->{segment_count})";
} if ($tmp{SE02} ne $s_ref->{ST02}) {
$s_ref->{error} = "SE control num $tmp{SE02} ne ST control number $s_ref->{ST02}";
}
$s_ref = undef;
next;
}
unless(defined($g_ref)) {
if ($seg->[0] eq 'GS') {
my %tmp = _x12_map($s,$vendor->{edi_version_id},'GS',$seg);
if ($tmp{error}) {
croak $tmp{error};
}
#print $seg->[0].": ".Data::Dumper->Dump([\%tmp]) if ($args{v});
$tmp{sets} = [];
$tmp{set_count} = 0;
# make sure they are sending to the right person
# unless($tmp{GS03} eq $work{partner}{edi_identifier}) {
# # kill this group because we did not match
# # our Data Interchange Control Number is GS06
# $tmp{error} = "Document Identifier $tmp{GS03} does not match partner identifier $work{partner}{edi_identifier}";
# }
push @{$i_ref}, { %tmp };
$g_ref = $i_ref->[$x{group_count}];
$x{group_count}++;
# croak "test: ".Data::Dumper->Dump([\%tmp]);
# now that we have the group, we need to load the
# rest of the data matching this version and for this
# vendor/partner
#_loadmap($tmp{GS08},$tmp{GS02});
next;
} else {
croak "GS not found";
}
}
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
$dt = 'HEAD';
my %tmp = _x12_map($s,$vendor->{edi_version_id},'ST',$seg);
if ($tmp{error}) {
croak $tmp{error};
}
# do we have this document for this vendor, and is it the right version?
# unless(defined($work{vendor_documents}{$tmp{ST01}}) &&
# $g_ref->{GS08} eq $work{vendor_documents}{$tmp{ST01}}{version_code}) {
# $tmp{error} = "Document $tmp{ST01}/$g_ref->{GS08} not defined for vendor";
# }
#croak "test: ".Data::Dumper->Dump([\%tmp]);
$tmp{segments} = [];
$tmp{segment_count} = 1;
push @{$g_ref->{sets}}, { %tmp };
$s_ref = $g_ref->{sets}[$g_ref->{set_count}];
$g_ref->{set_count}++;
$dt = $tmp{ST01};
next;
} else {
croak "ST not found";
}
}
my %hash = _x12_map($s,$vendor->{edi_version_id},$seg->[0],$seg);
# print $seg->[0].": ".Data::Dumper->Dump([\%hash]) if ($args{v});
push @{$s_ref->{segments}}, { %hash } if (keys %hash);
$s_ref->{segment_count}++;
}
return %x;
}
sub _x12_map {
my $s = shift;
my $version = shift;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
$out{SE}{1}++;
}
# accept if we had no errors
$out{AK9}{1} = 'A' if ($out{AK9}{2} == $out{AK9}{4}); # accepted
$out{AK9}{1} = 'P' if ($out{AK9}{2} > $out{AK9}{4} && $out{AK9}{4}); # partial accept
$out{AK9}{1} = 'R' unless ($out{AK9}{4}); # reject all
$out{SE}{1}++; # for the AK1
$out{SE}{1}++; # for the AK9
}
#print Data::Dumper->Dump([\%out]);
my $x12 = $s->format_x12($doc{vendor_edi_document_id},\%out);
#print $x12;
$s->send_x12('997',$x12,$vendor->{edi_vendor_id},$edi_trans_id);
}
sub x12_add_isa {
my $s = shift;
my $vendor = shift;
my $out = shift;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
SELECT a.action_id, a.name, a.a_object, a.a_function,
concat(ga.group_id) as groups
FROM actions_v a
LEFT JOIN group_actions ga ON a.action_id=ga.action_id
WHERE a.a_object=?
AND a.a_function=?
GROUP BY 1,2,3,4
",'hash',
v => [ $s->{object}, $function ]);
#croak "<pre>".Data::Dumper->Dump([\%hash])."</pre>";
# if we do not, then add the object/function to the admin group
unless($hash{action_id}) {
$hash{groups} = $s->_set_default_access($s->{object},$function);
}
# we have a problem here....how do we deal with people who
# we do not want to to have access to "everything"?
# if someone has "strict_perms", then skip this everyone check
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
my $insert = 1 unless(defined($s->{session_data}));
$s->{session_data}{$key} = $value;
_session_update($s,$insert);
}
sub _session_update {
my $s = shift;
my $insert = shift;
Data::Dumper->Purity(1);
Data::Dumper->Deepcopy(1);
my $dd = Data::Dumper->new([\%{$s->{session_data}}],['$s->{session_data}']);
if ($insert) {
$s->db_insert('employee_sessions',{
employee_id => $s->{employee_id},
data => $dd->Dump(),
});
} else {
$s->db_q("
UPDATE employee_sessions SET data=?, last_update_ts=now()
WHERE employee_id=?
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
my $path = "$s->{function}.tt";
if ($s->{function} eq 'system') {
unless($s->{employee}{admin}) {
$s->alert("Sorry, you are not an admin, you can't look at that");
return;
}
# show our system help file, disaster recovery type information
$s->{nomenu} = 1;
my $debug = "<pre>".Data::Dumper->Dump([$s])."</pre>";
$s->tt('system.tt', { s => $s });
#$s->{content} .= $debug;
return;
}
if ($s->{in}{f} eq 'save' && $s->{employee}{admin}) {
open F, ">/data/$s->{obase}/template/help/$s->{function}.tt";
$s->{in}{help_text} =~ s/\r//g;
print F $s->{in}{help_text};
close F;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
nourl => 1);
}
$s->{content} = "Sorry no help file found for $s->{function}";
}
if ($s->{employee}{admin}) {
$s->add_action(function => 'system',
title => 'emergency information');
}
#$s->{content} = "<pre>".Data::Dumper->Dump([$s])."</pre>";
}
sub permission {
my $s = shift;
# manage permissions on an object. This should only be accessable
# with thos who are part of an admin group
unless($s->{employee}{admin}) {
$s->alert("You are not an admin. You can not do this!");
return 0;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
}
$s->notify("Permissions updated");
if ($s->{in}{return}) {
$s->redirect(function => $s->{in}{return},
params => $s->{in}{return_args});
}
return;
}
#croak "<pre>".Data::Dumper->Dump([\%existing])."</pre>";
$s->tt('permission.tt', { s => $s, groups => \@groups, existing => \%existing });
}
sub sendmail {
my $s = shift;
my %info = @_;
my %from;
my $nodev;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
if (defined($s->{o}{display_functions})) {
foreach my $function (@{$s->{o}{display_functions}}) {
my $title = $function;
$title =~ s/_/ /g;
$s->add_action(function => $function,
title => $title,
params => "$s->{o}{id}=$hash{$s->{o}{id}}");
}
}
#croak "<pre>".Data::Dumper->Dump([\%hash])."<pre>";
$s->tt('display.tt',{ s => $s, hash => \%hash });
}
sub generic_addnote {
my $s = shift;
return unless($s->check_in_id());
if ($s->{in}{note_text}) {
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
}
}
if ($s->{in}{$s->{o}{id}} =~ m/^\d+$/) {
# if they gave us an id, then skip everything else
undef @search;
push @search, { k => $s->{o}{id}, v => $s->{in}{$s->{o}{id}} };
}
if (scalar @search) {
$s->{content} = "<pre>".Data::Dumper->Dump([\@search])."</pre>";
} else {
$s->tt('search.tt',{ s => $s, });
}
}
sub generic_note {
my $s = shift;
return unless($s->check_in_id());
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
@{$s->{o}{menu}{$ref->{k}}} = $s->db_q("
SELECT id, name
FROM ${table}s_v_keyval
ORDER BY name
",'arrayhash');
};
}
}
}
#croak "<pre>".Data::Dumper->Dump([\%{$s->{o}}])."<pre>";
$s->add_action(function => 'list') if (defined($s->{o}{functions}{list}));
$s->tt('create.tt',{ s => $s, });
}
sub generic_edit {
my $s = shift;
return unless($s->check_in_id());
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
foreach my $ref (@{$s->{o}{relations}}) {
@{$hash{relation}{$ref->{t}}} = $s->db_q("
SELECT * FROM $ref->{t}_v_$s->{object}
WHERE $s->{o}{id}=?
ORDER BY 1",
'arrayhash',
v => [ $s->{in}{$s->{o}{id}} ]);
}
}
#croak "<pre>".Data::Dumper->Dump([\%hash])."</pre>";
$s->add_action(function => 'list') if (defined($s->{o}{functions}{list}));
$s->add_action(function => 'display',
params => "$s->{o}{id}=$hash{$s->{o}{id}}") if (defined($s->{o}{functions}{display}));
$s->add_action(function => 'delete',
params => "$s->{o}{id}=$hash{$s->{o}{id}}") if (defined($s->{o}{functions}{delete}));
$s->tt('edit.tt',{ s => $s, hash => \%hash });
}
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
my $table = $ref->{r};
@{$s->{menu}{$ref->{r}}} = $s->db_q("
SELECT id, name
FROM ${table}s_v_keyval
ORDER BY name
",'arrayhash');
}
}
# try and process the file
#croak "<pre>".Data::Dumper->Dump([\%{$s->{in}}])."</pre>";
#croak "dump\n".Data::Dumper->Dump([\@header]);
$s->tt('map_import.tt', { s => $s, header => \@header });
return;
}
if ($s->{in}{process}) {
#croak "<pre>".Data::Dumper->Dump([\%{$s->{in}}])."</pre>";
# load the file
unless(-e $localfile) {
$s->alert("Sorry, can't find import file $localfile");
return;
}
my $file;
open F, $localfile;
while (<F>) {
$file .= $_;
}
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
$default{all}{$fn} = $s->{in}{$k} if ($s->{in}{$k});
}
}
}
if (defined($s->{o}{create_session_extra})) {
my $key = $s->{o}{create_session_extra};
$default{all}{$key} = $s->{session_data}{$key};
}
#$s->alert("<pre>".Data::Dumper->Dump([\%default])."</pre>");
#return;
#my @debug;
for my $i ( 1 .. $#r ) {
my %import;
foreach my $n (keys %fmap) {
$import{$fmap{$n}} = $r[$i][$n-1];
}
# clean up....
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
#push @debug, { %import };
$import{data_import_id} = $data_import_id;
# add any required subof key
$import{$s->{subof_key}} = $s->{subof_id} if ($s->{subof_key});
eval { $s->db_insert($s->{o}{table},\%import); };
if ($@) {
$s->alert("Error while processing line $i of file: $@\n".
"<pre>".Data::Dumper->Dump([\%import])."</pre>");
$s->{dbh}->rollback;
return;
} else {
$count++;
}
}
#croak "process dump\n".Data::Dumper->Dump([\@r]);
$s->db_update_key('data_imports','data_import_id',$data_import_id,{
count => $count
});
$s->{dbh}->commit;
unlink $localfile;
if ($s->{subof_key}) {
$s->notify("File imported successfully. $count rows processed. ".
$s->object_link(function => 'display',
object => $s->{o}{subof},
params => "$s->{subof_key}=$s->{subof_id}",
title => 'Continue'));
} else {
$s->notify("File imported successfully. $count rows processed. ".
$s->object_link(function => 'list',
title => 'Continue'));
}
#$s->{content} .= "<pre>".Data::Dumper->Dump([\@debug])."</pre>";
return;
}
# before we can do anything, make sure we have a data_import_id field on this
# table, otherwise we can not roll this back or delete what we just imported
eval {
$s->db_q("SELECT data_import_id
FROM $s->{o}{table}
LIMIT 1
");
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
#$s->{raw_path} = '/';
#$s->{uri} =~ s/logout//;
}
SWITCH: {
last if ($s->_interface_check_cookie());
last if ($s->_interface_check_login());
}
#$s->{content} .= "<pre>".Data::Dumper->Dump([$s])."</pre>";
return 1 if ($s->{$s->{o}{id}});
$s->{nomenu} = 1;
$s->{title} = 'Login';
$s->tt('interface_login.tt',{ s => $s });
return 0;
}
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
#$s->{raw_path} = '/';
#$s->{uri} =~ s/logout//;
}
SWITCH: {
last if ($s->_check_api());
last if ($s->_check_cookie());
last if ($s->_check_login());
}
#$s->{content} .= "<pre>".Data::Dumper->Dump([$s])."</pre>";
return 1 if ($s->{employee_id});
$s->{nomenu} = 1;
$s->{title} = 'Login';
unless($s->{in}{ori_args}) {
$s->{in}{ori_args} = $s->{args};
}
lib/Apache/SdnFw/lib/DB.pm view on Meta::CPAN
return @return;
} elsif ($t eq 'importfile') {
my $cols = $sth->{NAME};
croak "undefined file field f in args" unless($args{f});
croak "undefined table import name t in args" unless($args{t});
my %lookup;
my $n = length @{$cols};
for my $i ( 0 .. $n+1 ) {
$lookup{$cols->[$i]} = $i;
}
#croak "test".Data::Dumper->Dump([\%lookup]);
open F, ">$args{f}";
print F "COPY $args{t} (".(join ',', @{$cols}).") FROM STDIN;\n";
while (my @row = $sth->fetchrow_array) {
for my $i ( 0 .. $#row ) {
$row[$i] = '\N' if ($row[$i] eq '' || $row[$i] eq undef);
$row[$i] =~ s/\t//g;
$row[$i] =~ s/\r/\\r/g;
$row[$i] =~ s/\n/\\n/g;
}
lib/Apache/SdnFw/lib/DB.pm view on Meta::CPAN
}
} else {
print F (join "\t", @row)."\n";
}
}
print F "\\.\n";
$sth->finish;
close F;
} elsif ($t eq 'csv' || $t eq 'text') {
my $cols = $sth->{NAME};
#croak "<pre>".Data::Dumper->Dump([$cols])."</pre>";
croak "undefined file field f in args" unless($args{f});
#croak "undefined header field h in args" unless($args{h});
my %restrict;
if (defined($args{restrict_columns})) {
my $tmp;
for my $i ( 0 .. $#{$cols} ) {
unless (defined($args{restrict_columns}{$cols->[$i]})) {
push @{$tmp}, $cols->[$i];
} else {
$restrict{$i} = 1;
lib/Apache/SdnFw/lib/Memcached.pm view on Meta::CPAN
return 0 unless($mdata);
# print STDERR "found $key\n";
unless(ref $mdata) {
if ($mdata eq "\0u") { $mdata = undef;
} elsif ($mdata eq "\0a") { $mdata = [];
} elsif ($mdata eq "\0h") { $mdata = {};
} elsif ($mdata eq "\0s") { $mdata = undef; }
}
# print STDERR Data::Dumper->Dump([$mdata])."\n";
# make sure we are sending back the data that they want
# in the right format
if ($t eq 'scalar' && ref $mdata eq 'SCALAR') {
$data = $$mdata;
return 1;
} elsif ($t =~ m/^(hash|hashhash|keyval)$/ && ref $mdata eq 'HASH') {
foreach my $key (keys %{$mdata}) {
$data->{$key} = $mdata->{$key};
}
return 1;
lib/Apache/SdnFw/object/dbdb.pm view on Meta::CPAN
PeerPort => 11272,
Proto => 'tcp'
) || croak "Nothing running on that socket: $!";
my $raw = <$sock>;
$sock->close;
my $dump = new XML::Dumper;
my $xml = $dump->xml2pl($raw);
# $s->{content} = "<pre>".Data::Dumper->Dump([\$xml])."</pre>";
my %hash;
foreach my $t (qw(page code)) {
foreach my $k (qw(count avg)) {
@{$hash{$t}{$k}} = (sort {
$xml->{$t}{$b}{$k} <=> $xml->{$t}{$a}{$k}
} (keys %{$xml->{$t}})
);
}
}
# $s->{content} .= "<pre>".Data::Dumper->Dump([\%hash])."</pre>";
$s->tt('dbdb/list.tt', { $s => $s, hash => \%hash, xml => $xml });
}
1;
lib/Apache/SdnFw/startup.pl view on Meta::CPAN
use Crypt::CBC;
use Crypt::Blowfish;
use XML::Dumper;
use XML::Simple;
use Net::SMTP::SSL;
use Net::FTP;
use Digest::MD5 qw(md5_hex);
use MIME::Base64 qw(encode_base64);
use MIME::QuotedPrint qw(encode_qp);
use Date::Format;
use Data::Dumper;
if ($ENV{MEM_CALC}) {
my $emem = `ps -o rss --no-heading -p $$`;
chomp $emem;
my $tmem = $emem-$smem;
print STDERR "${tmem}k";
}
print STDERR "\n";
( run in 0.556 second using v1.01-cache-2.11-cpan-4d50c553e7e )