initial commit .gitignore .percriticrc - doesn't work no critic per file Change-Id: If46efa9a6b008861d3e7a527c47715743fef2579changes/17/5317/10
Rene Krenn
9 years ago
parent
538fc41bd3
commit
9027e86928
@ -0,0 +1,25 @@
|
||||
*.log
|
||||
*.html
|
||||
*.htm
|
||||
*.tar
|
||||
*.gz
|
||||
*.tar.gz
|
||||
*.bak
|
||||
*.csv
|
||||
*.xls
|
||||
*.xlsx
|
||||
*.sql
|
||||
*.db
|
||||
*.msg
|
||||
*.komodoproject
|
||||
*.kpf
|
||||
*.MAC
|
||||
.gitattributes
|
||||
|
||||
#/uml
|
||||
#/html
|
||||
#/mails
|
||||
#/log
|
||||
#/backup
|
||||
#/csv
|
||||
#/db
|
||||
@ -0,0 +1,57 @@
|
||||
verbose = %f line %l col %c\n [%s] %p (%e) = %m\n %r\n
|
||||
# the ouput format, another nice one is 8, the [%s] is the severity
|
||||
severity = 3
|
||||
theme = security || (pbp && bugs) || cosmetic || sipwise
|
||||
|
||||
[Documentation::RequirePodSections]
|
||||
add_themes = sipwise
|
||||
lib_sections = NAME | DESCRIPTION | LICENSE | AUTHOR
|
||||
# let's keep this simple for now
|
||||
|
||||
[Bangs::ProhibitCommentedOutCode]
|
||||
commentedcoderegex = \$(?!Id)[A-Za-z_].*=/
|
||||
add_themes = sipwise
|
||||
# should not trigger on the RCS variable
|
||||
|
||||
[Perl::Critic::Policy::Tics::ProhibitLongLines]
|
||||
add_themes = sipwise
|
||||
base_max = 100
|
||||
hard_max = 160
|
||||
pct_allowed = 50
|
||||
# terminal width
|
||||
|
||||
[InputOutput::RequireCheckedSyscalls]
|
||||
add_themes = sipwise
|
||||
functions = :builtins
|
||||
exclude_functions = print
|
||||
|
||||
[-Modules::RequireExplicitInclusion]
|
||||
# we dont want this
|
||||
|
||||
[BuiltinFunctions::ProhibitStringyEval]
|
||||
allow_includes = 0
|
||||
# use Module::Runtime for includes
|
||||
|
||||
[TestingAndDebugging::RequireUseStrict]
|
||||
equivalent_modules = strictures Sipwise::Base HTML::FormHandler::Moose Mojo::Base
|
||||
|
||||
[TestingAndDebugging::RequireUseWarnings]
|
||||
equivalent_modules = strictures Sipwise::Base HTML::FormHandler::Moose Mojo::Base
|
||||
|
||||
##### Other exclusions
|
||||
# not: only relevant with perlcritic 1.117-2 from wheezy,
|
||||
[-Miscellanea::RequireRcsKeywords]
|
||||
|
||||
[-Subroutines::RequireFinalReturn]
|
||||
[-CodeLayout::ProhibitHashBarewords]
|
||||
# meh, it's super annoying
|
||||
[-Lax::ProhibitStringyEval::ExceptForRequire]
|
||||
# already covered through BuiltinFunctions::ProhibitStringyEval::allow_includes
|
||||
[-ControlStructures::ProhibitPostfixControls]
|
||||
[-ControlStructures::ProhibitUnlessBlocks]
|
||||
[-RegularExpressions::RequireLineBoundaryMatching]
|
||||
[-RegularExpressions::RequireDotMatchAnything]
|
||||
[-ValuesAndExpressions::ProhibitEmptyQuotes]
|
||||
[-ValuesAndExpressions::ProhibitNoisyQuotes]
|
||||
[-References::ProhibitDoubleSigils]
|
||||
[-ValuesAndExpressions::RequireNumberSeparators]
|
||||
@ -0,0 +1,384 @@
|
||||
package Array;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use Table;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
mergearrays
|
||||
removeduplicates
|
||||
itemcount
|
||||
grouparray
|
||||
reversearray
|
||||
contains
|
||||
arrayeq
|
||||
mapeq
|
||||
seteq
|
||||
setcontains
|
||||
filter
|
||||
getroundrobinitem
|
||||
getrandomitem
|
||||
array_to_map);
|
||||
|
||||
sub mergearrays {
|
||||
|
||||
my ($array_ptr1,$array_ptr2) = @_;
|
||||
my @result = ();
|
||||
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
||||
foreach my $element (@$array_ptr1) {
|
||||
push @result,$element;
|
||||
}
|
||||
}
|
||||
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
||||
foreach my $element (@$array_ptr2) {
|
||||
push @result,$element;
|
||||
}
|
||||
}
|
||||
return \@result;
|
||||
|
||||
}
|
||||
|
||||
sub removeduplicates {
|
||||
|
||||
my ($array_ptr,$case_insensitive) = @_;
|
||||
my @result = ();
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
|
||||
foreach my $element (@$array_ptr) {
|
||||
if (not contains($element,\@result,$case_insensitive)) {
|
||||
push @result,$element;
|
||||
}
|
||||
}
|
||||
}
|
||||
return \@result;
|
||||
|
||||
}
|
||||
|
||||
sub itemcount {
|
||||
|
||||
my ($item,$array_ptr,$case_insensitive) = @_;
|
||||
my $itemcount = 0;
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
if ($case_insensitive) {
|
||||
foreach my $element (@$array_ptr) {
|
||||
if (lc($element) eq lc($item)) {
|
||||
$itemcount += 1;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
foreach my $element (@$array_ptr) {
|
||||
if ($element eq $item) {
|
||||
$itemcount += 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return $itemcount;
|
||||
|
||||
}
|
||||
|
||||
sub grouparray {
|
||||
|
||||
my ($array_ptr,$case_insensitive) = @_;
|
||||
my $result = new Table();
|
||||
my $reducedarray = removeduplicates($array_ptr,$case_insensitive);
|
||||
my $sort_occurencecount_desc;
|
||||
if ($case_insensitive) {
|
||||
$sort_occurencecount_desc = sub {
|
||||
|
||||
return ((lc($Table::b->[1]) <=> lc($Table::a->[1])) or (lc($Table::a->[0]) cmp lc($Table::b->[0])));
|
||||
|
||||
};
|
||||
} else {
|
||||
$sort_occurencecount_desc = sub {
|
||||
|
||||
return (($Table::b->[1] <=> $Table::a->[1]) or ($Table::a->[0] cmp $Table::b->[0]));
|
||||
|
||||
};
|
||||
}
|
||||
foreach my $element (@$reducedarray) {
|
||||
$result->addrow_ref([$element,itemcount($element,$array_ptr,$case_insensitive)]);
|
||||
}
|
||||
$result->sortrows($sort_occurencecount_desc);
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
sub reversearray {
|
||||
|
||||
my ($array_ptr) = @_;
|
||||
my @result = ();
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
my $ubound = (scalar @$array_ptr) - 1;
|
||||
for (my $i = $ubound; $i >= 0; $i -= 1) {
|
||||
$result[$i] = $array_ptr->[$ubound - $i];
|
||||
}
|
||||
}
|
||||
return \@result;
|
||||
|
||||
}
|
||||
|
||||
sub contains {
|
||||
|
||||
my ($item,$array_ptr,$case_insensitive) = @_;
|
||||
my $result = 0;
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
if ($case_insensitive) {
|
||||
foreach my $element (@$array_ptr) {
|
||||
if (lc($element) eq lc($item)) {
|
||||
$result = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
foreach my $element (@$array_ptr) {
|
||||
if ($element eq $item) {
|
||||
$result = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
sub arrayeq {
|
||||
|
||||
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
||||
my $ubound1;
|
||||
my $ubound2;
|
||||
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
||||
$ubound1 = (scalar @$array_ptr1) - 1;
|
||||
} else {
|
||||
$ubound1 = -1;
|
||||
}
|
||||
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
||||
$ubound2 = (scalar @$array_ptr2) - 1;
|
||||
} else {
|
||||
$ubound2 = -1;
|
||||
}
|
||||
my $result = 1;
|
||||
if ($ubound1 != $ubound2) {
|
||||
return 0;
|
||||
} else {
|
||||
if ($case_insensitive) {
|
||||
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
||||
if (lc($array_ptr1->[$i]) ne lc($array_ptr2->[$i])) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
||||
if ($array_ptr1->[$i] ne $array_ptr2->[$i]) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub seteq {
|
||||
|
||||
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
||||
my $ubound1;
|
||||
my $ubound2;
|
||||
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
||||
$ubound1 = (scalar @$array_ptr1) - 1;
|
||||
} else {
|
||||
$ubound1 = -1;
|
||||
}
|
||||
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
||||
$ubound2 = (scalar @$array_ptr2) - 1;
|
||||
} else {
|
||||
$ubound2 = -1;
|
||||
}
|
||||
# every element of array1 must be existent in array2 ...
|
||||
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
||||
if (not contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
# ... and every element of array2 must be existent in array1
|
||||
for (my $i = 0; $i <= $ubound2; $i += 1) {
|
||||
if (not contains($array_ptr2->[$i],$array_ptr1,$case_insensitive)) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub setcontains {
|
||||
|
||||
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
||||
my $ubound1;
|
||||
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
||||
$ubound1 = (scalar @$array_ptr1) - 1;
|
||||
} else {
|
||||
$ubound1 = -1;
|
||||
}
|
||||
# every element of array1 must be existent in array2:
|
||||
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
||||
if (not contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub filter {
|
||||
|
||||
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
||||
my $ubound1;
|
||||
my $ubound2;
|
||||
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
||||
$ubound1 = (scalar @$array_ptr1) - 1;
|
||||
} else {
|
||||
return [];
|
||||
}
|
||||
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
||||
$ubound2 = (scalar @$array_ptr2) - 1;
|
||||
} else {
|
||||
return $array_ptr1;
|
||||
}
|
||||
my @result = ();
|
||||
# every element of array1 must be existent in array2 ...
|
||||
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
||||
if (contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) {
|
||||
push @result,$array_ptr1->[$i];
|
||||
}
|
||||
}
|
||||
|
||||
return \@result;
|
||||
|
||||
}
|
||||
|
||||
sub getroundrobinitem {
|
||||
|
||||
my ($array_ptr,$recentindex) = @_;
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
my $size = (scalar @$array_ptr);
|
||||
if ($size == 1) {
|
||||
return (@{$array_ptr}[0],0);
|
||||
} elsif ($size > 1) {
|
||||
if (not defined $recentindex or $recentindex < 0) {
|
||||
$recentindex = -1;
|
||||
}
|
||||
my $newindex = ($recentindex + 1) % $size;
|
||||
return (@{$array_ptr}[$newindex],$newindex);
|
||||
}
|
||||
}
|
||||
return (undef,undef);
|
||||
|
||||
}
|
||||
|
||||
sub getrandomitem {
|
||||
|
||||
my ($array_ptr) = @_;
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
my $size = (scalar @$array_ptr);
|
||||
if ($size == 1) {
|
||||
return (@{$array_ptr}[0],0);
|
||||
} elsif ($size > 1) {
|
||||
my $newindex = int(rand($size));
|
||||
return (@{$array_ptr}[$newindex],$newindex);
|
||||
}
|
||||
}
|
||||
return (undef,undef);
|
||||
|
||||
}
|
||||
|
||||
sub array_to_map {
|
||||
|
||||
my ($array_ptr,$get_key_code,$get_value_code,$mode) = @_;
|
||||
my $map = {};
|
||||
my @keys = ();
|
||||
my @values = ();
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
if (defined $get_key_code and ref $get_key_code eq 'CODE') {
|
||||
if (not (defined $get_value_code and ref $get_value_code eq 'CODE')) {
|
||||
$get_value_code = sub { return shift; };
|
||||
}
|
||||
$mode = lc($mode);
|
||||
if (not ($mode eq 'group' or $mode eq 'first' or $mode eq 'last')) {
|
||||
$mode = 'group';
|
||||
}
|
||||
foreach my $item (@$array_ptr) {
|
||||
my $key = &$get_key_code($item);
|
||||
if (defined $key) {
|
||||
my $value = &$get_value_code($item);
|
||||
if (defined $value) {
|
||||
if (not exists $map->{$key}) {
|
||||
if ($mode eq 'group') {
|
||||
$map->{$key} = [ $value ];
|
||||
} else {
|
||||
$map->{$key} = $value;
|
||||
}
|
||||
push(@keys,$key);
|
||||
} else {
|
||||
if ($mode eq 'group') {
|
||||
push(@{$map->{$key}}, $value);
|
||||
} elsif ($mode eq 'last') {
|
||||
$map->{$key} = $value;
|
||||
}
|
||||
}
|
||||
push(@values,$value);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return ($map,\@keys,\@values);
|
||||
|
||||
}
|
||||
|
||||
sub mapeq {
|
||||
my ($map_prt1,$map_prt2,$case_insensitive) = @_;
|
||||
my $key_count1;
|
||||
my $key_count2;
|
||||
if (defined $map_prt1 and ref $map_prt1 eq 'HASH') {
|
||||
$key_count1 = (scalar keys %$map_prt1);
|
||||
} else {
|
||||
$key_count1 = 0;
|
||||
}
|
||||
if (defined $map_prt2 and ref $map_prt2 eq 'HASH') {
|
||||
$key_count2 = (scalar keys %$map_prt2);
|
||||
} else {
|
||||
$key_count2 = 0;
|
||||
}
|
||||
if ($key_count1 != $key_count2) {
|
||||
return 0; #print "they don't have the same number of keys\n";
|
||||
} else {
|
||||
my %cmp = map { $_ => 1 } keys %$map_prt1;
|
||||
if ($case_insensitive) {
|
||||
for my $key (keys %$map_prt2) {
|
||||
last unless exists $cmp{$key};
|
||||
last unless $map_prt1->{$key} eq $map_prt2->{$key};
|
||||
delete $cmp{$key};
|
||||
}
|
||||
} else {
|
||||
for my $key (keys %$map_prt2) {
|
||||
last unless exists $cmp{$key};
|
||||
last unless lc($map_prt1->{$key}) eq lc($map_prt2->{$key});
|
||||
delete $cmp{$key};
|
||||
}
|
||||
}
|
||||
if (%cmp) {
|
||||
return 0; #print "they don't have the same keys or values\n";
|
||||
} else {
|
||||
return 1; #print "they have the same keys or values\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,266 @@
|
||||
# retrieve files from emails
|
||||
|
||||
## no critic
|
||||
|
||||
package AttachmentDownloader;
|
||||
use strict;
|
||||
|
||||
use Logging qw(
|
||||
getlogger
|
||||
attachmentdownloaderdebug
|
||||
attachmentdownloaderinfo
|
||||
);
|
||||
use LogError qw(
|
||||
fileerror
|
||||
attachmentdownloadererror
|
||||
attachmentdownloaderwarn
|
||||
);
|
||||
|
||||
use Email::MIME;
|
||||
use Email::MIME::Attachment::Stripper;
|
||||
use URI::Find;
|
||||
#use File::Fetch;
|
||||
#use LWP::Simple;
|
||||
use LWP::UserAgent;
|
||||
use HTTP::Request;
|
||||
#use HTTP::Cookies;
|
||||
|
||||
use Utils qw(kbytes2gigs changemod);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
$attachment_no_match
|
||||
$attachment_match
|
||||
$attachment_found
|
||||
);
|
||||
|
||||
our $attachment_no_match = 0;
|
||||
our $attachment_match = 1;
|
||||
our $attachment_found = 2;
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
sub new {
|
||||
|
||||
my ($class,$derived_class,@params) = @_;
|
||||
my $self = bless {}, $derived_class;
|
||||
$self->{download_urls} = 0;
|
||||
$self->setup(@params);
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub setup {
|
||||
|
||||
my $self = shift;
|
||||
my (@params) = @_;
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub logout {
|
||||
|
||||
my $self = shift;
|
||||
my (@params) = @_;
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub download {
|
||||
|
||||
my $self = shift;
|
||||
my ($filedir) = @_;
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub _process_message {
|
||||
|
||||
my $self = shift;
|
||||
my ($subject,$message_string,$filedir,$files_saved) = @_;
|
||||
|
||||
|
||||
#if (length($message_string)) {
|
||||
|
||||
attachmentdownloaderinfo('processing message "' . $subject . '"',$logger);
|
||||
|
||||
my $parsed = Email::MIME->new($message_string);
|
||||
|
||||
my $found = ($self->{download_urls} ? $self->_process_bodies($parsed,$subject,$filedir,$files_saved) : 0);
|
||||
$found = $self->_process_attachments($parsed,$subject,$filedir,$files_saved) if !$found;
|
||||
|
||||
|
||||
|
||||
|
||||
#}
|
||||
|
||||
return $found;
|
||||
|
||||
|
||||
}
|
||||
|
||||
sub _process_attachments {
|
||||
my ($self,$parsed,$subject,$filedir,$files_saved) = @_;
|
||||
|
||||
my $found = 0;
|
||||
|
||||
my $stripper = Email::MIME::Attachment::Stripper->new($parsed, (force_filename => 1));
|
||||
|
||||
my @attachments = $stripper->attachments();
|
||||
|
||||
foreach my $attachment (@attachments) {
|
||||
$attachment->{subject} = $subject;
|
||||
$attachment->{size} = length($attachment->{payload});
|
||||
$attachment->{match} = undef;
|
||||
if (defined $self->{checkfilenamecode} and ref $self->{checkfilenamecode} eq 'CODE') {
|
||||
my $match = &{$self->{checkfilenamecode}}($attachment);
|
||||
if ($match == $attachment_no_match) {
|
||||
attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') skipped',$logger);
|
||||
next;
|
||||
} elsif ($match == $attachment_found) {
|
||||
attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') found',$logger);
|
||||
$found = 1;
|
||||
} elsif ($match == $attachment_match) {
|
||||
attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') matched',$logger);
|
||||
} else {
|
||||
attachmentdownloaderwarn('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') - unknown match, skipped',$logger);
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
_save_file($attachment,$filedir,$files_saved);
|
||||
|
||||
|
||||
}
|
||||
return $found;
|
||||
}
|
||||
|
||||
sub _save_file {
|
||||
|
||||
my ($attachment,$filedir,$files_saved) = @_;
|
||||
my $filepath = $filedir . $attachment->{filename};
|
||||
|
||||
unlink $filepath;
|
||||
|
||||
local *ATTACHMENTFILE;
|
||||
if (not open (ATTACHMENTFILE,'>' . $filepath)) {
|
||||
fileerror('cannot open file ' . $filepath . ': ' . $!,$logger);
|
||||
return; # $files_saved;
|
||||
}
|
||||
binmode(ATTACHMENTFILE);
|
||||
print ATTACHMENTFILE $attachment->{payload};
|
||||
|
||||
close(ATTACHMENTFILE);
|
||||
changemod($filepath);
|
||||
|
||||
push(@$files_saved,{ saved => $filepath, match => $attachment->{match} });
|
||||
|
||||
attachmentdownloaderinfo('attachment saved: ' . $filepath,$logger);
|
||||
}
|
||||
|
||||
sub _process_bodies {
|
||||
|
||||
my ($self,$parsed,$subject,$filedir,$files_saved) = @_;
|
||||
|
||||
my $found = 0;
|
||||
|
||||
$parsed->walk_parts(sub {
|
||||
my ($part) = @_;
|
||||
return if $found;
|
||||
if ((scalar $part->subparts) > 0) {
|
||||
foreach my $subpart ($part->subparts) {
|
||||
if (!$found) {
|
||||
$found = $self->_process_body($subpart,$subject,$found,$filedir,$files_saved);
|
||||
} else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$found = $self->_process_body($part,$subject,$found,$filedir,$files_saved);
|
||||
}
|
||||
});
|
||||
|
||||
return $found;
|
||||
}
|
||||
|
||||
sub _process_body {
|
||||
my ($self,$part,$subject,$found,$filedir,$files_saved) = @_;
|
||||
|
||||
if ($part->content_type =~ m/text\//i) {
|
||||
my %uris;
|
||||
my $finder = URI::Find->new(sub {
|
||||
my ($uri,$orig_uri) = @_;
|
||||
my $url = $uri->as_string;
|
||||
if ($url =~ /^http/i) {
|
||||
$uris{$url} = undef;
|
||||
}
|
||||
});
|
||||
my $body = $part->body;
|
||||
$finder->find(\$body);
|
||||
if ((scalar keys %uris) > 0) {
|
||||
foreach my $uri (sort keys %uris) {
|
||||
my $attachment = _download_file($uri);
|
||||
if ($attachment) {
|
||||
$attachment->{subject} = $subject;
|
||||
$attachment->{size} = length($attachment->{payload});
|
||||
$attachment->{match} = undef;
|
||||
|
||||
if (defined $self->{checkfilenamecode} and ref $self->{checkfilenamecode} eq 'CODE') {
|
||||
my $match = &{$self->{checkfilenamecode}}($attachment);
|
||||
if ($match == $attachment_no_match) {
|
||||
attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') skipped',$logger);
|
||||
next;
|
||||
} elsif ($match == $attachment_found) {
|
||||
attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') found',$logger);
|
||||
$found = 1;
|
||||
} elsif ($match == $attachment_match) {
|
||||
attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') matched',$logger);
|
||||
} else {
|
||||
attachmentdownloaderwarn('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') - unknown match, skipped',$logger);
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
_save_file($attachment,$filedir,$files_saved);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
attachmentdownloaderinfo("no urls for download found in part '" . $part->content_type . "'",$logger);
|
||||
}
|
||||
}
|
||||
|
||||
return $found;
|
||||
}
|
||||
|
||||
sub _download_file { # .. dropbox links and the like
|
||||
my ($uri) = @_;
|
||||
my $ua = LWP::UserAgent->new;
|
||||
$ua->timeout(10);
|
||||
$ua->ssl_opts(
|
||||
verify_hostname => 0,
|
||||
);
|
||||
$ua->cookie_jar({});
|
||||
my $request = HTTP::Request->new('GET', $uri);
|
||||
attachmentdownloaderinfo('downloading ' . $uri,$logger);
|
||||
my $response = $ua->request($request);
|
||||
if ($response->code == 200) {
|
||||
my $attachment = {};
|
||||
$attachment->{uri} = $uri;
|
||||
$attachment->{payload} = $response->decoded_content( charset => 'none' );
|
||||
#$attachment->{size} = $response->header('content-length'); # -s $attachment->{payload};
|
||||
($attachment->{filename}) = ($response->header('Content-Disposition') =~ m/"([^"]+)"/);
|
||||
return $attachment;
|
||||
} else {
|
||||
attachmentdownloaderwarn('downloading ' . $uri . ' failed',$logger);
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
|
||||
my $self = shift;
|
||||
$self->logout();
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,239 @@
|
||||
package ConnectorPool;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use Globals qw(
|
||||
$system_abbreviation
|
||||
$system_instance
|
||||
|
||||
$accounting_databasename
|
||||
$accounting_username
|
||||
$accounting_password
|
||||
$accounting_host
|
||||
$accounting_port
|
||||
|
||||
$billing_databasename
|
||||
$billing_username
|
||||
$billing_password
|
||||
$billing_host
|
||||
$billing_port
|
||||
|
||||
);
|
||||
|
||||
|
||||
use Logging qw(getlogger);
|
||||
use LogError qw(dbclustererror dbclusterwarn); #nodumpdbset
|
||||
|
||||
use SqlConnectors::MySQLDB;
|
||||
#use SqlConnectors::OracleDB;
|
||||
#use SqlConnectors::PostgreSQLDB;
|
||||
#use SqlConnectors::SQLiteDB qw($staticdbfilemode
|
||||
# cleanupdbfiles);
|
||||
#use SqlConnectors::CSVDB;
|
||||
#use SqlConnectors::SQLServerDB;
|
||||
|
||||
use SqlRecord qw(cleartableinfo);
|
||||
|
||||
use Utils qw(threadid);
|
||||
|
||||
use Array qw(
|
||||
filter
|
||||
mergearrays
|
||||
getroundrobinitem
|
||||
getrandomitem
|
||||
);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
get_accounting_db
|
||||
accounting_db_tableidentifier
|
||||
|
||||
get_billing_db
|
||||
billing_db_tableidentifier
|
||||
|
||||
destroy_dbs
|
||||
);
|
||||
|
||||
my $connectorinstancenameseparator = '_';
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
# thread connector pools:
|
||||
my $sql_dbs = {};
|
||||
|
||||
sub register_sql_db {
|
||||
my ($class,$name) = @_;
|
||||
my $registered = 0;
|
||||
if (!exists $sql_connectors->{$class}) {
|
||||
$sql_connectors->{$class} = {};
|
||||
}
|
||||
if (!exists $sql_connectors->{$class}->{$name}) {
|
||||
$sql_connectors->{$class}->{$name} = {};
|
||||
$registered = 1;
|
||||
}
|
||||
return $registered;
|
||||
}
|
||||
|
||||
sub get_sql_db {
|
||||
my ($instance_name,$reconnect) = @_;
|
||||
}
|
||||
|
||||
my $accounting_dbs = {};
|
||||
my $billing_dbs = {};
|
||||
|
||||
|
||||
sub get_accounting_db {
|
||||
|
||||
my ($instance_name,$reconnect) = @_;
|
||||
my $name = _get_connectorinstancename($instance_name); #threadid(); #shift;
|
||||
if (not defined $accounting_dbs->{$name}) {
|
||||
$accounting_dbs->{$name} = SqlConnectors::MySQLDB->new($instance_name); #$name);
|
||||
if (not defined $reconnect) {
|
||||
$reconnect = 1;
|
||||
}
|
||||
}
|
||||
if ($reconnect) {
|
||||
$accounting_dbs->{$name}->db_connect($accounting_databasename,$accounting_username,$accounting_password,$accounting_host,$accounting_port);
|
||||
}
|
||||
return $accounting_dbs->{$name};
|
||||
|
||||
}
|
||||
|
||||
sub accounting_db_tableidentifier {
|
||||
|
||||
my ($get_target_db,$tablename) = @_;
|
||||
my $target_db = (ref $get_target_db eq 'CODE') ? &$get_target_db() : $get_target_db;
|
||||
return $target_db->getsafetablename(SqlConnectors::MySQLDB::get_tableidentifier($tablename,$accounting_databasename));
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub get_billing_db {
|
||||
|
||||
my ($instance_name,$reconnect) = @_;
|
||||
my $name = _get_connectorinstancename($instance_name); #threadid(); #shift;
|
||||
if (not defined $billing_dbs->{$name}) {
|
||||
$billing_dbs->{$name} = SqlConnectors::MySQLDB->new($instance_name); #$name);
|
||||
if (not defined $reconnect) {
|
||||
$reconnect = 1;
|
||||
}
|
||||
}
|
||||
if ($reconnect) {
|
||||
$billing_dbs->{$name}->db_connect($billing_databasename,$billing_username,$billing_password,$billing_host,$billing_port);
|
||||
}
|
||||
return $billing_dbs->{$name};
|
||||
|
||||
}
|
||||
|
||||
sub billing_db_tableidentifier {
|
||||
|
||||
my ($get_target_db,$tablename) = @_;
|
||||
my $target_db = (ref $get_target_db eq 'CODE') ? &$get_target_db() : $get_target_db;
|
||||
return $target_db->getsafetablename(SqlConnectors::MySQLDB::get_tableidentifier($tablename,$billing_databasename));
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub _get_connectorinstancename {
|
||||
my ($name) = @_;
|
||||
my $instance_name = threadid();
|
||||
if (length($name) > 0) {
|
||||
$instance_name .= $connectorinstancenameseparator . $name;
|
||||
}
|
||||
return $instance_name;
|
||||
}
|
||||
|
||||
sub destroy_dbs {
|
||||
|
||||
my $name;
|
||||
|
||||
|
||||
foreach $name (keys %$accounting_dbs) {
|
||||
cleartableinfo($accounting_dbs->{$name});
|
||||
undef $accounting_dbs->{$name};
|
||||
delete $accounting_dbs->{$name};
|
||||
}
|
||||
|
||||
foreach $name (keys %$billing_dbs) {
|
||||
cleartableinfo($billing_dbs->{$name});
|
||||
undef $billing_dbs->{$name};
|
||||
delete $billing_dbs->{$name};
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub _get_cluster_db { # oracle RAC and the like ...
|
||||
|
||||
my ($cluster,$instance_name,$reconnect) = @_;
|
||||
#if ((defined $cluster) and ref $cluster ne 'HASH') {
|
||||
my $node = undef;
|
||||
my $tid = threadid();
|
||||
if ((not defined $cluster->{scheduling_vars}) or ref $cluster->{scheduling_vars} ne 'HASH') {
|
||||
$cluster->{scheduling_vars} = {};
|
||||
}
|
||||
my $scheduling_vars = $cluster->{scheduling_vars};
|
||||
if ((not defined $scheduling_vars->{$tid}) or ref $scheduling_vars->{$tid} ne 'HASH') {
|
||||
$scheduling_vars->{$tid} = {};
|
||||
}
|
||||
$scheduling_vars = $scheduling_vars->{$tid};
|
||||
my $nodes;
|
||||
if (not defined $scheduling_vars->{nodes}) {
|
||||
$nodes = {};
|
||||
foreach my $node (@{$cluster->{nodes}}) {
|
||||
if (defined $node and ref $node eq 'HASH') {
|
||||
if ($node->{active}) {
|
||||
$nodes->{$node->{label}} = $node;
|
||||
}
|
||||
} else {
|
||||
dbclustererror($cluster->{name},'node configuration error',$logger);
|
||||
}
|
||||
}
|
||||
$scheduling_vars->{nodes} = $nodes;
|
||||
} else {
|
||||
$nodes = $scheduling_vars->{nodes};
|
||||
}
|
||||
my @active_nodes = @{$nodes}{sort keys(%$nodes)}; #hash slice
|
||||
if (defined $cluster->{scheduling_code} and ref $cluster->{scheduling_code} eq 'CODE') {
|
||||
my $cluster_instance_name;
|
||||
if (length($instance_name) > 0) {
|
||||
$cluster_instance_name = $cluster->{name} . $connectorinstancenameseparator . $instance_name;
|
||||
} else {
|
||||
$cluster_instance_name = $cluster->{name};
|
||||
}
|
||||
($node,$scheduling_vars->{node_index}) = &{$cluster->{scheduling_code}}(\@active_nodes,$scheduling_vars->{node_index});
|
||||
if (defined $node) {
|
||||
my $get_db = $node->{get_db};
|
||||
if (defined $get_db and ref $get_db eq 'CODE') {
|
||||
my $db = undef;
|
||||
eval {
|
||||
$db = &{$get_db}($cluster_instance_name,$reconnect,$cluster);
|
||||
};
|
||||
if ($@) {
|
||||
dbclusterwarn($cluster->{name},'node ' . $node->{label} . ' inactive',$logger);
|
||||
delete $nodes->{$node->{label}};
|
||||
return _get_cluster_db($cluster,$instance_name,$reconnect);
|
||||
} else {
|
||||
#$db->cluster($cluster);
|
||||
return $db;
|
||||
}
|
||||
} else {
|
||||
dbclustererror($cluster->{name},'node ' . $node->{label} . ' configuration error',$logger);
|
||||
delete $nodes->{$node->{label}};
|
||||
return _get_cluster_db($cluster,$instance_name,$reconnect);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
dbclustererror($cluster->{name},'scheduling configuration error',$logger);
|
||||
return undef;
|
||||
}
|
||||
|
||||
#}
|
||||
dbclustererror($cluster->{name},'cannot switch to next active node',$logger);
|
||||
return undef;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,186 @@
|
||||
package DSSorter;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
# guarantee stability, regardless of algorithm
|
||||
use sort 'stable';
|
||||
|
||||
use Logging qw(getlogger);
|
||||
use LogError qw(sortconfigerror);
|
||||
|
||||
use Table;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(sort_by_config_ids
|
||||
sort_by_configs);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
$self->{sortconfig} = Table->new();
|
||||
bless($self,$class);
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub add_sorting {
|
||||
|
||||
my $self = shift;
|
||||
my ($sorting_id,$numeric,$dir,$memberchain) = @_;
|
||||
|
||||
if (defined $memberchain and ref $memberchain eq 'ARRAY') {
|
||||
my @fieldnames = @$memberchain;
|
||||
if ((scalar @fieldnames) > 0) {
|
||||
$self->{sortconfig}->addrow_nodupe($numeric,$dir,@fieldnames);
|
||||
}
|
||||
} else {
|
||||
sortconfigerror($sorting_id,'chain of object members undefined/invalid',$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub clear_sorting {
|
||||
|
||||
my $self = shift;
|
||||
$self->{sortconfig}->clear();
|
||||
|
||||
}
|
||||
|
||||
sub sort_array {
|
||||
|
||||
my $self = shift;
|
||||
my $array_ptr = shift;
|
||||
|
||||
my $sortconfig = $self->{sortconfig};
|
||||
|
||||
my $sorter = sub ($$) {
|
||||
|
||||
my $a = shift;
|
||||
my $b = shift;
|
||||
|
||||
my $result = 0;
|
||||
|
||||
for (my $i = 0; $i < $sortconfig->rowcount(); $i++) {
|
||||
|
||||
my $j = 2;
|
||||
my $membername = $sortconfig->element($i,$j);
|
||||
my $item_a = ($a ? $a->{$membername} : undef);
|
||||
my $item_b = ($b ? $b->{$membername} : undef);
|
||||
$j++;
|
||||
$membername = $sortconfig->element($i,$j);
|
||||
while (defined $membername) {
|
||||
|
||||
$item_a = ($item_a ? $item_a->{$membername} : undef);
|
||||
$item_b = ($item_b ? $item_b->{$membername} : undef);
|
||||
$j++;
|
||||
$membername = $sortconfig->element($i,$j);
|
||||
|
||||
}
|
||||
|
||||
$result = ($result or
|
||||
|
||||
(
|
||||
|
||||
$sortconfig->element($i,0) ?
|
||||
($item_a <=> $item_b) : ($item_a cmp $item_b)
|
||||
|
||||
) * $sortconfig->element($i,1)
|
||||
|
||||
);
|
||||
|
||||
}
|
||||
|
||||
return $result;
|
||||
|
||||
};
|
||||
my @sorted = ();
|
||||
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
@sorted = sort $sorter @$array_ptr;
|
||||
}
|
||||
|
||||
return \@sorted;
|
||||
|
||||
}
|
||||
|
||||
sub sort_by_config_ids {
|
||||
|
||||
my ($array_ptr,$sortings,$sortingconfigurations) = @_;
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
if (defined $sortings and ref $sortings eq 'ARRAY') {
|
||||
if (defined $sortingconfigurations and
|
||||
ref $sortingconfigurations eq 'HASH') {
|
||||
my @sorting_ids = @$sortings;
|
||||
if ((scalar @sorting_ids) > 0) {
|
||||
my $sorter = DSSorter->new();
|
||||
foreach my $sorting_id (@sorting_ids) {
|
||||
my $sc = $sortingconfigurations->{$sorting_id};
|
||||
if (defined $sc and ref $sc eq 'HASH') {
|
||||
$sorter->add_sorting($sorting_id,
|
||||
$sc->{numeric},
|
||||
$sc->{dir},
|
||||
$sc->{memberchain});
|
||||
} else {
|
||||
sortconfigerror($sorting_id,
|
||||
'missing/invalid sorting configuration',
|
||||
$logger);
|
||||
}
|
||||
}
|
||||
return $sorter->sort_array($array_ptr);
|
||||
}
|
||||
} else {
|
||||
sortconfigerror(undef,
|
||||
'missing/invalid sorting configurations',
|
||||
$logger);
|
||||
}
|
||||
}
|
||||
return $array_ptr;
|
||||
} else {
|
||||
return [];
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub sort_by_configs {
|
||||
|
||||
my ($array_ptr,$sortingconfigurations) = @_;
|
||||
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
||||
|
||||
if (defined $sortingconfigurations and
|
||||
ref $sortingconfigurations eq 'ARRAY') {
|
||||
|
||||
my @scs = @$sortingconfigurations;
|
||||
if ((scalar @scs) > 0) {
|
||||
my $sorter = DSSorter->new();
|
||||
my $sorting_id = -1;
|
||||
foreach my $sc (@scs) {
|
||||
#my $sc = $sortingconfigurations->{$sorting_id};
|
||||
if (defined $sc and ref $sc eq 'HASH') {
|
||||
$sorter->add_sorting($sorting_id,
|
||||
$sc->{numeric},
|
||||
$sc->{dir},
|
||||
$sc->{memberchain});
|
||||
} else {
|
||||
sortconfigerror($sorting_id,
|
||||
'invalid sorting configuration',
|
||||
$logger);
|
||||
}
|
||||
$sorting_id -= 1;
|
||||
}
|
||||
return $sorter->sort_array($array_ptr);
|
||||
}
|
||||
|
||||
}
|
||||
return $array_ptr;
|
||||
} else {
|
||||
return [];
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,105 @@
|
||||
|
||||
package billing::contract_balances;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Logging qw(getlogger);
|
||||
|
||||
use ConnectorPool qw(get_billing_db
|
||||
billing_db_tableidentifier);
|
||||
|
||||
use SqlRecord qw(checktableinfo);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlRecord);
|
||||
our @EXPORT_OK = qw(
|
||||
XX
|
||||
backoffice_client_byboclientid
|
||||
sync_table
|
||||
drop_table
|
||||
|
||||
check_local_table
|
||||
check_source_table);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $tablename = 'contract_balances';
|
||||
my $get_db = \&get_billing_db;
|
||||
my $get_tablename = \&billing_db_tableidentifier;
|
||||
|
||||
my $expected_fieldnames = [
|
||||
'id',
|
||||
'contract_id',
|
||||
'cash_balance',
|
||||
'cash_balance_interval',
|
||||
'free_time_balance',
|
||||
'free_time_balance_interval',
|
||||
'topup_count',
|
||||
'timely_topup_count',
|
||||
'start',
|
||||
'end',
|
||||
'invoice_id',
|
||||
'underrun_profiles',
|
||||
'underrun_lock',
|
||||
];
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
my $self = SqlRecord->new($get_db,
|
||||
gettablename(),
|
||||
$expected_fieldnames);
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
copy_row($self,shift,$expected_fieldnames);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub buildrecords_fromrows {
|
||||
|
||||
my ($rows,$load_recursive) = @_;
|
||||
|
||||
my @records = ();
|
||||
my $record;
|
||||
|
||||
if (defined $rows and ref $rows eq 'ARRAY') {
|
||||
foreach my $row (@$rows) {
|
||||
$record = __PACKAGE__->new($row);
|
||||
|
||||
# transformations go here ...
|
||||
|
||||
push @records,$record;
|
||||
}
|
||||
}
|
||||
|
||||
return \@records;
|
||||
|
||||
}
|
||||
|
||||
sub gettablename {
|
||||
|
||||
my $db = &$get_local_db();
|
||||
return &$get_tablename($db,$tablename);
|
||||
|
||||
}
|
||||
|
||||
sub check_table {
|
||||
|
||||
my $db = &$get_local_db();
|
||||
|
||||
return checktableinfo($get_db,
|
||||
gettablename(),
|
||||
$expected_fieldnames);
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,105 @@
|
||||
|
||||
package mr28::billing::contract_balances;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Logging qw(getlogger);
|
||||
|
||||
use ConnectorPool qw(get_billing_db
|
||||
billing_db_tableidentifier);
|
||||
|
||||
use SqlRecord qw(checktableinfo);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlRecord);
|
||||
our @EXPORT_OK = qw(
|
||||
XX
|
||||
backoffice_client_byboclientid
|
||||
sync_table
|
||||
drop_table
|
||||
|
||||
check_local_table
|
||||
check_source_table);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $tablename = 'contract_balances';
|
||||
my $get_db = \&get_billing_db;
|
||||
my $get_tablename = \&billing_db_tableidentifier;
|
||||
|
||||
my $expected_fieldnames = [
|
||||
'id',
|
||||
'contract_id',
|
||||
'cash_balance',
|
||||
'cash_balance_interval',
|
||||
'free_time_balance',
|
||||
'free_time_balance_interval',
|
||||
'topup_count',
|
||||
'timely_topup_count',
|
||||
'start',
|
||||
'end',
|
||||
'invoice_id',
|
||||
'underrun_profiles',
|
||||
'underrun_lock',
|
||||
];
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
my $self = SqlRecord->new($get_db,
|
||||
gettablename(),
|
||||
$expected_fieldnames);
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
copy_row($self,shift,$expected_fieldnames);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub buildrecords_fromrows {
|
||||
|
||||
my ($rows,$load_recursive) = @_;
|
||||
|
||||
my @records = ();
|
||||
my $record;
|
||||
|
||||
if (defined $rows and ref $rows eq 'ARRAY') {
|
||||
foreach my $row (@$rows) {
|
||||
$record = __PACKAGE__->new($row);
|
||||
|
||||
# transformations go here ...
|
||||
|
||||
push @records,$record;
|
||||
}
|
||||
}
|
||||
|
||||
return \@records;
|
||||
|
||||
}
|
||||
|
||||
sub gettablename {
|
||||
|
||||
my $db = &$get_local_db();
|
||||
return &$get_tablename($db,$tablename);
|
||||
|
||||
}
|
||||
|
||||
sub check_table {
|
||||
|
||||
my $db = &$get_local_db();
|
||||
|
||||
return checktableinfo($get_db,
|
||||
gettablename(),
|
||||
$expected_fieldnames);
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,183 @@
|
||||
package Downloaders::IMAPAttachmentDownloader;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Logging qw(
|
||||
getlogger
|
||||
attachmentdownloaderdebug
|
||||
attachmentdownloaderinfo
|
||||
);
|
||||
use LogError qw(
|
||||
fileerror
|
||||
attachmentdownloadererror
|
||||
attachmentdownloaderwarn
|
||||
);
|
||||
|
||||
use Utils qw(kbytes2gigs changemod);
|
||||
|
||||
use IO::Socket::SSL;
|
||||
use Mail::IMAPClient;
|
||||
use MIME::Base64;
|
||||
#use GSSAPI;
|
||||
#use Authen::SASL::Perl;
|
||||
#use Authen::SASL::Perl::GSSAPI;
|
||||
#use Authen::SASL qw(Perl);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter AttachmentDownloader);
|
||||
our @EXPORT_OK = qw();
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
my ($server,$ssl,$user,$pass,$foldername,$checkfilenamecode,$download_urls) = @_;
|
||||
my $self = AttachmentDownloader->new($class,$server,$ssl,$user,$pass,$foldername,$checkfilenamecode,$download_urls);
|
||||
attachmentdownloaderdebug('IMAP attachment downloader object created',$logger);
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub logout {
|
||||
my $self = shift;
|
||||
if (defined $self->{imap}) {
|
||||
if ($self->{imap}->logout()) {
|
||||
attachmentdownloaderinfo('IMAP logout successful',$logger);
|
||||
} else {
|
||||
attachmentdownloaderwarn($@,$logger);
|
||||
}
|
||||
$self->{imap} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub setup {
|
||||
|
||||
my $self = shift;
|
||||
my ($server,$ssl,$user,$pass,$foldername,$checkfilenamecode,$download_urls) = @_; #,$mimetypes) = @_;
|
||||
|
||||
$self->logout();
|
||||
|
||||
attachmentdownloaderdebug('IMAP attachment downloader setup - ' . $server . ($ssl ? ' (SSL)' : ''),$logger);
|
||||
|
||||
$self->{server} = $server;
|
||||
$self->{ssl} = $ssl;
|
||||
$self->{foldername} = $foldername;
|
||||
#$self->{mimetypes} = $mimetypes;
|
||||
$self->{checkfilenamecode} = $checkfilenamecode;
|
||||
#$self->{imap} = undef;
|
||||
$self->{download_urls} = $download_urls;
|
||||
|
||||
#* OK The Microsoft Exchange IMAP4 service is ready.
|
||||
#a1 capability
|
||||
#* CAPABILITY IMAP4 IMAP4rev1 AUTH=NTLM AUTH=GSSAPI AUTH=PLAIN STARTTLS UIDPLUS CHILDREN IDLE NAMESPACE LITERAL+
|
||||
|
||||
my %opts = (
|
||||
User => $user,
|
||||
Password => $pass,
|
||||
Uid => 1,
|
||||
Peek => 1, # don't set \Seen flag)
|
||||
Debug => 0,
|
||||
IgnoreSizeErrors => 1,
|
||||
Authmechanism => 'LOGIN',
|
||||
#Authmechanism => 'NTLM', #'DIGEST-MD5', # DIGEST-MD5 'LOGIN', #CRAM-MD5 NTLM
|
||||
);
|
||||
|
||||
if ($ssl) {
|
||||
$opts{Socket} = IO::Socket::SSL->new(
|
||||
Proto => 'tcp',
|
||||
PeerAddr => $server,
|
||||
PeerPort => 993,
|
||||
) or attachmentdownloadererror($@,$logger);
|
||||
} else {
|
||||
$opts{Server} = $server;
|
||||
}
|
||||
|
||||
my $imap = Mail::IMAPClient->new(%opts) or attachmentdownloadererror($@,$logger);
|
||||
|
||||
#eval {
|
||||
#my ($gss_api_step, $sasl, $conn, $cred) = (0, undef, undef, GSSAPI::Cred);
|
||||
#$imap->authenticate('GSSAPI', sub {
|
||||
# $gss_api_step++;
|
||||
# if ($gss_api_step == 1) {
|
||||
# $sasl = Authen::SASL->new(
|
||||
# mechanism => 'GSSAPI',
|
||||
# debug => 1,
|
||||
# callback => { pass => $pass,
|
||||
# user => $user,
|
||||
# }
|
||||
# );
|
||||
# $conn = $sasl->client_new('imap', $server);
|
||||
# my $mesg = $conn->client_start() or attachmentdownloadererror($@,$logger);
|
||||
# print "mesg $gss_api_step: " . $mesg;
|
||||
# return encode_base64($mesg, '');
|
||||
# } else {
|
||||
# my $mesg = $conn->client_step(decode_base64($_[0]));
|
||||
# print "mesg $gss_api_step: " . $mesg;
|
||||
# return encode_base64($mesg, '');
|
||||
# }
|
||||
# });
|
||||
#};
|
||||
if ($@) {
|
||||
attachmentdownloadererror($@,$logger);
|
||||
} else {
|
||||
attachmentdownloaderinfo('IMAP login successful',$logger);
|
||||
}
|
||||
|
||||
$imap->select($foldername) or attachmentdownloadererror('cannot select ' . $foldername . ': ' . $imap->LastError,$logger); #'folder ' . $foldername . ' not found: '
|
||||
attachmentdownloaderdebug('folder ' . $foldername . ' selected',$logger);
|
||||
|
||||
$self->{imap} = $imap;
|
||||
|
||||
}
|
||||
|
||||
sub download {
|
||||
|
||||
my $self = shift;
|
||||
my $filedir = shift;
|
||||
|
||||
my @files_saved = ();
|
||||
my $message_count = 0;
|
||||
|
||||
if (defined $self->{imap}) {
|
||||
|
||||
attachmentdownloaderinfo('searching messages from folder ' . $self->{foldername},$logger);
|
||||
|
||||
my $found = 0;
|
||||
|
||||
my $message_ids = $self->{imap}->search('ALL');
|
||||
if (defined $message_ids and ref $message_ids eq 'ARRAY') {
|
||||
foreach my $id (@$message_ids) {
|
||||
attachmentdownloadererror('invalid message id ' . $id,$logger) unless $id =~ /\A\d+\z/;
|
||||
my $message_string = $self->{imap}->message_string($id) or attachmentdownloadererror($@,$logger);
|
||||
|
||||
$found |= $self->_process_message($self->{imap}->subject($id),$message_string,$filedir,\@files_saved);
|
||||
$message_count++;
|
||||
|
||||
if ($found) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if ($@) {
|
||||
attachmentdownloadererror($@,$logger);
|
||||
}
|
||||
}
|
||||
|
||||
if (scalar @files_saved == 0) {
|
||||
attachmentdownloaderwarn('IMAP download complete - ' . $message_count . ' messages found, but no matching attachments saved',$logger);
|
||||
} else {
|
||||
attachmentdownloaderinfo('IMAP attachment download complete - ' . scalar @files_saved . ' files saved',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
return \@files_saved;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,299 @@
|
||||
package Globals;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use 5.8.8;
|
||||
|
||||
use threads; # as early as possible...
|
||||
use threads::shared;
|
||||
|
||||
use Time::HiRes qw(time);
|
||||
|
||||
use Tie::IxHash;
|
||||
|
||||
use Cwd 'abs_path';
|
||||
use File::Basename qw(dirname);
|
||||
|
||||
use Utils qw(
|
||||
get_ipaddress
|
||||
get_hostfqdn
|
||||
get_cpucount
|
||||
$chmod_umask);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
$system_name
|
||||
$system_version
|
||||
$system_abbreviation
|
||||
$system_instance
|
||||
$system_instance_label
|
||||
$local_ip
|
||||
$local_fqdn
|
||||
$application_path
|
||||
$appstartsecs
|
||||
$enablemultithreading
|
||||
$root_threadid
|
||||
$cpucount
|
||||
|
||||
$cells_transfer_memory_limit
|
||||
$LongReadLen_limit
|
||||
$defer_indexes
|
||||
|
||||
$accounting_databasename
|
||||
$accounting_username
|
||||
$accounting_password
|
||||
$accounting_host
|
||||
$accounting_port
|
||||
|
||||
$billing_databasename
|
||||
$billing_username
|
||||
$billing_password
|
||||
$billing_host
|
||||
$billing_port
|
||||
|
||||
$csv_path
|
||||
|
||||
|
||||
$local_db_path
|
||||
$emailenable
|
||||
$erroremailrecipient
|
||||
$warnemailrecipient
|
||||
$completionemailrecipient
|
||||
$successemailrecipient
|
||||
$mailfilepath
|
||||
|
||||
$ismsexchangeserver
|
||||
$sender_address
|
||||
$smtp_server
|
||||
$smtpuser
|
||||
$smtppasswd
|
||||
$writefiles
|
||||
$tpath
|
||||
|
||||
$logfile_path
|
||||
$fileloglevel
|
||||
$screenloglevel
|
||||
$emailloglevel
|
||||
$mailprog
|
||||
$mailtype
|
||||
|
||||
|
||||
$defaultconfig
|
||||
|
||||
update_mainconfig
|
||||
log_mainconfig
|
||||
|
||||
|
||||
$chmod_umask
|
||||
|
||||
@jobservers
|
||||
$jobnamespace
|
||||
|
||||
|
||||
|
||||
);
|
||||
|
||||
|
||||
#set process umask for open and mkdir calls:
|
||||
umask oct($chmod_umask);
|
||||
|
||||
# general constants
|
||||
our $system_name = 'Sipwise Bulk Processor Framework';
|
||||
our $system_version = '0.0.1'; #keep this filename-save
|
||||
our $system_abbreviation = 'bpf'; #keep this filename-, dbname-save
|
||||
our $system_instance = 'initial'; #'test'; #'2014'; #dbname-save 0-9a-z_
|
||||
our $system_instance_label = 'test';
|
||||
|
||||
our $local_ip = get_ipaddress();
|
||||
our $local_fqdn = get_hostfqdn();
|
||||
our $application_path = get_applicationpath();
|
||||
#my $remotefilesystem = "MSWin32";
|
||||
our $system_username = 'system';
|
||||
|
||||
|
||||
our $enablemultithreading;
|
||||
if ($^O eq 'MSWin32') {
|
||||
$enablemultithreading = 1; # tested ok with windows.
|
||||
} else {
|
||||
$enablemultithreading = 1; # oel 5.4 perl 5.8.8 obvoisly not ok.
|
||||
}
|
||||
|
||||
our $cpucount = get_cpucount();
|
||||
|
||||
our $root_threadid = 0; #threadid() . ''; #0
|
||||
our $cells_transfer_memory_limit = 10000000; #db fields
|
||||
our $defer_indexes = 1;
|
||||
#http://docstore.mik.ua/orelly/linux/dbi/ch06_01.htm
|
||||
our $LongReadLen_limit = 128*1024; #longest LOB field size in bytes
|
||||
|
||||
our $appstartsecs = Time::HiRes::time();
|
||||
|
||||
|
||||
|
||||
|
||||
our $accounting_databasename = 'accounting';
|
||||
our $accounting_username = 'root';
|
||||
our $accounting_password = '';
|
||||
our $accounting_host = '127.0.0.1';
|
||||
our $accounting_port = '3306';
|
||||
|
||||
our $billing_databasename = 'accounting';
|
||||
our $billing_username = 'root';
|
||||
our $billing_password = '';
|
||||
our $billing_host = '127.0.0.1';
|
||||
our $billing_port = '3306';
|
||||
|
||||
|
||||
# csv
|
||||
our $csv_path = $application_path . 'csv/';
|
||||
#mkdir $csv_path;
|
||||
|
||||
# logging
|
||||
our $logfile_path = $application_path . 'log/';
|
||||
#mkdir $logfile_path;
|
||||
|
||||
our $fileloglevel = 'OFF'; #'DEBUG';
|
||||
our $screenloglevel = 'OFF'; #'DEBUG';
|
||||
|
||||
our $emailloglevel = 'OFF'; #'INFO';
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# local db setup
|
||||
our $local_db_path = $application_path . 'db/';
|
||||
#mkdir $local_db_path;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# email setup
|
||||
#set emailenable and writefiles to 0 during development with IDE that perform
|
||||
#on-the-fly compilation during typing
|
||||
our $emailenable = 0; # globally enable email sending
|
||||
our $mailfilepath = $application_path . 'mails/'; # emails can be saved (logged) as message files to this folder
|
||||
#mkdir $mailfilepath;
|
||||
our $writefiles = 0; # save emails
|
||||
|
||||
our $erroremailrecipient = ''; #'rkrenn@sipwise.com';
|
||||
our $warnemailrecipient = ''; #'rkrenn@sipwise.com';
|
||||
our $completionemailrecipient = '';
|
||||
our $successemailrecipient = '';
|
||||
|
||||
our $mailprog = "/usr/sbin/sendmail"; # linux only
|
||||
our $mailtype = 1; #0 .. mailprog, 1 .. socket, 2 .. Net::SMTP
|
||||
|
||||
|
||||
our $ismsexchangeserver = 0; # smtp server is a ms exchange server
|
||||
our $smtp_server = '10.146.1.17'; # smtp sever ip/hostname
|
||||
our $smtpuser = 'WORKGROUP\rkrenn';
|
||||
our $smtppasswd = 'xyz';
|
||||
our $sender_address = 'donotreply@sipwise.com';
|
||||
|
||||
|
||||
|
||||
#service layer:
|
||||
our @jobservers = ('127.0.0.1:4730');
|
||||
#our $jobnamespace = $system_abbreviation . '-' . $system_version . '-' . $local_fqdn . '-' . $system_instance;
|
||||
our $jobnamespace = $system_abbreviation . '-' . $system_version . '-' . $system_instance;
|
||||
|
||||
|
||||
|
||||
# test directory
|
||||
our $tpath = $application_path . 't/';
|
||||
#mkdir $tpath;
|
||||
|
||||
|
||||
|
||||
our $defaultconfig = 'default.cfg';
|
||||
|
||||
|
||||
sub update_mainconfig {
|
||||
|
||||
my ($config,$configfile,
|
||||
$split_tuplecode,
|
||||
$parse_floatcode,
|
||||
$configurationwarncode,
|
||||
$configurationerrorcode,
|
||||
$configlogger) = @_;
|
||||
|
||||
if (defined $config) {
|
||||
|
||||
|
||||
# databases - dsp
|
||||
$accounting_host = $config->{accounting_host} if exists $config->{accounting_host};
|
||||
$accounting_port = $config->{accounting_port} if exists $config->{accounting_port};
|
||||
$accounting_databasename = $config->{accounting_databasename} if exists $config->{accounting_databasename};
|
||||
$accounting_username = $config->{accounting_username} if exists $config->{accounting_username};
|
||||
$accounting_password = $config->{accounting_password} if exists $config->{accounting_password};
|
||||
|
||||
$billing_host = $config->{billing_host} if exists $config->{billing_host};
|
||||
$billing_port = $config->{billing_port} if exists $config->{billing_port};
|
||||
$billing_databasename = $config->{billing_databasename} if exists $config->{billing_databasename};
|
||||
$billing_username = $config->{billing_username} if exists $config->{billing_username};
|
||||
$billing_password = $config->{billing_password} if exists $config->{billing_password};
|
||||
|
||||
|
||||
$enablemultithreading = $config->{enablemultithreading} if exists $config->{enablemultithreading};
|
||||
$cells_transfer_memory_limit = $config->{cells_transfer_memory_limit} if exists $config->{cells_transfer_memory_limit};
|
||||
$defer_indexes = $config->{defer_indexes} if exists $config->{defer_indexes};
|
||||
|
||||
|
||||
if (defined $split_tuplecode and ref $split_tuplecode eq 'CODE') {
|
||||
@jobservers = &$split_tuplecode($config->{jobservers}) if exists $config->{jobservers};
|
||||
} else {
|
||||
@jobservers = ($config->{jobservers}) if exists $config->{jobservers};
|
||||
}
|
||||
|
||||
if (defined $parse_floatcode and ref $parse_floatcode eq 'CODE') {
|
||||
|
||||
}
|
||||
|
||||
|
||||
$emailenable = $config->{emailenable} if exists $config->{emailenable};
|
||||
$erroremailrecipient = $config->{erroremailrecipient} if exists $config->{erroremailrecipient};
|
||||
$warnemailrecipient = $config->{warnemailrecipient} if exists $config->{warnemailrecipient};
|
||||
$completionemailrecipient = $config->{completionemailrecipient} if exists $config->{completionemailrecipient};
|
||||
$successemailrecipient = $config->{successemailrecipient} if exists $config->{successemailrecipient};
|
||||
|
||||
$ismsexchangeserver = $config->{ismsexchangeserver} if exists $config->{ismsexchangeserver};
|
||||
$smtp_server = $config->{smtp_server} if exists $config->{smtp_server};
|
||||
$smtpuser = $config->{smtpuser} if exists $config->{smtpuser};
|
||||
$smtppasswd = $config->{smtppasswd} if exists $config->{smtppasswd};
|
||||
|
||||
$fileloglevel = $config->{fileloglevel} if exists $config->{fileloglevel};
|
||||
$screenloglevel = $config->{screenloglevel} if exists $config->{screenloglevel};
|
||||
$emailloglevel = $config->{emailloglevel} if exists $config->{emailloglevel};
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub log_mainconfig {
|
||||
|
||||
my ($logconfigcode,$configlogger) = @_;
|
||||
if (defined $logconfigcode and ref $logconfigcode eq 'CODE') {
|
||||
&$logconfigcode($system_name . ' ' . $system_version . ' (' . $system_instance_label . ') [' . $local_fqdn . ']',$configlogger);
|
||||
&$logconfigcode('application path ' . $application_path,$configlogger);
|
||||
&$logconfigcode($cpucount . ' cpu(s), multithreading ' . ($enablemultithreading ? 'enabled' : 'disabled'),$configlogger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub get_applicationpath {
|
||||
|
||||
return dirname(abs_path(__FILE__)) . '/';
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@ -0,0 +1,32 @@
|
||||
package LoadCLIConfig;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use Getopt::Long;
|
||||
use Globals qw($defaultconfig);
|
||||
use LoadConfig qw(load_config);
|
||||
|
||||
my $configfile;
|
||||
my $arg = shift @ARGV;
|
||||
if (defined $arg) {
|
||||
$configfile = $arg;
|
||||
} else {
|
||||
$configfile = $defaultconfig;
|
||||
}
|
||||
|
||||
my $configfile = $defaultconfig;
|
||||
|
||||
|
||||
GetOptions ("host=s" => \$host,
|
||||
"port=i" => \$port,
|
||||
"file=s" => \$output_filename,
|
||||
"dir=s" => \$output_dir,
|
||||
"user=s" => \$user,
|
||||
"pass=s" => \$pass,
|
||||
"period=s" => \$period,
|
||||
'verbose+' => \$verbose) or fatal("Error in command line arguments");
|
||||
|
||||
load_config($configfile);
|
||||
|
||||
1;
|
||||
@ -0,0 +1,199 @@
|
||||
package LoadConfig;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use Globals qw(
|
||||
$application_path
|
||||
update_mainconfig
|
||||
log_mainconfig
|
||||
);
|
||||
|
||||
use Logging qw(
|
||||
getlogger
|
||||
mainconfigurationloaded
|
||||
configinfo
|
||||
init_log4perl
|
||||
);
|
||||
|
||||
use LogError qw(
|
||||
fileerror
|
||||
yamlerror
|
||||
configurationwarn
|
||||
configurationerror
|
||||
parameterdefinedtwice
|
||||
);
|
||||
|
||||
use YAML::Tiny;
|
||||
use Utils qw(format_number);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
$loadedmainconfigfile
|
||||
load_config
|
||||
);
|
||||
|
||||
our $loadedmainconfigfile;
|
||||
|
||||
my $tuplesplitpattern = join('|',(quotemeta(','),
|
||||
quotemeta(';'),
|
||||
quotemeta('/')
|
||||
)
|
||||
);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
sub load_config {
|
||||
|
||||
my ($configfile,$process_code,$configtype) = @_;
|
||||
|
||||
my $data;
|
||||
if (defined $configfile) {
|
||||
if (-e $configfile) {
|
||||
$data = _parse_config($file,$configtype);
|
||||
} else {
|
||||
$configfile = $application_path . $configfile;
|
||||
if (-e $configfile) {
|
||||
$data = _parse_config($configfile,$configtype);
|
||||
} else {
|
||||
fileerror('cannot find config file ' . $configfile,$logger);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
configurationerror('no config file specified',$logger);
|
||||
}
|
||||
|
||||
if ('CODE' eq ref $process_code) {
|
||||
my $result = @$process_code($data);
|
||||
configinfo('configuration file ' . $configfile . ' loaded',$logger);
|
||||
return $result;
|
||||
} else {
|
||||
if (update_mainconfig($data,$configfile,
|
||||
\&split_tuple,
|
||||
\&format_number,
|
||||
\&configurationwarn,
|
||||
\&configurationerror,
|
||||
$logger)) {
|
||||
$loadedmainconfigfile = $configfile;
|
||||
mainconfigurationloaded($configfile,$logger);
|
||||
return 1;
|
||||
}
|
||||
log_mainconfig(\&configinfo,$logger);
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _parse_config {
|
||||
my ($file,$configtype) = @_;
|
||||
my $data;
|
||||
if (defined $configtype) {
|
||||
if ($configtype == 1) {
|
||||
$data = _parse_yaml_config($file);
|
||||
} else {
|
||||
$data = _parse_simple_config($file);
|
||||
}
|
||||
} else {
|
||||
$data = _parse_simple_config($file);
|
||||
}
|
||||
return $data;
|
||||
}
|
||||
|
||||
sub split_tuple {
|
||||
|
||||
my $token = shift;
|
||||
return split(/$tuplesplitpattern/,$token);
|
||||
|
||||
}
|
||||
|
||||
#sub parse_float {
|
||||
#
|
||||
# my ($value) = @_;
|
||||
# my $output = $value;
|
||||
# if (index($output,",") > -1) {
|
||||
# $output =~ s/,/\./g;
|
||||
# }
|
||||
# $output = sprintf("%f",$output);
|
||||
# #$output =~ s/0+$//g;
|
||||
# #$output =~ s/\.$//g;
|
||||
# #if ($output =~ /\..+/) {
|
||||
# # $output =~ s/0+$//g;
|
||||
# # $output =~ s/\.$//g;
|
||||
# #}
|
||||
# if (index($output,".") > -1) {
|
||||
# $output =~ s/0+$//g;
|
||||
# $output =~ s/\.$//g;
|
||||
# }
|
||||
# return $output;
|
||||
#
|
||||
#}
|
||||
|
||||
sub _parse_simple_config {
|
||||
|
||||
my $file = shift;
|
||||
|
||||
my $config = {};
|
||||
local *CF;
|
||||
|
||||
if (not open (CF, '<' . $file)) {
|
||||
fileerror('parse simple config - cannot open file ' . $file . ': ' . $!,$logger);
|
||||
return $config;
|
||||
}
|
||||
|
||||
read(CF, my $data, -s $file);
|
||||
close(CF);
|
||||
|
||||
my @lines = split(/\015\012|\012|\015/,$data);
|
||||
my $count = 0;
|
||||
|
||||
foreach my $line(@lines) {
|
||||
$count++;
|
||||
|
||||
next if($line =~ /^\s*#/);
|
||||
next if($line !~ /^\s*\S+\s*=.*$/);
|
||||
|
||||
#my $cindex = index($line,'#');
|
||||
#if ($cindex >= 0) {
|
||||
# $line = substr($line,0,$cindex);
|
||||
#}
|
||||
|
||||
my ($key,$value) = split(/=/,$line,2);
|
||||
|
||||
# Remove whitespaces at the beginning and at the end
|
||||
|
||||
$key =~ s/^\s+//g;
|
||||
$key =~ s/\s+$//g;
|
||||
$value =~ s/^\s+//g;
|
||||
$value =~ s/\s+$//g;
|
||||
|
||||
if (exists $config->{$key}) {
|
||||
parameterdefinedtwice('parse simple config - parameter ' . $key . ' defined twice in line ' . $count . ' of configuration file ' . $file,$logger);
|
||||
}
|
||||
|
||||
$config->{$key} = $value;
|
||||
#print $key . "\n";
|
||||
}
|
||||
|
||||
return $config;
|
||||
|
||||
}
|
||||
|
||||
sub _parse_yaml_config {
|
||||
|
||||
my $file = shift;
|
||||
|
||||
my $yaml = undef;
|
||||
eval {
|
||||
$yaml = YAML::Tiny->read($file);
|
||||
};
|
||||
if ($@) {
|
||||
yamlerror('parse yaml config - error reading file ' . $file . ': ' . $!,$logger);
|
||||
return $yaml;
|
||||
}
|
||||
|
||||
return $yaml;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,592 @@
|
||||
package LogError;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
#use threads 1.72; # qw(running);
|
||||
#use threads::shared;
|
||||
|
||||
#use LoadConfig;
|
||||
use Globals qw(
|
||||
$system_version
|
||||
$erroremailrecipient
|
||||
$warnemailrecipient
|
||||
$successemailrecipient
|
||||
$completionemailrecipient
|
||||
$appstartsecs
|
||||
$root_threadid
|
||||
);
|
||||
|
||||
use Mail qw(
|
||||
send_message
|
||||
send_email
|
||||
$signature
|
||||
wrap_mailbody
|
||||
$lowpriority
|
||||
$normalpriority
|
||||
);
|
||||
use Utils qw(
|
||||
threadid
|
||||
create_guid
|
||||
getscriptpath
|
||||
timestamp
|
||||
secs_to_years
|
||||
);
|
||||
|
||||
use POSIX qw(ceil locale_h);
|
||||
setlocale(LC_NUMERIC, 'C');
|
||||
|
||||
use Time::HiRes qw(time);
|
||||
|
||||
use Carp qw(carp cluck croak confess);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
notimplementederror
|
||||
dberror
|
||||
dbwarn
|
||||
fieldnamesdiffer
|
||||
transferzerorowcount
|
||||
processzerorowcount
|
||||
deleterowserror
|
||||
|
||||
tabletransferfailed
|
||||
tableprocessingfailed
|
||||
|
||||
fileerror
|
||||
filewarn
|
||||
|
||||
yamlerror
|
||||
|
||||
parameterdefinedtwice
|
||||
emailwarn
|
||||
configurationwarn
|
||||
configurationerror
|
||||
|
||||
sortconfigerror
|
||||
|
||||
xls2csverror
|
||||
xls2csvwarn
|
||||
|
||||
serviceerror
|
||||
servicewarn
|
||||
|
||||
webarchivexls2csverror
|
||||
webarchivexls2csvwarn
|
||||
|
||||
dbclustererror
|
||||
dbclusterwarn
|
||||
|
||||
success
|
||||
completion
|
||||
);
|
||||
|
||||
my $erroremailsubject = 'error: module ';
|
||||
my $warnemailsubject = 'warning: module ';
|
||||
my $successmailsubject = 'success: module ';
|
||||
my $completionmailsubject = 'completed: module ';
|
||||
|
||||
sub success {
|
||||
|
||||
my ($message,$attachments,$logger) = @_;
|
||||
|
||||
if (length($message) == 0) {
|
||||
$message = 'success';
|
||||
}
|
||||
|
||||
my $appexitsecs = Time::HiRes::time();
|
||||
#$message .= "\n\n" . sprintf("%.2f",$appexitsecs - $appstartsecs) . ' seconds';
|
||||
$message .= "\n\n" . 'time elapsed: ' . secs_to_years(ceil($appexitsecs - $appstartsecs));
|
||||
|
||||
if (defined $logger) {
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
if (threadid() == $root_threadid) {
|
||||
if (length($successemailrecipient) > 0 and defined $logger) {
|
||||
my $email = {
|
||||
to => $successemailrecipient,
|
||||
#cc => 'rkrenn@sipwise.com',
|
||||
#bcc => '',
|
||||
#return_path => undef,
|
||||
priority => $lowpriority,
|
||||
#sender_name => 'Rene K.',
|
||||
#from => 'rkrenn@sipwise.com',
|
||||
subject => $successmailsubject . $logger->{category},
|
||||
body => getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature,
|
||||
guid => create_guid()
|
||||
};
|
||||
|
||||
my ($mailresult,$mailresultmessage) = send_email($email,$attachments,\&fileerror,\&emailwarn);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub completion {
|
||||
|
||||
my ($message,$attachments,$logger) = @_;
|
||||
|
||||
if (length($message) == 0) {
|
||||
$message = 'completed';
|
||||
}
|
||||
|
||||
my $appexitsecs = Time::HiRes::time();
|
||||
#$message .= "\n\n" . sprintf("%.2f",$appexitsecs - $appstartsecs) . ' seconds';
|
||||
$message .= "\n\n" . 'time elapsed: ' . secs_to_years(ceil($appexitsecs - $appstartsecs));
|
||||
|
||||
if (defined $logger) {
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
if (threadid() == $root_threadid) {
|
||||
if (length($completionemailrecipient) > 0 and defined $logger) {
|
||||
my $email = {
|
||||
to => $completionemailrecipient,
|
||||
#cc => 'rkrenn@sipwise.com',
|
||||
#bcc => '',
|
||||
#return_path => undef,
|
||||
priority => $normalpriority,
|
||||
#sender_name => 'Rene K.',
|
||||
#from => 'rkrenn@sipwise.com',
|
||||
subject => $completionmailsubject . $logger->{category},
|
||||
body => getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature,
|
||||
guid => create_guid()
|
||||
};
|
||||
|
||||
my ($mailresult,$mailresultmessage) = send_email($email,$attachments,\&fileerror,\&emailwarn);
|
||||
}
|
||||
|
||||
#exit(0);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub warning {
|
||||
|
||||
my ($message,$logger,$sendemail) = @_;
|
||||
|
||||
if (threadid() == $root_threadid) {
|
||||
if ($sendemail and length($warnemailrecipient) > 0 and defined $logger) {
|
||||
my ($mailresult,$mailresultmessage) = send_message($warnemailrecipient,$warnemailsubject . $logger->{category},getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature,\&fileerror,\&emailwarn);
|
||||
}
|
||||
carp($message);
|
||||
#warn($message);
|
||||
} else {
|
||||
carp($message);
|
||||
#warn($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub terminate {
|
||||
|
||||
my ($message,$logger) = @_;
|
||||
|
||||
if (threadid() == $root_threadid) {
|
||||
|
||||
my $appexitsecs = Time::HiRes::time();
|
||||
#$message .= "\n\n" . sprintf("%.2f",$appexitsecs - $appstartsecs) . ' seconds';
|
||||
$message .= "\n\n" . 'time elapsed: ' . secs_to_years(ceil($appexitsecs - $appstartsecs));
|
||||
|
||||
if (length($erroremailrecipient) > 0 and defined $logger) {
|
||||
my ($mailresult,$mailresultmessage) = send_message($erroremailrecipient,$erroremailsubject . $logger->{category},getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature,\&fileerror,\&emailwarn);
|
||||
}
|
||||
croak($message); # confess...
|
||||
#die($message);
|
||||
} else {
|
||||
|
||||
croak($message);
|
||||
#die($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
#sub registerthread {
|
||||
#
|
||||
# my $thrlogger = shift;
|
||||
# $registered_tids{threads->tid()} = 1;
|
||||
# $SIG{'DIE'} = sub {
|
||||
#
|
||||
# print "signal\n";
|
||||
# my $tid = threads->tid();
|
||||
# my $message = '[' . $tid . '] aborting';
|
||||
# if (defined $thrlogger) {
|
||||
# $thrlogger->error('[' . $tid . '] aborting');
|
||||
# }
|
||||
# unregisterthread($tid);
|
||||
# #threads->exit();
|
||||
# croak($message);
|
||||
# };
|
||||
#
|
||||
#}
|
||||
#
|
||||
#sub unregisterthread {
|
||||
#
|
||||
# my $tid = shift;
|
||||
# if (!defined $tid) {
|
||||
# $tid = threads->tid();
|
||||
# }
|
||||
# delete $registered_tids{$tid};
|
||||
#
|
||||
#}
|
||||
|
||||
#sub terminatethreads {
|
||||
#
|
||||
# # Loop through all the threads
|
||||
# foreach my $thr (threads->list()) {
|
||||
# # Don't join the main thread or ourselves
|
||||
# if ($thr->tid != 0 && !threads::equal($thr,threads->self)) {
|
||||
# $thr->kill('DIE'); #->detach();
|
||||
# }
|
||||
# }
|
||||
#
|
||||
#}
|
||||
|
||||
sub notimplementederror {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub dberror {
|
||||
|
||||
my ($db, $message, $logger) = @_;
|
||||
$message = _getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message);
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub dbwarn {
|
||||
|
||||
my ($db, $message, $logger) = @_;
|
||||
$message = _getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message);
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
|
||||
#die();
|
||||
warning($message, $logger, 1);
|
||||
|
||||
}
|
||||
|
||||
sub fieldnamesdiffer {
|
||||
|
||||
my ($db,$tablename,$expectedfieldnames,$fieldnamesfound,$logger) = @_;
|
||||
my $message = _getconnectorinstanceprefix($db) . 'wrong table fieldnames (v ' . $system_version . '): [' . $db->connectidentifier() . '].' . $tablename . ":\nexpected: " . ((defined $expectedfieldnames) ? join(', ',@$expectedfieldnames) : '<none>') . "\nfound: " . ((defined $fieldnamesfound) ? join(', ',@$fieldnamesfound) : '<none>');
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub dbclustererror {
|
||||
|
||||
my ($clustername,$message,$logger) = @_;
|
||||
$message = 'database cluster ' . $clustername . ': ' . $message;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
|
||||
}
|
||||
|
||||
sub dbclusterwarn {
|
||||
|
||||
my ($clustername,$message,$logger) = @_;
|
||||
$message = 'database cluster ' . $clustername . ': ' . $message;
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
|
||||
#die();
|
||||
warning($message, $logger, 1);
|
||||
|
||||
}
|
||||
|
||||
sub transferzerorowcount {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_;
|
||||
my $message = _getconnectorinstanceprefix($db) . '[' . $db->connectidentifier() . '].' . $tablename . ' has 0 rows';
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub processzerorowcount {
|
||||
|
||||
my ($db,$tablename,$numofrows,$logger) = @_;
|
||||
my $message = '[' . $db->connectidentifier() . '].' . $tablename . ' has 0 rows';
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub deleterowserror {
|
||||
|
||||
my ($db,$tablename,$message,$logger) = @_;
|
||||
$message = _getconnectorinstanceprefix($db) . '[' . $db->connectidentifier() . '].' . $tablename . ' - ' . $message;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub tabletransferfailed {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_;
|
||||
my $message = _getconnectorinstanceprefix($db) . 'table transfer failed: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
terminate($message, $logger);
|
||||
|
||||
}
|
||||
|
||||
sub tableprocessingfailed {
|
||||
|
||||
my ($db,$tablename,$numofrows,$logger) = @_;
|
||||
my $message = 'table processing failed: [' . $db->connectidentifier() . '].' . $tablename;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
terminate($message, $logger);
|
||||
|
||||
}
|
||||
|
||||
sub fileerror {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub yamlerror {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub xls2csverror {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub webarchivexls2csverror {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
#terminatethreads();
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub filewarn {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
|
||||
#die();
|
||||
warning($message, $logger, 1);
|
||||
}
|
||||
|
||||
|
||||
sub xls2csvwarn {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
|
||||
warning($message, $logger, 1);
|
||||
}
|
||||
|
||||
sub webarchivexls2csvwarn {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
|
||||
warning($message, $logger, 1);
|
||||
}
|
||||
|
||||
sub parameterdefinedtwice {
|
||||
|
||||
my ($message,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
warning($message, $logger, 1);
|
||||
}
|
||||
|
||||
sub emailwarn {
|
||||
|
||||
my ($message, $errormsg, $response, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
if (length($response) > 0) {
|
||||
$logger->warn($message . ': ' . $errormsg . ' \'' . $response . '\'');
|
||||
} else {
|
||||
$logger->warn($message . ': ' . $errormsg);
|
||||
}
|
||||
}
|
||||
|
||||
warning($message, $logger, 0);
|
||||
|
||||
}
|
||||
|
||||
sub configurationwarn {
|
||||
|
||||
my ($configfile,$message,$logger) = @_;
|
||||
$message = 'configuration file ' . $configfile . ': ' . $message;
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
warning($message, $logger, 0);
|
||||
|
||||
}
|
||||
|
||||
sub configurationerror {
|
||||
|
||||
my ($configfile,$message,$logger) = @_;
|
||||
$message = 'configuration file ' . $configfile . ': ' . $message;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
|
||||
}
|
||||
|
||||
sub sortconfigerror {
|
||||
|
||||
my ($identifier,$message,$logger) = @_;
|
||||
|
||||
if (defined $identifier) {
|
||||
$message = 'sort configuration (' . $identifier . '): ' . $message;
|
||||
} else {
|
||||
$message = 'sort configuration: ' . $message;
|
||||
}
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
|
||||
}
|
||||
|
||||
sub serviceerror {
|
||||
|
||||
my ($service, $message, $logger) = @_;
|
||||
$message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message;
|
||||
if (defined $logger) {
|
||||
$logger->error($message);
|
||||
}
|
||||
|
||||
terminate($message, $logger);
|
||||
|
||||
}
|
||||
|
||||
sub servicewarn {
|
||||
|
||||
my ($service, $message, $logger) = @_;
|
||||
$message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message;
|
||||
if (defined $logger) {
|
||||
$logger->warn($message);
|
||||
}
|
||||
|
||||
#die();
|
||||
warning($message, $logger, 1);
|
||||
|
||||
}
|
||||
|
||||
sub _getconnectorinstanceprefix {
|
||||
my ($db) = @_;
|
||||
my $instancestring = $db->instanceidentifier();
|
||||
if (length($instancestring) > 0) {
|
||||
if ($db->{tid} != $root_threadid) {
|
||||
return '[' . $db->{tid} . '/' . $instancestring . '] ';
|
||||
} else {
|
||||
return '[' . $instancestring . '] ';
|
||||
}
|
||||
} elsif ($db->{tid} != $root_threadid) {
|
||||
return '[' . $db->{tid} . '] ';
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
sub _getconnectidentifiermessage {
|
||||
my ($db,$message) = @_;
|
||||
my $result = $db->connectidentifier();
|
||||
my $connectidentifier = $db->_connectidentifier();
|
||||
if (length($result) > 0 and defined $db->cluster and length($connectidentifier) > 0) {
|
||||
$result .= '->' . $connectidentifier;
|
||||
}
|
||||
if (length($result) > 0) {
|
||||
$result .= ' - ';
|
||||
}
|
||||
return $result . $message;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,607 @@
|
||||
# a verbose logging module
|
||||
|
||||
package Logging;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
#use threads;
|
||||
#use Table;
|
||||
|
||||
use Globals qw(
|
||||
$root_threadid
|
||||
$logfile_path
|
||||
$fileloglevel
|
||||
$emailloglevel
|
||||
$screenloglevel
|
||||
log_mainconfig
|
||||
$enablemultithreading
|
||||
);
|
||||
|
||||
use Log::Log4perl qw(get_logger);
|
||||
|
||||
use Utils qw(timestampdigits datestampdigits changemod chopstring trim);
|
||||
use Array qw (contains);
|
||||
#use Mail qw(send_message);
|
||||
#require Mail;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our @EXPORT_OK = qw(
|
||||
getlogger
|
||||
abortthread
|
||||
cleanuplogfiles
|
||||
|
||||
emailinfo
|
||||
emaildebug
|
||||
dbdebug
|
||||
dbinfo
|
||||
|
||||
attachmentdownloaderdebug
|
||||
attachmentdownloaderinfo
|
||||
|
||||
fieldnamesaquired
|
||||
primarykeycolsaquired
|
||||
tableinfoscleared
|
||||
tabletransferstarted
|
||||
tableprocessingstarted
|
||||
rowtransferstarted
|
||||
texttablecreated
|
||||
temptablecreated
|
||||
indexcreated
|
||||
primarykeycreated
|
||||
tabletruncated
|
||||
tabledropped
|
||||
rowtransferred
|
||||
rowskipped
|
||||
rowinserted
|
||||
rowupdated
|
||||
rowsdeleted
|
||||
totalrowsdeleted
|
||||
rowinsertskipped
|
||||
rowupdateskipped
|
||||
tabletransferdone
|
||||
tableprocessingdone
|
||||
rowtransferdone
|
||||
fetching_rows
|
||||
writing_rows
|
||||
processing_rows
|
||||
|
||||
mainconfigurationloaded
|
||||
configinfo
|
||||
init_log4perl
|
||||
$currentlogfile
|
||||
$attachmentlogfile
|
||||
cleanupinfo
|
||||
|
||||
xls2csvinfo
|
||||
tablethreadingdebug
|
||||
|
||||
tablefixed
|
||||
servicedebug
|
||||
serviceinfo
|
||||
);
|
||||
|
||||
my $logfileextension = '.log';
|
||||
|
||||
our $currentlogfile;
|
||||
our $weblogfile;
|
||||
our $attachmentlogfile;
|
||||
|
||||
#eval {
|
||||
init_log4perl();
|
||||
#};
|
||||
|
||||
sub createlogfile {
|
||||
|
||||
my ($logfile,$fileerrorcode,$logger) = @_;
|
||||
local *LOGFILE;
|
||||
if (not open (LOGFILE,'>' . $logfile)) {
|
||||
if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') {
|
||||
&$fileerrorcode('cannot create log file ' . $logfile . ': ' . $!,$logger);
|
||||
}
|
||||
}
|
||||
close(LOGFILE);
|
||||
changemod($logfile);
|
||||
|
||||
}
|
||||
|
||||
sub init_log4perl {
|
||||
|
||||
$currentlogfile = $logfile_path . timestampdigits() . $logfileextension;
|
||||
createlogfile($currentlogfile);
|
||||
$attachmentlogfile = $logfile_path . 'email_' . timestampdigits() . $logfileextension;
|
||||
createlogfile($attachmentlogfile);
|
||||
$weblogfile = $logfile_path . 'web_' . datestampdigits() . $logfileextension;
|
||||
createlogfile($weblogfile);
|
||||
|
||||
# log configuration
|
||||
my $conf = "log4perl.logger = DEBUG, FileApp, ScreenApp, MailAttApp\n" .
|
||||
|
||||
"log4perl.appender.FileApp = Log::Log4perl::Appender::File\n" .
|
||||
"log4perl.appender.FileApp.umask = 0\n" .
|
||||
"log4perl.appender.FileApp.syswite = 1\n" .
|
||||
'log4perl.appender.FileApp.Threshold = ' . $fileloglevel . "\n" .
|
||||
"log4perl.appender.FileApp.mode = append\n" .
|
||||
'log4perl.appender.FileApp.filename = ' . $currentlogfile . "\n" .
|
||||
"log4perl.appender.FileApp.create_at_logtime = 1\n" .
|
||||
"log4perl.appender.FileApp.layout = PatternLayout\n" .
|
||||
'log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n' . "\n\n" .
|
||||
|
||||
"log4perl.appender.MailAttApp = Log::Log4perl::Appender::File\n" .
|
||||
"log4perl.appender.MailApp.umask = 0\n" .
|
||||
"log4perl.appender.MailApp.syswite = 1\n" .
|
||||
'log4perl.appender.MailAttApp.Threshold = ' . $emailloglevel . "\n" .
|
||||
"log4perl.appender.MailAttApp.mode = append\n" .
|
||||
'log4perl.appender.MailAttApp.filename = ' . $attachmentlogfile . "\n" .
|
||||
"log4perl.appender.MailAttApp.create_at_logtime = 1\n" .
|
||||
"log4perl.appender.MailAttApp.layout = Log::Log4perl::Layout::SimpleLayout\n" .
|
||||
'log4perl.appender.MailAttApp.layout.ConversionPattern = %d> %m%n' . "\n\n" .
|
||||
|
||||
"log4perl.appender.ScreenApp = Log::Log4perl::Appender::Screen\n" .
|
||||
#"log4perl.appender.ScreenApp = Log::Log4perl::Appender::ScreenColoredLevels\n" .
|
||||
'log4perl.appender.ScreenApp.Threshold = ' . $screenloglevel . "\n" .
|
||||
"log4perl.appender.ScreenApp.stderr = 0\n" .
|
||||
"log4perl.appender.ScreenApp.layout = Log::Log4perl::Layout::SimpleLayout\n" .
|
||||
'log4perl.appender.ScreenApp.layout.ConversionPattern = %d> %m%n';
|
||||
|
||||
# Initialize logging behaviour
|
||||
Log::Log4perl->init( \$conf );
|
||||
}
|
||||
|
||||
#my $loglogger;
|
||||
#eval {
|
||||
# $loglogger = get_logger(__PACKAGE__);
|
||||
#};
|
||||
my $loglogger = get_logger(__PACKAGE__);
|
||||
|
||||
sub getlogger {
|
||||
|
||||
my $package = shift;
|
||||
#my $newlogger;
|
||||
#eval {
|
||||
# $newlogger = get_logger($package);
|
||||
#};
|
||||
#if (defined $loglogger and defined $newlogger) {
|
||||
# $loglogger->debug('logger for category ' . $package . ' created');
|
||||
#}
|
||||
my $newlogger = get_logger($package);
|
||||
$loglogger->debug('logger for category ' . $package . ' created');
|
||||
return $newlogger;
|
||||
|
||||
}
|
||||
|
||||
sub cleanuplogfiles {
|
||||
|
||||
my ($fileerrorcode,$filewarncode,@remaininglogfiles) = @_;
|
||||
my $rlogfileextension = quotemeta($logfileextension);
|
||||
local *LOGDIR;
|
||||
if (not opendir(LOGDIR, $logfile_path)) {
|
||||
if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') {
|
||||
&$fileerrorcode('cannot opendir ' . $logfile_path . ': ' . $!,$loglogger);
|
||||
return;
|
||||
}
|
||||
}
|
||||
my @files = grep { /$rlogfileextension$/ && -f $logfile_path . $_} readdir(LOGDIR);
|
||||
closedir LOGDIR;
|
||||
foreach my $file (@files) {
|
||||
#print $file;
|
||||
my $filepath = $logfile_path . $file;
|
||||
#print $filepath . "\n";
|
||||
#print $remaininglogfiles[0] . "\n\n";
|
||||
if (not contains($filepath,\@remaininglogfiles)) {
|
||||
if ((unlink $filepath) == 0) {
|
||||
if (defined $filewarncode and ref $filewarncode eq 'CODE') {
|
||||
&$filewarncode('cannot remove ' . $filepath . ': ' . $!,$loglogger);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub emailinfo {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub emaildebug {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->debug($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub dbdebug {
|
||||
|
||||
my ($db, $message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->debug(_getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message));
|
||||
}
|
||||
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub dbinfo {
|
||||
|
||||
my ($db, $message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message));
|
||||
}
|
||||
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub attachmentdownloaderdebug {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->debug($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub attachmentdownloaderinfo {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub xls2csvinfo {
|
||||
|
||||
my ($message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub fieldnamesaquired {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'fieldnames aquired and OK: [' . $db->connectidentifier() . '].' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub primarykeycolsaquired {
|
||||
|
||||
my ($db,$tablename,$keycols,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'primary key columns aquired for [' . $db->connectidentifier() . '].' . $tablename . ': ' . ((defined $keycols and scalar @$keycols > 0) ? join(', ',@$keycols) : '<no primary key columns>'));
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tableinfoscleared {
|
||||
|
||||
my ($db,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'table infos cleared for ' . $db->connectidentifier());
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tabletransferstarted {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'table transfer started: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tableprocessingstarted {
|
||||
|
||||
my ($db,$tablename,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info('table processing started: [' . $db->connectidentifier() . '].' . $tablename . ': ' . $numofrows . ' row(s)');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tablethreadingdebug {
|
||||
|
||||
my ($message,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->debug($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowtransferstarted {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'row transfer started: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub texttablecreated {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'text table created: ' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub indexcreated {
|
||||
|
||||
my ($db,$tablename,$indexname,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'index created: ' . $indexname . ' on ' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub primarykeycreated {
|
||||
|
||||
my ($db,$tablename,$keycols,$logger) = @_;
|
||||
if (defined $logger and (defined $keycols and scalar @$keycols > 0)) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'primary key created: ' . join(', ',@$keycols) . ' on ' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub temptablecreated {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'temporary table created: ' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tabletruncated {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'table truncated: ' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tabledropped {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'table dropped: ' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowtransferred {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$i,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->debug(_getconnectorinstanceprefix($db) . 'row ' . $i . '/' . $numofrows . ' transferred');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowskipped {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$i,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'row ' . $i . '/' . $numofrows . ' skipped');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowinserted {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->debug(_getconnectorinstanceprefix($db) . 'row inserted');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowupdated {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->debug(_getconnectorinstanceprefix($db) . 'row updated');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowsdeleted {
|
||||
|
||||
my ($db,$tablename,$rowcount,$initial_rowcount,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
if (defined $initial_rowcount) {
|
||||
$logger->debug(_getconnectorinstanceprefix($db) . $rowcount . ' of ' . $initial_rowcount . ' row(s) deleted');
|
||||
} else {
|
||||
$logger->debug(_getconnectorinstanceprefix($db) . $rowcount . ' row(s) deleted');
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub totalrowsdeleted {
|
||||
|
||||
my ($db,$tablename,$rowcount_total,$initial_rowcount,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . $rowcount_total . ' of ' . $initial_rowcount . ' row(s) deleted from [' . $db->connectidentifier() . '].' . $tablename);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowinsertskipped {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'row insert skipped');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowupdateskipped {
|
||||
|
||||
my ($db,$tablename,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'row update skipped');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tabletransferdone {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'table transfer done: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tablefixed {
|
||||
|
||||
my ($target_db,$targettablename,$statement,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($target_db) . 'table fix applied to ' . $targettablename . ': ' . chopstring(trim($statement),90));
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tableprocessingdone {
|
||||
|
||||
my ($db,$tablename,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info('table processing done: [' . $db->connectidentifier() . '].' . $tablename . ': ' . $numofrows . ' row(s)');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowtransferdone {
|
||||
|
||||
my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'row transfer done: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub fetching_rows {
|
||||
|
||||
my ($db,$tablename,$start,$blocksize,$totalnumofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'fetching rows from [' . $db->connectidentifier() . '].' . $tablename . ': ' . ($start + 1) . '-' . ($start + $blocksize) . ' of ' . $totalnumofrows);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub writing_rows {
|
||||
|
||||
my ($db,$tablename,$start,$blocksize,$totalnumofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(_getconnectorinstanceprefix($db) . 'writing rows to ' . $tablename . ': ' . ($start + 1) . '-' . ($start + $blocksize) . ' of ' . $totalnumofrows);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub processing_rows {
|
||||
|
||||
my ($tid, $start,$blocksize,$totalnumofrows,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info(($enablemultithreading ? '[' . $tid . '] ' : '') . 'processing rows: ' . ($start + 1) . '-' . ($start + $blocksize) . ' of ' . $totalnumofrows);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub mainconfigurationloaded {
|
||||
|
||||
my ($configfile,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info('system configuration file ' . $configfile . ' loaded');
|
||||
}
|
||||
log_mainconfig(\&configinfo,$logger);
|
||||
|
||||
}
|
||||
|
||||
sub configinfo {
|
||||
|
||||
my ($message,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub cleanupinfo {
|
||||
|
||||
my ($message,$logger) = @_;
|
||||
if (defined $logger) {
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub servicedebug {
|
||||
|
||||
my ($service, $message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message;
|
||||
$logger->debug($message);
|
||||
}
|
||||
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub serviceinfo {
|
||||
|
||||
my ($service, $message, $logger) = @_;
|
||||
if (defined $logger) {
|
||||
$message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message;
|
||||
$logger->info($message);
|
||||
}
|
||||
|
||||
#die();
|
||||
|
||||
}
|
||||
|
||||
sub _getconnectorinstanceprefix {
|
||||
my ($db) = @_;
|
||||
my $instancestring = $db->instanceidentifier();
|
||||
if (length($instancestring) > 0) {
|
||||
if ($db->{tid} != $root_threadid) {
|
||||
return '[' . $db->{tid} . '/' . $instancestring . '] ';
|
||||
} else {
|
||||
return '[' . $instancestring . '] ';
|
||||
}
|
||||
} elsif ($db->{tid} != $root_threadid) {
|
||||
return '[' . $db->{tid} . '] ';
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
sub _getconnectidentifiermessage {
|
||||
my ($db,$message) = @_;
|
||||
my $result = $db->connectidentifier();
|
||||
my $connectidentifier = $db->_connectidentifier();
|
||||
if (length($result) > 0 and defined $db->cluster and length($connectidentifier) > 0) {
|
||||
$result .= '->' . $connectidentifier;
|
||||
}
|
||||
if (length($result) > 0) {
|
||||
$result .= ' - ';
|
||||
}
|
||||
return $result . $message;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,625 @@
|
||||
# mail module: sending emails with attachments
|
||||
|
||||
package Mail;
|
||||
#BEGIN { $INC{Mail} ||= __FILE__ };
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
#require Logging;
|
||||
use Logging qw(
|
||||
getlogger
|
||||
emailinfo
|
||||
emaildebug);
|
||||
#use LogError qw(fileerror);
|
||||
#use LogWarn qw(emailwarn);
|
||||
|
||||
#use LoadConfig;
|
||||
use Globals qw(
|
||||
$system_name
|
||||
$system_instance_label
|
||||
$system_version
|
||||
$local_fqdn
|
||||
$mailfilepath
|
||||
$emailenable
|
||||
$mailprog
|
||||
$mailtype
|
||||
|
||||
$ismsexchangeserver
|
||||
$sender_address
|
||||
$smtp_server
|
||||
$smtpuser
|
||||
$smtppasswd
|
||||
$writefiles
|
||||
);
|
||||
|
||||
use Utils qw(trim file_md5 create_guid wrap_text changemod);
|
||||
|
||||
use File::Basename;
|
||||
#use File::Temp qw(tempfile tempdir);
|
||||
use MIME::Base64;
|
||||
use MIME::Lite;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
send_message
|
||||
send_email
|
||||
wrap_mailbody
|
||||
$signature
|
||||
$normalpriority
|
||||
$lowpriority
|
||||
$highpriority
|
||||
cleanupmsgfiles
|
||||
);
|
||||
|
||||
my $wordwrapcolumns = 72; #linebreak/wrap columns
|
||||
|
||||
our $signature = "--\n" . $system_name . ' ' . $system_version . ' (' . $system_instance_label . ")\n[" . $local_fqdn . ']'; # a nice email signature
|
||||
|
||||
my $msgextension = '.msg';
|
||||
|
||||
our $normalpriority = 0;
|
||||
our $lowpriority = 1;
|
||||
our $highpriority = 2;
|
||||
|
||||
my %msmailpriority = (
|
||||
$normalpriority => 'Normal',
|
||||
$lowpriority => 'Low',
|
||||
$highpriority => 'High');
|
||||
|
||||
# sample email data structure:
|
||||
#my $message = {
|
||||
# to => 'rkrenn@sipwise.com',
|
||||
# cc => 'rkrenn@alumni.tugraz.at',
|
||||
# bcc => '',
|
||||
# return_path => '',
|
||||
# priority => $normalpriority,
|
||||
# sender_name => 'Rene Krenn',
|
||||
# from => 'rkrenn@sipwise.com',
|
||||
# subject => 'subject...',
|
||||
# body => wrap_mailbody('test.......'),
|
||||
# guid => create_guid()
|
||||
#};
|
||||
|
||||
|
||||
my $mailsentsuccessfully = 1;
|
||||
|
||||
my $mailingdisabled = 0;
|
||||
|
||||
my $smtpserveripinvalid = -11;
|
||||
my $smtpsocketcreatefailed = -12;
|
||||
my $smtpserverconnectfailed = -13;
|
||||
my $smtpprotocolerrorinitial = -14;
|
||||
my $smtpprotocolerrorehlo = -15; #list auth options - esmtp
|
||||
my $smtpnoauthloginavailable = -16;
|
||||
my $smtpprotocolerrorlogin = -17; #start login
|
||||
my $smtpprotocolerroruser = -18;
|
||||
my $smtpprotocolerrorpass = -19;
|
||||
my $smtpprotocolerrorhelo = -20; #normal smtp - no auth
|
||||
my $mailrecipientundefined = -21;
|
||||
my $smtpprotocolerrorfrom = -20;
|
||||
my $smtpprotocolerrorrcpt = -22;
|
||||
my $smtpprotocolerrordata = -23;
|
||||
|
||||
|
||||
my $smtpnetfatalerror = -24;
|
||||
my $smtpprotocolerrordataaccepted = -25;
|
||||
|
||||
|
||||
my $mailprogpipeerror = -26;
|
||||
my $writemailfileerror = -27;
|
||||
|
||||
my $errorcreatingmimemail = -30;
|
||||
my $errorcreatingfileattachment = -32;
|
||||
my $attachmentfilenotexistent = -31;
|
||||
|
||||
|
||||
|
||||
my $mailerr_messages = {
|
||||
$mailsentsuccessfully => 'MailSentSuccessfully',
|
||||
$mailingdisabled => 'MailingDisabled',
|
||||
|
||||
$smtpserveripinvalid => 'SMTPServerIPInvalid',
|
||||
$smtpsocketcreatefailed => 'SMTPSocketCreateFailed',
|
||||
$smtpserverconnectfailed => 'SMTPServerConnectFailed',
|
||||
$smtpprotocolerrorinitial => 'SMTPProtocolErrorInitial',
|
||||
$smtpprotocolerrorehlo => 'SMTPProtocolErrorEhlo',
|
||||
$smtpnoauthloginavailable => 'SMTPNoAuthLoginAvailable',
|
||||
$smtpprotocolerrorlogin => 'SMTPProtocolErrorLogin',
|
||||
$smtpprotocolerroruser => 'SMTPProtocolErrorUser',
|
||||
$smtpprotocolerrorpass => 'SMTPProtocolErrorPass',
|
||||
$smtpprotocolerrorhelo => 'SMTPProtocolErrorHelo',
|
||||
$smtpprotocolerrorfrom => 'SMTPProtocolErrorFrom',
|
||||
$smtpprotocolerrorrcpt => 'SMTPProtocolErrorRcpt',
|
||||
$smtpprotocolerrordata => 'SMTPProtocolErrorData',
|
||||
|
||||
$smtpnetfatalerror => 'SMTPNetFatalError',
|
||||
$smtpprotocolerrordataaccepted => 'SMTPProtocolErrorDataAccepted',
|
||||
|
||||
$mailprogpipeerror => 'MailProgPipeError',
|
||||
|
||||
$writemailfileerror => 'WriteMailFileError',
|
||||
|
||||
$mailrecipientundefined => 'MailRecipientUndefined',
|
||||
$errorcreatingmimemail => 'ErrorCreatingMIMEMail',
|
||||
$errorcreatingfileattachment => 'ErrorCreatingFileAttachment',
|
||||
|
||||
$attachmentfilenotexistent => 'AttachmentFileNotExistent',
|
||||
|
||||
};
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
# email body wordwrapping:
|
||||
sub wrap_mailbody {
|
||||
|
||||
return wrap_text(shift,$wordwrapcolumns);
|
||||
|
||||
}
|
||||
|
||||
# send an email
|
||||
# $mailmessage parameter is a email data structure
|
||||
# $filepaths is an arrayref with filenames to attach
|
||||
sub send_mail_with_attachments {
|
||||
|
||||
my ($mailmessage,$filepaths,$fileerrorcode, $emailwarncode) = @_;
|
||||
|
||||
my @filestocleanup = ();
|
||||
|
||||
my $message = $mailmessage->{body};
|
||||
$message =~ s/^\./\.\./gm;
|
||||
$message =~ s/\r\n/\n/g;
|
||||
|
||||
my $to = cleanrcpts($mailmessage->{to});
|
||||
my $cc = cleanrcpts($mailmessage->{cc});
|
||||
my $bcc = cleanrcpts($mailmessage->{bcc});
|
||||
my $returnpath = preparemailaddress($mailmessage->{return_path});
|
||||
my $priority = $msmailpriority{$mailmessage->{priority}};
|
||||
|
||||
my $mime_mail = MIME::Lite->new(
|
||||
From => '"' . $mailmessage->{sender_name} . '" <' . preparemailaddress($mailmessage->{from}) . '>',
|
||||
Sender => $system_name,
|
||||
Type => 'multipart/mixed',
|
||||
Encoding => 'binary',
|
||||
Subject => $mailmessage->{subject}
|
||||
) or return $errorcreatingmimemail;
|
||||
|
||||
$mime_mail->add('Message-ID' => '<' . $mailmessage->{guid} . '@' . $local_fqdn . '>');
|
||||
$mime_mail->add('X-Mailer' => $system_name . ' Plaintext Mailer');
|
||||
|
||||
if (defined $to and $to ne '') {
|
||||
$mime_mail->add('To' => $to);
|
||||
}
|
||||
if (defined $cc and $cc ne '') {
|
||||
$mime_mail->add('Cc' => $cc);
|
||||
}
|
||||
if (defined $bcc and $bcc ne '') {
|
||||
$mime_mail->add('Bcc' => $bcc);
|
||||
}
|
||||
if (defined $returnpath and $returnpath ne '') {
|
||||
$mime_mail->add('Return-Path' => '<' . $returnpath . '>');
|
||||
}
|
||||
if (defined $priority and $priority ne '') {
|
||||
$mime_mail->add('Importance' => $priority);
|
||||
}
|
||||
|
||||
$mime_mail->attr('content-type.charset' => 'UTF8');
|
||||
|
||||
$mime_mail->attach(
|
||||
Type => 'TEXT',
|
||||
Data => $message
|
||||
);
|
||||
|
||||
if (defined $filepaths and ref $filepaths eq 'ARRAY') {
|
||||
|
||||
my @attachmentfilepaths = @$filepaths;
|
||||
|
||||
for (my $i = 0; $i < scalar @attachmentfilepaths; $i++) {
|
||||
my $attachmentfilepath = $attachmentfilepaths[$i];
|
||||
if (-e $attachmentfilepath) {
|
||||
my $filesize = -s $attachmentfilepath;
|
||||
#push @filestocleanup,$attachmentfilepath;
|
||||
if ($filesize > 0) {
|
||||
$mime_mail->attach(
|
||||
Id => file_md5($attachmentfilepath,$fileerrorcode,$logger),
|
||||
Type => 'AUTO',
|
||||
Filename => basename($attachmentfilepath),
|
||||
Length => $filesize,
|
||||
Encoding => 'base64',
|
||||
Disposition => 'attachment',
|
||||
ReadNow => 1,
|
||||
Path => $attachmentfilepath
|
||||
) or return flushtempfiles($errorcreatingfileattachment,\@filestocleanup);
|
||||
}
|
||||
} else {
|
||||
return flushtempfiles($attachmentfilenotexistent,\@filestocleanup);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return flushtempfiles(send_smtp(preparemailaddress($mailmessage->{from}), mergercpts(($mailmessage->{to},$mailmessage->{cc},$mailmessage->{bcc})), $mime_mail->as_string(),$fileerrorcode, $emailwarncode),\@filestocleanup);
|
||||
|
||||
}
|
||||
|
||||
sub flushtempfiles {
|
||||
|
||||
my ($errorcode,$filestocleanup) = @_;
|
||||
foreach my $filetocleanup (@$filestocleanup) {
|
||||
unlink $filetocleanup;
|
||||
}
|
||||
return $errorcode;
|
||||
|
||||
}
|
||||
|
||||
sub send_simple_mail {
|
||||
|
||||
my ($to, $subject, $messagebody, $from, $from_name, $return_path,$fileerrorcode, $emailwarncode) = @_;
|
||||
|
||||
my $message = $messagebody;
|
||||
$message =~ s/^\./\.\./gm;
|
||||
$message =~ s/\r\n/\n/g;
|
||||
$message =~ s/<\/*b>//g;
|
||||
|
||||
my $crlf = "\n";
|
||||
if ($ismsexchangeserver) {
|
||||
$crlf = "\r\n";
|
||||
}
|
||||
|
||||
my $fromemail = preparemailaddress($from);
|
||||
my $returnpath = preparemailaddress($return_path);
|
||||
|
||||
my $data = 'From: ';
|
||||
if (defined $from_name and $from_name ne '') {
|
||||
$data .= '"' . $from_name . '" ';
|
||||
}
|
||||
if (defined $fromemail and $fromemail ne '') {
|
||||
$data .= '<' . $fromemail . '>' . $crlf;
|
||||
} else {
|
||||
$data .= '<' . $sender_address . '>' . $crlf;
|
||||
}
|
||||
$data .= 'Subject: ' . $subject . $crlf;
|
||||
$data .= 'To: ' . cleanrcpts($to) . $crlf;
|
||||
$data .= 'X-Mailer: ' . $system_name . ' Plaintext Mailer' . $crlf;
|
||||
if (defined $returnpath and $returnpath ne '') {
|
||||
$data .= 'Return-Path: <' . $returnpath . '>' . $crlf;
|
||||
}
|
||||
$data .= $message;
|
||||
|
||||
return send_smtp($from, $to, $data,$fileerrorcode, $emailwarncode);
|
||||
|
||||
}
|
||||
|
||||
sub send_smtp {
|
||||
|
||||
my ($from, $to, $data, $fileerrorcode, $emailwarncode) = @_;
|
||||
|
||||
my $fromemail = preparemailaddress($from);
|
||||
|
||||
if (!$to) {
|
||||
return $mailrecipientundefined;
|
||||
}
|
||||
|
||||
my $crlf = "\n";
|
||||
if ($ismsexchangeserver) {
|
||||
$crlf = "\r\n";
|
||||
}
|
||||
|
||||
local *MAIL;
|
||||
|
||||
if ($mailtype == 1) {
|
||||
|
||||
use Socket;
|
||||
|
||||
my($proto) = (getprotobyname('tcp'))[2];
|
||||
my($port) = (getservbyname('smtp', 'tcp'))[2];
|
||||
my($smtpaddr) = ($smtp_server =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) ? pack('C4',$1,$2,$3,$4) : (gethostbyname($smtp_server))[4];
|
||||
|
||||
if (!defined($smtpaddr)) { return $smtpserveripinvalid; }
|
||||
if (!socket(MAIL, AF_INET, SOCK_STREAM, $proto)) { return $smtpsocketcreatefailed; }
|
||||
if (!connect(MAIL, pack('Sna4x8', AF_INET, $port, $smtpaddr))) { return $smtpserverconnectfailed; }
|
||||
|
||||
my($oldfh) = select(MAIL);
|
||||
$| = 1;
|
||||
select($oldfh);
|
||||
|
||||
$_ = <MAIL>;
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrorinitial;
|
||||
}
|
||||
|
||||
if (defined $smtpuser and $smtpuser ne '') {
|
||||
|
||||
#use MIME::Base64;
|
||||
print MAIL 'ehlo ' . $smtp_server . "\r\n";
|
||||
|
||||
my $authloginavailable = 0;
|
||||
while (<MAIL>) {
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrorehlo;
|
||||
} elsif (/auth.login/gi) { #auth login available
|
||||
$authloginavailable = ($authloginavailable or 1);
|
||||
} elsif (/ok/gi) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($authloginavailable == 0) {
|
||||
close(MAIL);
|
||||
return $smtpnoauthloginavailable;
|
||||
}
|
||||
|
||||
print MAIL "auth login\r\n";
|
||||
$_ = <MAIL>;
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrorlogin;
|
||||
}
|
||||
|
||||
print MAIL encode_base64($smtpuser,'') . "\r\n";
|
||||
$_ = <MAIL>;
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerroruser;
|
||||
}
|
||||
|
||||
print MAIL encode_base64($smtppasswd,'') . "\r\n";
|
||||
$_ = <MAIL>;
|
||||
#emaildebug($_,$logger);
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrorpass; #auth unsuccessful
|
||||
}
|
||||
|
||||
} else {
|
||||
|
||||
print MAIL 'helo ' . $smtp_server . "\r\n";
|
||||
$_ = <MAIL>;
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrorhelo;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
print MAIL 'mail from: <' . $fromemail . ">\r\n";
|
||||
$_ = <MAIL>;
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrorfrom;
|
||||
}
|
||||
|
||||
foreach (splitrcpts($to)) {
|
||||
print MAIL 'rcpt to: <' . $_ . ">\r\n";
|
||||
$_ = <MAIL>;
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrorrcpt;
|
||||
}
|
||||
}
|
||||
|
||||
print MAIL "data\r\n";
|
||||
$_ = <MAIL>;
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrordata;
|
||||
}
|
||||
#print MAIL "123";
|
||||
#print MAIL $crlf . '.' . $crlf;
|
||||
#$_ = <MAIL>;
|
||||
|
||||
} elsif ($mailtype == 0) {
|
||||
if (not open(MAIL,"| $mailprog -t")) {
|
||||
emailwarn('problem with pipe to ' . $mailprog . ': ' . $!,$logger);
|
||||
return $mailprogpipeerror;
|
||||
}
|
||||
}
|
||||
|
||||
if ($mailtype == 2) {
|
||||
eval {
|
||||
use Net::SMTP;
|
||||
my $smtp;
|
||||
if (not $smtp = Net::SMTP->new($smtp_server, Debug => 0)) {
|
||||
#emailwarn('unable to create Net::SMTP object - ' . $smtp_server);
|
||||
#if (defined $emailwarncode and ref $emailwarncode eq 'CODE') {
|
||||
# &$emailwarncode('unable to create Net::SMTP object - ' . $smtp_server);
|
||||
#}
|
||||
die('unable to create Net::SMTP object - ' . $smtp_server);
|
||||
} else {
|
||||
$smtp->mail($fromemail);
|
||||
if (defined $smtpuser and $smtpuser ne '') {
|
||||
$smtp->auth($smtpuser,$smtppasswd);
|
||||
}
|
||||
$smtp->to($to);
|
||||
$smtp->data();
|
||||
$smtp->datasend($data);
|
||||
$smtp->dataend();
|
||||
$smtp->quit();
|
||||
}
|
||||
};
|
||||
if ($@) {
|
||||
#emailwarn('Net::SMTP fatal error: ' . $@);
|
||||
if (defined $emailwarncode and ref $emailwarncode eq 'CODE') {
|
||||
&$emailwarncode('Net::SMTP fatal error: ' . $@);
|
||||
}
|
||||
return $smtpnetfatalerror;
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
|
||||
print MAIL $data;
|
||||
print MAIL $crlf . '.' . $crlf;
|
||||
#print MAIL "\n.\n"; #$crlf . '.' . $crlf;
|
||||
|
||||
if ($mailtype == 1) {
|
||||
$_ = <MAIL>;
|
||||
emaildebug($_,$logger);
|
||||
if (/^[45]/) {
|
||||
close(MAIL);
|
||||
return $smtpprotocolerrordataaccepted;
|
||||
}
|
||||
}
|
||||
|
||||
print MAIL "quit\r\n";
|
||||
|
||||
if ($mailtype == 1) {
|
||||
$_ = <MAIL>;
|
||||
}
|
||||
|
||||
close(MAIL);
|
||||
|
||||
}
|
||||
|
||||
if ($writefiles) {
|
||||
foreach my $rcpt (splitrcpts($to)) {
|
||||
my $fileindex = 0;
|
||||
my $emailfile = $mailfilepath . $rcpt . '.' . $fileindex . $msgextension;
|
||||
while (-e $emailfile) {
|
||||
$fileindex += 1;
|
||||
$emailfile = $mailfilepath . $rcpt . '.' . $fileindex . $msgextension;
|
||||
}
|
||||
local *MAILFILE;
|
||||
if (not open (MAILFILE,'>' . $emailfile)) {
|
||||
#fileerror('cannot open file ' . $emailfile . ': ' . $!,$logger);
|
||||
if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') {
|
||||
&$fileerrorcode('cannot open file ' . $emailfile . ': ' . $!,$logger);
|
||||
}
|
||||
return $writemailfileerror;
|
||||
}
|
||||
print MAILFILE $data;
|
||||
close(MAILFILE);
|
||||
changemod($emailfile);
|
||||
}
|
||||
}
|
||||
|
||||
return $mailsentsuccessfully ;
|
||||
|
||||
}
|
||||
|
||||
sub cleanupmsgfiles {
|
||||
|
||||
my ($fileerrorcode,$filewarncode) = @_;
|
||||
my $rmsgextension = quotemeta($msgextension);
|
||||
local *MAILDIR;
|
||||
if (not opendir(MAILDIR, $mailfilepath)) {
|
||||
#fileerror('cannot opendir ' . $mailfilepath . ': ' . $!,$logger);
|
||||
if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') {
|
||||
&$fileerrorcode('cannot opendir ' . $mailfilepath . ': ' . $!,$logger);
|
||||
}
|
||||
return;
|
||||
}
|
||||
my @files = grep { /$rmsgextension$/ && -f $mailfilepath . $_ } readdir(MAILDIR);
|
||||
closedir MAILDIR;
|
||||
foreach my $file (@files) {
|
||||
my $filepath = $mailfilepath . $file;
|
||||
if ((unlink $filepath) == 0) {
|
||||
#filewarn('cannot remove ' . $filepath . ': ' . $!,$logger);
|
||||
if (defined $filewarncode and ref $filewarncode eq 'CODE') {
|
||||
&$filewarncode('cannot remove ' . $filepath . ': ' . $!,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub preparemailaddress {
|
||||
|
||||
my ($emailaddress) = @_;
|
||||
my $cleanedemailaddress = trim($emailaddress);
|
||||
$cleanedemailaddress =~ s/^.*<//g;
|
||||
$cleanedemailaddress =~ s/>$//g;
|
||||
return $cleanedemailaddress;
|
||||
|
||||
}
|
||||
|
||||
sub splitrcpts {
|
||||
|
||||
my ($rcptemails) = @_;
|
||||
my @rcptemails_arr = ();
|
||||
foreach my $rcptemail (split(/;|,/, $rcptemails)) {
|
||||
my $cleanedemailaddress = preparemailaddress($rcptemail);
|
||||
if (defined $cleanedemailaddress and $cleanedemailaddress ne '') {
|
||||
push @rcptemails_arr,$cleanedemailaddress;
|
||||
}
|
||||
}
|
||||
return @rcptemails_arr;
|
||||
|
||||
}
|
||||
|
||||
sub cleanrcpts {
|
||||
|
||||
my ($rcptemails) = @_;
|
||||
if (defined $rcptemails and $rcptemails ne '') {
|
||||
return '<' . join('>, <',splitrcpts($rcptemails)) . '>';
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub mergercpts {
|
||||
|
||||
my (@rcptemails) = @_;
|
||||
return join(',',splitrcpts(join(',',@rcptemails)));
|
||||
|
||||
}
|
||||
|
||||
sub send_message {
|
||||
|
||||
my ($to, $subject, $message,$fileerrorcode, $emailwarncode) = @_;
|
||||
my $errormsg = $mailingdisabled;
|
||||
if ($emailenable) {
|
||||
$errormsg = send_simple_mail($to,$subject,$message,$sender_address,$system_name, $sender_address,$fileerrorcode, $emailwarncode);
|
||||
if ($errormsg != $mailsentsuccessfully ) {
|
||||
#emailwarn('error sending email to ' . $to . ' via ' . $smtp_server . ' (' . $errorcode . ')',$_,$logger);
|
||||
if (defined $emailwarncode and ref $emailwarncode eq 'CODE') {
|
||||
&$emailwarncode('error sending email to ' . $to . ' via ' . $smtp_server,$mailerr_messages->{$errormsg},$_,$logger);
|
||||
}
|
||||
} else {
|
||||
emailinfo('email sent to ' . $to . ' via ' . $smtp_server,$logger);
|
||||
}
|
||||
}
|
||||
return $errormsg;
|
||||
|
||||
}
|
||||
|
||||
sub send_email {
|
||||
|
||||
my ($email,$attachments,$fileerrorcode, $emailwarncode) = @_;
|
||||
my $errormsg = $mailingdisabled;
|
||||
if ($emailenable and defined $email) {
|
||||
if (not exists $email->{return_path} or not defined $email->{return_path}) {
|
||||
$email->{return_path} = $sender_address;
|
||||
}
|
||||
|
||||
if (not exists $email->{priority} or not defined $email->{priority}) {
|
||||
$email->{priority} = $normalpriority;
|
||||
}
|
||||
|
||||
if (not exists $email->{sender_name} or not defined $email->{sender_name}) {
|
||||
$email->{sender_name} = $system_name;
|
||||
}
|
||||
|
||||
if (not exists $email->{from} or not defined $email->{from}) {
|
||||
$email->{from} = $sender_address;
|
||||
}
|
||||
|
||||
if (not exists $email->{guid} or not defined $email->{guid}) {
|
||||
$email->{guid} = create_guid();
|
||||
}
|
||||
|
||||
$errormsg = send_mail_with_attachments($email,$attachments,$fileerrorcode, $emailwarncode);
|
||||
if ($errormsg != $mailsentsuccessfully ) {
|
||||
#emailwarn('error sending email to ' . mergercpts(($email->{to},$email->{cc},$email->{bcc})) . ' via ' . $smtp_server . ' (' . $errorcode . ')',$_,$logger);
|
||||
if (defined $emailwarncode and ref $emailwarncode eq 'CODE') {
|
||||
&$emailwarncode('error sending email to ' . mergercpts(($email->{to},$email->{cc},$email->{bcc})) . ' via ' . $smtp_server,$mailerr_messages->{$errormsg},$_,$logger);
|
||||
}
|
||||
} else {
|
||||
emailinfo('email sent to ' . mergercpts(($email->{to},$email->{cc},$email->{bcc})) . ' via ' . $smtp_server,$logger);
|
||||
}
|
||||
}
|
||||
return $errormsg;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,6 @@
|
||||
package NoSqlConnector;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
1;
|
||||
@ -0,0 +1,235 @@
|
||||
# mysql, oracle, mssql, .. matrix db interconnection test
|
||||
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use LoadCLIConfig;
|
||||
|
||||
use ConnectorPool qw(
|
||||
destroy_dbs
|
||||
get_sqlserver_test_db
|
||||
get_postgres_test_db
|
||||
get_oracle_test_db
|
||||
get_mysql_test_db
|
||||
get_csv_test_db
|
||||
get_sqlite_test_db
|
||||
);
|
||||
|
||||
use Test::Unit::Procedural;
|
||||
|
||||
use test::csv_table;
|
||||
use test::mysql_table;
|
||||
use test::oracle_table;
|
||||
use test::postgres_table;
|
||||
use test::sqlite_table;
|
||||
use test::sqlserver_table;
|
||||
|
||||
my $sort_config = [ { numeric => 1,
|
||||
dir => 1,
|
||||
column => 'column1',
|
||||
},
|
||||
{ numeric => 1,
|
||||
dir => -1,
|
||||
memberchain => 'column2',
|
||||
},
|
||||
];
|
||||
|
||||
sub set_up {
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub test_sync_tables_to_sqlite {
|
||||
|
||||
test::sqlserver_table::sync_table(\&get_sqlite_test_db);
|
||||
test::postgres_table::sync_table(\&get_sqlite_test_db);
|
||||
test::oracle_table::sync_table(\&get_sqlite_test_db);
|
||||
test::sqlite_table::sync_table(\&get_sqlite_test_db);
|
||||
test::csv_table::sync_table(\&get_sqlite_test_db);
|
||||
test::mysql_table::sync_table(\&get_sqlite_test_db);
|
||||
|
||||
}
|
||||
|
||||
sub test_sync_tables_to_mysql {
|
||||
|
||||
test::sqlserver_table::sync_table(\&get_mysql_test_db);
|
||||
test::postgres_table::sync_table(\&get_mysql_test_db);
|
||||
test::oracle_table::sync_table(\&get_mysql_test_db);
|
||||
test::sqlite_table::sync_table(\&get_mysql_test_db);
|
||||
test::csv_table::sync_table(\&get_mysql_test_db);
|
||||
test::mysql_table::sync_table(\&get_mysql_test_db);
|
||||
|
||||
}
|
||||
|
||||
sub test_sync_tables_to_postgres {
|
||||
|
||||
test::sqlserver_table::sync_table(\&get_postgres_test_db);
|
||||
test::postgres_table::sync_table(\&get_postgres_test_db);
|
||||
test::oracle_table::sync_table(\&get_postgres_test_db);
|
||||
test::sqlite_table::sync_table(\&get_postgres_test_db);
|
||||
test::csv_table::sync_table(\&get_postgres_test_db);
|
||||
test::mysql_table::sync_table(\&get_postgres_test_db);
|
||||
|
||||
}
|
||||
|
||||
sub test_sync_tables_to_oracle {
|
||||
|
||||
test::sqlserver_table::sync_table(\&get_oracle_test_db);
|
||||
test::postgres_table::sync_table(\&get_oracle_test_db);
|
||||
test::oracle_table::sync_table(\&get_oracle_test_db);
|
||||
test::sqlite_table::sync_table(\&get_oracle_test_db);
|
||||
test::csv_table::sync_table(\&get_oracle_test_db);
|
||||
test::mysql_table::sync_table(\&get_oracle_test_db);
|
||||
|
||||
}
|
||||
|
||||
sub test_sync_tables_to_sqlserver {
|
||||
|
||||
test::sqlserver_table::sync_table(\&get_sqlserver_test_db);
|
||||
test::postgres_table::sync_table(\&get_sqlserver_test_db);
|
||||
test::oracle_table::sync_table(\&get_sqlserver_test_db);
|
||||
test::sqlite_table::sync_table(\&get_sqlserver_test_db);
|
||||
test::csv_table::sync_table(\&get_sqlserver_test_db);
|
||||
test::mysql_table::sync_table(\&get_sqlserver_test_db);
|
||||
|
||||
}
|
||||
|
||||
sub test_sync_tables_to_csv {
|
||||
|
||||
test::sqlserver_table::sync_table(\&get_csv_test_db);
|
||||
test::postgres_table::sync_table(\&get_csv_test_db);
|
||||
test::oracle_table::sync_table(\&get_csv_test_db);
|
||||
test::sqlite_table::sync_table(\&get_csv_test_db);
|
||||
test::csv_table::sync_table(\&get_csv_test_db);
|
||||
test::mysql_table::sync_table(\&get_csv_test_db);
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_sqlserver {
|
||||
|
||||
my $result = test::sqlserver_table::test_table_source_select('column1 is not null',2,3,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_postgres {
|
||||
|
||||
my $result = test::postgres_table::test_table_source_select('column1 is not null',2,3,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_oracle {
|
||||
|
||||
my $result = test::oracle_table::test_table_source_select('column1 is not null',0,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_sqlite {
|
||||
|
||||
my $result = test::sqlite_table::test_table_source_select('column1 is not null',2,3,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_csv {
|
||||
|
||||
my $result = test::csv_table::test_table_source_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_mysql {
|
||||
|
||||
my $result = test::mysql_table::test_table_source_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_local {
|
||||
$ConnectorPool::test_db = 'sqlserver';
|
||||
_table_local_selects();
|
||||
$ConnectorPool::test_db = 'postgres';
|
||||
_table_local_selects();
|
||||
$ConnectorPool::test_db = 'oracle';
|
||||
_table_local_selects();
|
||||
$ConnectorPool::test_db = 'sqlite';
|
||||
_table_local_selects();
|
||||
$ConnectorPool::test_db = 'mysql';
|
||||
_table_local_selects();
|
||||
$ConnectorPool::test_db = 'csv';
|
||||
_table_local_selects();
|
||||
|
||||
$ConnectorPool::test_db = 'mysql';
|
||||
}
|
||||
sub _table_local_selects {
|
||||
my $result = test::sqlserver_table::test_table_local_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'local query failed');
|
||||
$result = test::postgres_table::test_table_local_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
$result = test::oracle_table::test_table_local_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'local query failed');
|
||||
$result = test::sqlite_table::test_table_local_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
$result = test::csv_table::test_table_local_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
$result = test::mysql_table::test_table_source_select('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
}
|
||||
|
||||
sub test_select_source_temp_sqlserver {
|
||||
|
||||
my $result = test::sqlserver_table::test_table_source_select_temptable('column1 is not null',2,3,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_temp_postgres {
|
||||
|
||||
my $result = test::postgres_table::test_table_source_select_temptable('column1 is not null',2,3,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_temp_oracle {
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
my $result = test::oracle_table::test_table_source_select_temptable('column1 is not null',0,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub test_select_source_temp_sqlite {
|
||||
|
||||
my $result = test::sqlite_table::test_table_source_select_temptable('column1 is not null',2,3,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
#not supported
|
||||
#sub test_select_source_temp_csv {
|
||||
#
|
||||
#
|
||||
#}
|
||||
|
||||
sub test_select_source_temp_mysql {
|
||||
|
||||
my $result = test::mysql_table::test_table_source_select_temptable('column1 is not null',2,1,$sort_config);
|
||||
assert((scalar @$result) == 1,'source query failed');
|
||||
|
||||
}
|
||||
|
||||
sub tear_down {
|
||||
|
||||
}
|
||||
|
||||
create_suite();
|
||||
run_suite();
|
||||
|
||||
destroy_dbs();
|
||||
|
||||
exit;
|
||||
@ -0,0 +1,347 @@
|
||||
# gearman service layer test
|
||||
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use LoadCLIConfig;
|
||||
|
||||
use Logging;
|
||||
|
||||
use Test::Unit::Procedural;
|
||||
|
||||
use Service::TestService;
|
||||
use ServiceProxy qw(new_async_do);
|
||||
|
||||
use Serialization qw(
|
||||
$format_xml
|
||||
$format_yaml
|
||||
$format_json
|
||||
$format_php
|
||||
$format_perl
|
||||
);
|
||||
|
||||
my $service1;
|
||||
my $service2;
|
||||
my $service3;
|
||||
|
||||
my $service = test::TestService->new();
|
||||
my $proxy = ServiceProxy->new();
|
||||
#$service1 = test::TestService->new();
|
||||
#$service2 = test::TestService->new();
|
||||
#$service3 = test::TestService->new();
|
||||
|
||||
|
||||
sub set_up {
|
||||
|
||||
#set_project(yearmonth2projecttag($download_year,$download_month));
|
||||
# $service = test::TestService->new();
|
||||
# $proxy = ServiceProxy->new();
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub test_roundtrip_do {
|
||||
|
||||
my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('roundtrip',\&on_error,$input);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub test_roundtrip_json {
|
||||
$service->stop();
|
||||
$service->{serialization_format} = $format_json;
|
||||
$proxy->{serialization_format} = $format_json;
|
||||
$service->start();
|
||||
|
||||
my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('roundtrip',\&on_error,$input);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed');
|
||||
}
|
||||
$service->stop();
|
||||
$service->{serialization_format} = undef;
|
||||
$proxy->{serialization_format} = undef;
|
||||
$service->start();
|
||||
}
|
||||
|
||||
sub test_roundtrip_yaml {
|
||||
$service->stop();
|
||||
$service->{serialization_format} = $format_yaml;
|
||||
$proxy->{serialization_format} = $format_yaml;
|
||||
$service->start();
|
||||
|
||||
my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('roundtrip',\&on_error,$input);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed');
|
||||
}
|
||||
$service->stop();
|
||||
$service->{serialization_format} = undef;
|
||||
$proxy->{serialization_format} = undef;
|
||||
$service->start();
|
||||
}
|
||||
|
||||
sub Xtest_roundtrip_php {
|
||||
$service->stop();
|
||||
$service->{serialization_format} = $format_php;
|
||||
$proxy->{serialization_format} = $format_php;
|
||||
$service->start();
|
||||
|
||||
my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('roundtrip',\&on_error,$input);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed');
|
||||
}
|
||||
$service->stop();
|
||||
$service->{serialization_format} = undef;
|
||||
$proxy->{serialization_format} = undef;
|
||||
$service->start();
|
||||
}
|
||||
|
||||
sub test_roundtrip_xml {
|
||||
$service->stop();
|
||||
$service->{serialization_format} = $format_xml;
|
||||
$proxy->{serialization_format} = $format_xml;
|
||||
$service->start();
|
||||
|
||||
my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('roundtrip',\&on_error,$input);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed');
|
||||
}
|
||||
$service->stop();
|
||||
$service->{serialization_format} = undef;
|
||||
$proxy->{serialization_format} = undef;
|
||||
$service->start();
|
||||
}
|
||||
|
||||
sub test_roundtrip_perl {
|
||||
$service->stop();
|
||||
$service->{serialization_format} = $format_perl;
|
||||
$proxy->{serialization_format} = $format_perl;
|
||||
$service->start();
|
||||
|
||||
my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('roundtrip',\&on_error,$input);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed');
|
||||
}
|
||||
$service->stop();
|
||||
$service->{serialization_format} = undef;
|
||||
$proxy->{serialization_format} = undef;
|
||||
$service->start();
|
||||
}
|
||||
|
||||
sub test_noop_do {
|
||||
|
||||
#my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
#$data->{$i} = 'roundtrip test ' . $i;
|
||||
#my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('noop',\&on_error);
|
||||
#print $output->[0]->{$output->[1]} . "\n";
|
||||
assert(!defined $output,'service do noop failed');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub test_exception_do {
|
||||
|
||||
#my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
#$data->{$i} = 'roundtrip test ' . $i;
|
||||
#my $input = [ $data, $i ];
|
||||
my $exception = undef;
|
||||
my $output = $proxy->do('exception',sub { $exception = shift; });
|
||||
#print $output->[0]->{$output->[1]} . "\n";
|
||||
assert(length($exception) > 0,'service do exception failed');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub test_sleep_roundtrip_do {
|
||||
|
||||
my $proxy = ServiceProxy->new(undef,1.5);
|
||||
|
||||
my $data = {};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'sleep roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
my $output = $proxy->do('sleeproundtrip',\&on_error,1,$input);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i},'service do sleep roundtrip failed');
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub test_sleep_roundtrip_do_async1 {
|
||||
|
||||
#my $service = test::TestService->new();
|
||||
my $proxy = ServiceProxy->new();
|
||||
|
||||
my $data = {};
|
||||
my $output = undef;
|
||||
|
||||
for (my $i = 0; $i < 3; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
if ($i > 0) {
|
||||
$proxy->wait(3);
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
assert($output->[0]->{$output->[1]} eq $data->{$i - 1},'service do async roundtrip failed');
|
||||
$output = undef;
|
||||
}
|
||||
assert($proxy->do_async('sleeproundtrip',sub { $output = shift; },\&on_error,2,$input),'service do async failed');
|
||||
|
||||
}
|
||||
#$proxy->wait();
|
||||
|
||||
}
|
||||
|
||||
sub test_sleep_roundtrip_do_async2 {
|
||||
|
||||
my $data = {};
|
||||
my @proxies = ();
|
||||
|
||||
my $on_complete = sub { my $output = shift;
|
||||
print $output->[0]->{$output->[1]} . "\n";
|
||||
#assert($output->[0]->{$output->[1]} eq $data->{$i},'service do async roundtrip failed');
|
||||
};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
#if ($i > 0) {
|
||||
# $proxy->wait();
|
||||
# print $output->[0]->{$output->[1]} . "\n";
|
||||
#assert($output->[0]->{$output->[1]} eq $data->{$i - 1},'service do async roundtrip failed');
|
||||
# $output = undef;
|
||||
#}
|
||||
#my $proxy;
|
||||
#if ($i % 3 == 0) {
|
||||
# $proxy = $proxy1;
|
||||
#} elsif ($i % 3 == 1) {
|
||||
# $proxy = $proxy2;
|
||||
#} elsif ($i % 3 == 1) {
|
||||
# $proxy = $proxy3;
|
||||
#}
|
||||
|
||||
my $proxy = new_async_do('sleeproundtrip', $on_complete, \&on_error, 0, $input); #,
|
||||
#sub {
|
||||
#print shift . "\n";
|
||||
##assert(0,'on_error: ' . shift);
|
||||
#},
|
||||
#0,$input);
|
||||
assert(defined $proxy,'proxy not created');
|
||||
#$proxy->wait();
|
||||
push(@proxies, $proxy);
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
#undef @proxies;
|
||||
#$service->stop();
|
||||
#$proxy->wait();
|
||||
|
||||
}
|
||||
|
||||
sub test_exception_do_async {
|
||||
|
||||
my $data = {};
|
||||
my @proxies = ();
|
||||
|
||||
my $on_error = sub { my $exception = shift;
|
||||
print $exception . "\n";
|
||||
assert(length($exception) > 0,'service do async roundtrip failed');
|
||||
};
|
||||
|
||||
for (my $i = 0; $i < 10; $i++) {
|
||||
$data->{$i} = 'roundtrip test ' . $i;
|
||||
my $input = [ $data, $i ];
|
||||
#if ($i > 0) {
|
||||
# $proxy->wait();
|
||||
# print $output->[0]->{$output->[1]} . "\n";
|
||||
#assert($output->[0]->{$output->[1]} eq $data->{$i - 1},'service do async roundtrip failed');
|
||||
# $output = undef;
|
||||
#}
|
||||
#my $proxy;
|
||||
#if ($i % 3 == 0) {
|
||||
# $proxy = $proxy1;
|
||||
#} elsif ($i % 3 == 1) {
|
||||
# $proxy = $proxy2;
|
||||
#} elsif ($i % 3 == 1) {
|
||||
# $proxy = $proxy3;
|
||||
#}
|
||||
|
||||
my $proxy = new_async_do('sleeproundtrip', undef, $on_error, 0, $input); #,
|
||||
#sub {
|
||||
#print shift . "\n";
|
||||
##assert(0,'on_error: ' . shift);
|
||||
#},
|
||||
#0,$input);
|
||||
assert(defined $proxy,'proxy not created');
|
||||
#$proxy->wait();
|
||||
push(@proxies, $proxy);
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
#undef @proxies;
|
||||
#$service->stop();
|
||||
#$proxy->wait();
|
||||
|
||||
}
|
||||
|
||||
sub on_error {
|
||||
print shift . "\n";
|
||||
#assert(0,'on_error: ' . shift);
|
||||
}
|
||||
|
||||
sub tear_down {
|
||||
|
||||
#undef $service;
|
||||
#undef $proxy;
|
||||
|
||||
}
|
||||
|
||||
create_suite();
|
||||
run_suite();
|
||||
|
||||
#destroy_dbs();
|
||||
undef $service;
|
||||
undef $proxy;
|
||||
|
||||
exit;
|
||||
@ -0,0 +1,213 @@
|
||||
package Serialization;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
serialize
|
||||
deserialize
|
||||
serialize_storable
|
||||
deserialize_storable
|
||||
serialize_xml
|
||||
deserialize_xml
|
||||
serialize_yaml
|
||||
deserialize_yaml
|
||||
serialize_json
|
||||
deserialize_json
|
||||
serialize_php
|
||||
deserialize_php
|
||||
serialize_perl
|
||||
deserialize_perl
|
||||
serialize_storable_base64
|
||||
deserialize_storable_base64
|
||||
|
||||
$format_xml
|
||||
$format_yaml
|
||||
$format_json
|
||||
$format_php
|
||||
$format_perl
|
||||
$format_storable_base64
|
||||
);
|
||||
#$format_storable
|
||||
|
||||
#our $format_storable = 0;
|
||||
our $format_xml = 1;
|
||||
our $format_yaml = 2;
|
||||
our $format_json = 3;
|
||||
our $format_php = 4;
|
||||
our $format_perl = 5;
|
||||
our $format_storable_base64 = 6;
|
||||
|
||||
use MIME::Base64 qw(encode_base64 decode_base64);
|
||||
|
||||
#http://blogs.perl.org/users/steven_haryanto/2010/09/comparison-of-perl-serialization-modules.html
|
||||
use Storable; # qw( nfreeze thaw );
|
||||
|
||||
use JSON::XS; # qw(encode_json decode_json);
|
||||
|
||||
use Data::Dump; # qw(dump);
|
||||
$Data::Dump::INDENT = ' ';
|
||||
$Data::Dump::TRY_BASE64 = 0;
|
||||
|
||||
#use YAML::Syck qw(Dump Load);
|
||||
#$YAML::Syck::ImplicitTyping = 1;
|
||||
|
||||
use YAML::XS; # qw(Dump Load);
|
||||
$YAML::XS::UseCode = 0;
|
||||
$YAML::XS::DumpCode = 0;
|
||||
$YAML::XS::LoadCode = 0;
|
||||
$YAML::XS::QuoteNumericStrings = 1;
|
||||
|
||||
use XML::Dumper 0.81;
|
||||
my $errorcontext = undef; #undef to disable
|
||||
my $protocolencoding = 'ISO-8859-1';
|
||||
|
||||
use PHP::Serialization; #qw(serialize unserialize);
|
||||
|
||||
#encrypted:
|
||||
#use Data::Serializer;
|
||||
#my $serializer = Data::Serializer->new();
|
||||
#$serializer = Data::Serializer->new(
|
||||
# serializer => 'Storable',
|
||||
# digester => 'MD5',
|
||||
# cipher => 'DES',
|
||||
# secret => 'my secret',
|
||||
# compress => 1,
|
||||
# );
|
||||
|
||||
#$serialized = $obj->serialize({a => [1,2,3],b => 5});
|
||||
#$deserialized = $obj->deserialize($serialized);
|
||||
|
||||
|
||||
sub serialize {
|
||||
my ($input_ref,$format) = @_;
|
||||
if ($format == $format_xml) {
|
||||
return serialize_xml($input_ref);
|
||||
} elsif ($format == $format_yaml) {
|
||||
return serialize_yaml($input_ref);
|
||||
} elsif ($format == $format_json) {
|
||||
return serialize_json($input_ref);
|
||||
} elsif ($format == $format_php) {
|
||||
return serialize_php($input_ref);
|
||||
} elsif ($format == $format_perl) {
|
||||
return serialize_perl($input_ref);
|
||||
} elsif ($format == $format_storable_base64) {
|
||||
return serialize_storable_base64($input_ref);
|
||||
} else { #$format_storable
|
||||
return serialize_storable($input_ref);
|
||||
}
|
||||
}
|
||||
|
||||
sub deserialize {
|
||||
my ($input_ref,$format) = @_;
|
||||
if ($format == $format_xml) {
|
||||
return deserialize_xml($input_ref);
|
||||
} elsif ($format == $format_yaml) {
|
||||
return deserialize_yaml($input_ref);
|
||||
} elsif ($format == $format_json) {
|
||||
return deserialize_json($input_ref);
|
||||
} elsif ($format == $format_php) {
|
||||
return deserialize_php($input_ref);
|
||||
} elsif ($format == $format_perl) {
|
||||
return deserialize_perl($input_ref);
|
||||
} elsif ($format == $format_storable_base64) {
|
||||
return deserialize_storable_base64($input_ref);
|
||||
} else { #$format_storable
|
||||
return deserialize_storable($input_ref);
|
||||
}
|
||||
}
|
||||
|
||||
sub serialize_storable {
|
||||
my $input_ref = shift;
|
||||
return Storable::nfreeze($input_ref);
|
||||
}
|
||||
sub deserialize_storable {
|
||||
my $input_ref = shift;
|
||||
return Storable::thaw($input_ref);
|
||||
}
|
||||
|
||||
sub serialize_storable_base64 {
|
||||
my $input_ref = shift;
|
||||
return encode_base64(Storable::nfreeze($input_ref),'');
|
||||
}
|
||||
sub deserialize_storable_base64 {
|
||||
my $input_ref = shift;
|
||||
return Storable::thaw(decode_base64($input_ref));
|
||||
}
|
||||
|
||||
sub _get_xml_dumper {
|
||||
my $xml_dumper;
|
||||
my %xml_parser_params = ();
|
||||
if ($errorcontext) {
|
||||
$xml_parser_params{ErrorContext} = $errorcontext;
|
||||
#$xml_dumper = XML::Dumper->new(ErrorContext => $errorcontext,ProtocolEncoding => $protocolencoding);
|
||||
#} else {
|
||||
#$xml_dumper = XML::Dumper->new(ProtocolEncoding => $protocolencoding);
|
||||
}
|
||||
$xml_parser_params{ProtocolEncoding} = $protocolencoding;
|
||||
$xml_dumper = XML::Dumper->new(%xml_parser_params);
|
||||
#$xml_dumper->{xml_parser_params} = \%xml_parser_params;
|
||||
$xml_dumper->dtd();
|
||||
|
||||
return $xml_dumper;
|
||||
}
|
||||
|
||||
sub serialize_xml {
|
||||
my $input_ref = shift;
|
||||
return _get_xml_dumper()->pl2xml($input_ref);
|
||||
}
|
||||
|
||||
sub deserialize_xml {
|
||||
my $input_ref = shift;
|
||||
return _get_xml_dumper()->xml2pl($input_ref);
|
||||
}
|
||||
|
||||
sub serialize_json {
|
||||
my $input_ref = shift;
|
||||
return JSON::XS::encode_json($input_ref);
|
||||
}
|
||||
|
||||
sub deserialize_json {
|
||||
my $input_ref = shift;
|
||||
return JSON::XS::decode_json($input_ref);
|
||||
}
|
||||
|
||||
sub serialize_yaml {
|
||||
my $input_ref = shift;
|
||||
return YAML::XS::Dump($input_ref);
|
||||
}
|
||||
|
||||
sub deserialize_yaml {
|
||||
my $input_ref = shift;
|
||||
return YAML::XS::Load($input_ref);
|
||||
}
|
||||
|
||||
|
||||
sub serialize_php {
|
||||
my $input_ref = shift;
|
||||
return PHP::Serialization::serialize($input_ref);
|
||||
}
|
||||
|
||||
sub deserialize_php {
|
||||
my $input_ref = shift;
|
||||
return PHP::Serialization::unserialize($input_ref);
|
||||
}
|
||||
|
||||
sub serialize_perl {
|
||||
my $input_ref = shift;
|
||||
return Data::Dump::dump($input_ref);
|
||||
}
|
||||
|
||||
sub deserialize_perl {
|
||||
my $input_ref = shift;
|
||||
my $data = eval $input_ref;
|
||||
if ($@) {
|
||||
die($@);
|
||||
} else {
|
||||
return $data;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,293 @@
|
||||
# service layer backend
|
||||
|
||||
package Service;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use threads qw(yield);
|
||||
use threads::shared;
|
||||
|
||||
use Globals qw(
|
||||
@jobservers
|
||||
$jobnamespace
|
||||
);
|
||||
|
||||
use Logging qw(
|
||||
getlogger
|
||||
servicedebug
|
||||
serviceinfo
|
||||
);
|
||||
use LogError qw(
|
||||
serviceerror
|
||||
servicewarn
|
||||
notimplementederror
|
||||
);
|
||||
|
||||
use Utils qw(threadid);
|
||||
use Serialization qw(serialize deserialize);
|
||||
|
||||
use Encode qw(encode_utf8);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(); #get_tableidentifier);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
use Gearman::Worker;
|
||||
#use Time::HiRes qw(usleep);
|
||||
use Time::HiRes qw(sleep);
|
||||
|
||||
my $sleep_secs_default = 0.1; # = 0.1;
|
||||
|
||||
my $instance_counts = {};
|
||||
|
||||
sub new {
|
||||
|
||||
#my $class = shift;
|
||||
#my $self = bless {}, $class;
|
||||
my ($class,$functions,$derived_class,$serialization_format,$no_autostart) = @_;
|
||||
my $self = bless {}, $derived_class;
|
||||
|
||||
$self->{worker} = undef;
|
||||
$self->{functions} = $functions;
|
||||
#$self->_register_functions();
|
||||
|
||||
my $running = 0;
|
||||
$self->{running_ref} = share($running);
|
||||
$self->{thread} = undef;
|
||||
$self->{create_tid} = threadid();
|
||||
$self->{tid} = $self->{create_tid};
|
||||
$self->{worker_tid} = undef;
|
||||
$self->{sleep_secs} = $sleep_secs_default;
|
||||
$self->{serialization_format} = $serialization_format;
|
||||
|
||||
my $identifier = ref $self;
|
||||
my $instance_count;
|
||||
if (exists $instance_counts->{$identifier}) {
|
||||
$instance_count = $instance_counts->{$identifier};
|
||||
} else {
|
||||
$instance_count = 0;
|
||||
}
|
||||
$self->{instance} = $instance_count;
|
||||
$instance_count++;
|
||||
$instance_counts->{$identifier} = $instance_count;
|
||||
|
||||
if (not $no_autostart) {
|
||||
$self->start();
|
||||
}
|
||||
|
||||
#$self = share($self);
|
||||
#autostart??
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub identifier {
|
||||
my $self = shift;
|
||||
return (ref $self) . '(' . $self->{instance} . ')';
|
||||
}
|
||||
|
||||
sub _register_functions {
|
||||
|
||||
my $self = shift;
|
||||
my $functions = $self->{functions};
|
||||
|
||||
if (defined $functions and ref $functions eq 'HASH') {
|
||||
my $count = 0;
|
||||
foreach my $name (keys %$functions) {
|
||||
my $code = $functions->{$name};
|
||||
if (defined $code and ref $code eq 'CODE') {
|
||||
$self->{worker}->register_function($name,
|
||||
sub {
|
||||
#servicedebug($self,(ref $self) . ' connector destroyed',$logger);
|
||||
#my $resultref = serialize(&$code(deserialize($_[0]->argref())));
|
||||
#servicedebug($self,(ref $self) . ' connector destroyed',$logger);
|
||||
servicedebug($self,'invoking \'' . $name . '\', args length: ' . length(encode_utf8($_[0]->arg())),$logger);
|
||||
my $arg = deserialize($_[0]->arg(),$self->{serialization_format});
|
||||
my (@ret) = &$code(@$arg);
|
||||
my $result = serialize(\@ret,$self->{serialization_format});
|
||||
servicedebug($self,'returning from \'' . $name . '\', result length: ' . length(encode_utf8($result)),$logger);
|
||||
#$_[0]->set_status($numerator, $denominator);???
|
||||
return $result;
|
||||
}
|
||||
);
|
||||
servicedebug($self,'function \'' . $name . '\' registered',$logger);
|
||||
$count++;
|
||||
} else {
|
||||
servicewarn($self,'cannot register function ' . $name,$logger);
|
||||
}
|
||||
}
|
||||
serviceinfo($self,$count . ' functions registered at job servers ' . join(',',@jobservers),$logger);
|
||||
} else {
|
||||
serviceerror($self,'no functions to register',$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _unregister_functions {
|
||||
|
||||
my $self = shift;
|
||||
my $functions = $self->{functions};
|
||||
|
||||
if (defined $functions and ref $functions eq 'HASH') {
|
||||
my $count = 0;
|
||||
foreach my $name (keys %$functions) {
|
||||
$self->{worker}->unregister_function($name);
|
||||
servicedebug($self,'function \'' . $name . '\' unregistered',$logger);
|
||||
$count++;
|
||||
}
|
||||
serviceinfo($self,$count . ' functions unregistered from job servers ' . join(',',@jobservers),$logger);
|
||||
} else {
|
||||
serviceerror($self,'no functions to unregister',$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _worker {
|
||||
|
||||
my $context = shift;
|
||||
#my $tid = threadid();
|
||||
my $service = $context->{service};
|
||||
#${$context->{service}->{tid_ref}} = $tid;
|
||||
$service->{worker_tid} = threadid();
|
||||
$service->{tid} = $service->{worker_tid};
|
||||
servicedebug($service,'worker thread ' . $service->{worker_tid} . ' started',$logger);
|
||||
my $running_ref = $service->{running_ref};
|
||||
|
||||
my $stop_if = sub {
|
||||
lock($running_ref);
|
||||
#print join ',',@_ . "\n";
|
||||
if (not $$running_ref) {
|
||||
servicedebug($service,'shutting down work and worker thread ' . $service->{worker_tid} . ' ...',$logger);
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
};
|
||||
|
||||
my %worker_opts = (on_start => sub { $service->_on_start(@_); },
|
||||
on_complete => sub { $service->_on_complete(@_); },
|
||||
on_fail => sub { $service->_on_fail(@_); },
|
||||
stop_if => $stop_if );
|
||||
|
||||
$service->{worker} = Gearman::Worker->new(( job_servers => \@jobservers,
|
||||
prefix => $jobnamespace));
|
||||
$service->_register_functions();
|
||||
|
||||
while (not &$stop_if()) {
|
||||
$service->{worker}->work(%worker_opts);
|
||||
if ($service->{sleep_secs} > 0) {
|
||||
sleep($service->{sleep_secs});
|
||||
} else {
|
||||
yield();
|
||||
}
|
||||
}
|
||||
$service->_unregister_functions();
|
||||
#servicedebug($service,'worker thread ' . $service->{worker_tid} . ' shutting down',$logger);
|
||||
#threads->exit();
|
||||
}
|
||||
|
||||
sub start {
|
||||
|
||||
my $self = shift;
|
||||
if ($self->_is_create_thread()) {
|
||||
my $running_ref = $self->{running_ref};
|
||||
my $startup = 0;
|
||||
{
|
||||
lock($running_ref);
|
||||
if (not $$running_ref) {
|
||||
$$running_ref = 1;
|
||||
$startup = 1;
|
||||
}
|
||||
}
|
||||
if ($startup) {
|
||||
servicedebug($self,'starting worker thread ...',$logger);
|
||||
$self->{thread} = threads->create(\&_worker,
|
||||
|
||||
{ service => $self,
|
||||
#logger => $logger,
|
||||
}
|
||||
|
||||
);
|
||||
#$self->{worker_tid} = $self->{thread}->tid();
|
||||
} else {
|
||||
servicewarn($self,'worker thread already running?',$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub stop {
|
||||
|
||||
my $self = shift;
|
||||
if ($self->_is_create_thread()) {
|
||||
my $running_ref = $self->{running_ref};
|
||||
my $shutdown = 0;
|
||||
{
|
||||
lock($running_ref);
|
||||
if ($$running_ref) {
|
||||
$$running_ref = 0;
|
||||
$shutdown = 1;
|
||||
}
|
||||
}
|
||||
if ($shutdown) {
|
||||
servicedebug($self,'stopping worker thread ...',$logger);
|
||||
$self->{thread}->join();
|
||||
$self->{thread} = undef;
|
||||
$self->{worker_tid} = undef;
|
||||
servicedebug($self,'worker thread joined',$logger);
|
||||
} else {
|
||||
servicewarn($self,'thread already stopped',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _on_start {
|
||||
my $self = shift;
|
||||
if ($self->_is_worker_thread()) {
|
||||
servicedebug($self,'on_start',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
sub _on_complete {
|
||||
my $self = shift;
|
||||
if ($self->_is_worker_thread()) {
|
||||
servicedebug($self,'on_complete',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
sub _on_fail {
|
||||
my $self = shift;
|
||||
if ($self->_is_worker_thread()) {
|
||||
servicedebug($self,'on_fail',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
|
||||
my $self = shift;
|
||||
#print "DESTROY is worker: " . $self->_is_worker_thread() . "\n";
|
||||
if ($self->_is_create_thread()) {
|
||||
servicedebug($self,'destroying service ...',$logger);
|
||||
$self->stop();
|
||||
servicedebug($self,(ref $self) . ' service destroyed',$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _is_worker_thread {
|
||||
my $self = shift;
|
||||
return (defined $self->{worker_tid} and $self->{worker_tid} == threadid());
|
||||
}
|
||||
|
||||
sub _is_create_thread {
|
||||
my $self = shift;
|
||||
return $self->{create_tid} == threadid();
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,97 @@
|
||||
package Service::TestService;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Logging qw(getlogger servicedebug);
|
||||
|
||||
use Service;
|
||||
|
||||
#use test::csv_table; # qw(test_table_bycolumn1);
|
||||
#use test::mysql_table;
|
||||
#use test::oracle_table;
|
||||
#use test::postgres_table;
|
||||
#use test::sqlite_table;
|
||||
#use test::sqlserver_table;
|
||||
|
||||
use Utils; # qw(create_guid);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter Service);
|
||||
our @EXPORT_OK = qw(
|
||||
roundtrip
|
||||
sleep_seconds
|
||||
noop
|
||||
exception
|
||||
);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $functions = {
|
||||
create_uuid => \&Utils::create_guid,
|
||||
roundtrip => \&roundtrip,
|
||||
noop => \&noop,
|
||||
exception => \&exception,
|
||||
sleeproundtrip => \&sleep_roundtrip,
|
||||
#test_csv_table_bycolumn1 => \&test::csv_table::test_table_bycolumn1,
|
||||
#test_mysql_table_bycolumn1 => \&test::mysql_table::test_table_bycolumn1,
|
||||
#test_oracle_table_bycolumn1 => \&test::oracle_table::test_table_bycolumn1,
|
||||
#test_postgres_table_bycolumn1 => \&test::postgres_table::test_table_bycolumn1,
|
||||
#test_sqlite_table_bycolumn1 => \&test::sqlite_table::test_table_bycolumn1
|
||||
};
|
||||
|
||||
sub new {
|
||||
|
||||
#my $class = shift;
|
||||
#my $self = Service->new($functions,$class);
|
||||
|
||||
#bless($self,$class);
|
||||
|
||||
#return $self;
|
||||
|
||||
my $self = Service->new($functions,@_);
|
||||
servicedebug($self,__PACKAGE__ . ' service created',$logger);
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub roundtrip {
|
||||
return @_;
|
||||
#my (@in) = @_;
|
||||
##my $error = 1/0;
|
||||
#return @in;
|
||||
}
|
||||
|
||||
sub sleep_roundtrip {
|
||||
sleep(shift);
|
||||
return @_;
|
||||
}
|
||||
|
||||
sub noop {
|
||||
|
||||
}
|
||||
|
||||
sub exception {
|
||||
return 1/0;
|
||||
}
|
||||
|
||||
#sub _on_start {
|
||||
# my $self = shift;
|
||||
# print "_on_start\n";
|
||||
#}
|
||||
|
||||
#sub _on_complete {
|
||||
# my $self = shift;
|
||||
# print "_on_complete\n";
|
||||
#}
|
||||
|
||||
#sub _on_fail {
|
||||
# my $self = shift;
|
||||
# print "_on_fail\n";
|
||||
#}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,507 @@
|
||||
# service layer backend
|
||||
|
||||
package ServiceProxy;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use threads qw(yield);
|
||||
use threads::shared; # qw(shared_clone);
|
||||
use Thread::Queue;
|
||||
|
||||
use Time::HiRes qw(sleep);
|
||||
|
||||
use Globals qw(
|
||||
@jobservers
|
||||
$jobnamespace
|
||||
);
|
||||
|
||||
use Logging qw(
|
||||
getlogger
|
||||
servicedebug
|
||||
serviceinfo
|
||||
);
|
||||
use LogError qw(
|
||||
serviceerror
|
||||
servicewarn
|
||||
notimplementederror
|
||||
);
|
||||
|
||||
use Utils qw(threadid);
|
||||
use Serialization qw(serialize deserialize);
|
||||
use Encode qw(encode_utf8);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(new_async_do new_do);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
use Gearman::Client;
|
||||
#sub RECEIVE_EXCEPTIONS {
|
||||
# print "RECEIVE_EXCEPTIONS";
|
||||
# return 1;
|
||||
#}
|
||||
use Gearman::Task;
|
||||
|
||||
my $timeout_secs_default = 0;
|
||||
#my $try_timeout_secs_default = 0;
|
||||
my $retry_count_default = 0;
|
||||
my $high_priority_default = 0;
|
||||
|
||||
my $block_destroy_default = 1;
|
||||
|
||||
my $poll_interval_secs = 0.1;
|
||||
|
||||
my $instance_count = 0;
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
my $self = bless {}, $class;
|
||||
my ($serialization_format,$timeout_secs,$block_destroy) = @_;
|
||||
|
||||
$self->{serialization_format} = $serialization_format;
|
||||
$self->{client} = undef;
|
||||
|
||||
$self->{timeout_secs} = ((defined $timeout_secs) ? $timeout_secs : $timeout_secs_default);
|
||||
#$self->{try_timeout_secs} = $try_timeout_secs_default;
|
||||
$self->{retry_count} = $retry_count_default;
|
||||
$self->{high_priority} = $high_priority_default;
|
||||
|
||||
$self->{block_destroy} = ((defined $block_destroy) ? $block_destroy : $block_destroy_default);
|
||||
|
||||
$self->{arg} = undef;
|
||||
#my $ret = undef;
|
||||
$self->{ret} = undef; # = share($ret);
|
||||
$self->{function} = undef;
|
||||
#my $exception = undef;
|
||||
$self->{exception} = undef; #share($exception);
|
||||
$self->{on_error} = undef;
|
||||
|
||||
$self->{on_complete} = undef;
|
||||
$self->{on_fail} = undef;
|
||||
$self->{on_status} = undef;
|
||||
|
||||
my $async_running = 0;
|
||||
$self->{async_running_ref} = share($async_running);
|
||||
$self->{thread} = undef;
|
||||
$self->{create_tid} = threadid();
|
||||
$self->{tid} = $self->{create_tid};
|
||||
$self->{wait_tid} = undef;
|
||||
$self->{queue} = undef;
|
||||
|
||||
$self->{instance} = $instance_count;
|
||||
$instance_count++;
|
||||
|
||||
#$self->{taskset} = undef;
|
||||
#$self->{task} = undef;
|
||||
|
||||
servicedebug($self,'service proxy created, job servers ' . join(',',@jobservers),$logger);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub identifier {
|
||||
my $self = shift;
|
||||
return '(' . $self->{instance} . ') ' . (length($self->{function}) > 0 ? '\'' . $self->{function} . '\'' : __PACKAGE__);
|
||||
}
|
||||
|
||||
sub new_async_do {
|
||||
#my ($function_name,$on_complete,$on_error,@args) = @_;
|
||||
#my $serialization_format = shift;
|
||||
#my $timeout_secs = shift;
|
||||
#my $block_destroy = shift;
|
||||
my $proxy = __PACKAGE__->new(); #$serialization_format,$timeout_secs,$block_destroy);
|
||||
if ($proxy->do_async(@_)) {
|
||||
return $proxy;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
sub new_do {
|
||||
#my ($function_name,$on_complete,$on_error,@args) = @_;
|
||||
#my $serialization_format = shift;
|
||||
#my $timeout_secs = shift;
|
||||
#my $block_destroy = shift;
|
||||
my $proxy = __PACKAGE__->new(); #$serialization_format,$timeout_secs,$block_destroy);
|
||||
return $proxy->do(@_);
|
||||
}
|
||||
|
||||
sub do_async {
|
||||
my $self = shift;
|
||||
my ($function_name,$on_complete,$on_error,@args) = @_;
|
||||
|
||||
if ($self->_check_async_running($on_error,'do_async \'' . $function_name . '\' failed because do_async \'' . $self->{function} . '\' is waiting',1)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
$self->{client} = undef;
|
||||
|
||||
$self->{function} = $function_name;
|
||||
$self->{ret} = undef;
|
||||
$self->{exception} = undef;
|
||||
|
||||
#$self->{taskset} = undef;
|
||||
#$self->{task} = undef;
|
||||
#$self->{thread} = undef;
|
||||
#$self->{wait_tid} = undef;
|
||||
|
||||
$self->{on_error} = $on_error;
|
||||
$self->{on_complete} = $on_complete;
|
||||
$self->{on_fail} = undef;
|
||||
$self->{on_status} = undef;
|
||||
|
||||
my $arg = serialize(\@args,$self->{serialization_format});
|
||||
$self->{arg} = \$arg;
|
||||
|
||||
#if (not defined $self->{queue}) {
|
||||
$self->{queue} = Thread::Queue->new();
|
||||
#}
|
||||
|
||||
servicedebug($self,'start waiting do_async \'' . $function_name . '\', args length: ' . length(encode_utf8($arg)),$logger);
|
||||
$self->{thread} = threads->create(\&_wait_thread,
|
||||
|
||||
{ proxy => $self,
|
||||
#logger => $logger,
|
||||
}
|
||||
|
||||
);
|
||||
#$self->{wait_tid} = $self->{thread}->tid();
|
||||
#$self->{thread}->detach();
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _get_task_opts {
|
||||
my $self = shift;
|
||||
return {
|
||||
on_complete => undef,
|
||||
on_fail => undef,
|
||||
on_retry => undef,
|
||||
on_status => undef,
|
||||
on_exception => undef,
|
||||
retry_count => $self->{retry_count},
|
||||
high_priority => $self->{high_priority},
|
||||
#timeout => $self->{timeout_secs}
|
||||
};
|
||||
}
|
||||
|
||||
sub _wait_thread {
|
||||
|
||||
my $context = shift;
|
||||
#my $tid = threadid();
|
||||
#${$context->{proxy}->{tid_ref}} = $tid;
|
||||
my $proxy = $context->{proxy};
|
||||
#$proxy->{create_tid} = undef;
|
||||
$proxy->{wait_tid} = threadid();
|
||||
$proxy->{tid} = $proxy->{wait_tid};
|
||||
servicedebug($proxy,'wait thread tid ' . $proxy->{tid} . ' started',$logger);
|
||||
my $async_running_ref = $proxy->{async_running_ref};
|
||||
|
||||
my $task_opts = $proxy->_get_task_opts();
|
||||
$task_opts->{on_complete} = sub { $proxy->_on_complete(@_); };
|
||||
$task_opts->{on_fail} = sub { $proxy->_on_fail(@_); };
|
||||
$task_opts->{on_retry} = sub { $proxy->_on_retry(@_); };
|
||||
$task_opts->{on_status} = sub { $proxy->_on_status(@_); };
|
||||
$task_opts->{on_exception} = sub { $proxy->_on_exception(@_); };
|
||||
|
||||
$proxy->{client} = Gearman::Client->new(( job_servers => \@jobservers,
|
||||
prefix => $jobnamespace,
|
||||
exceptions => 1));
|
||||
|
||||
my $task = Gearman::Task->new($proxy->{function}, $proxy->{arg}, $task_opts);
|
||||
if ($proxy->{timeout_secs} > 0) {
|
||||
$task->timeout($proxy->{timeout_secs});
|
||||
}
|
||||
#$proxy->{task} = $task;
|
||||
|
||||
my $task_set = $proxy->{client}->new_task_set();
|
||||
#$proxy->{taskset} = $task_set;
|
||||
$task_set->add_task($task);
|
||||
|
||||
local $SIG{'KILL'} = sub {
|
||||
servicedebug($proxy,'kill signal received, exiting wait thread tid ' . $proxy->{tid} . ' ...',$logger);
|
||||
#{
|
||||
# lock $async_running_ref;
|
||||
# $$async_running_ref = 0;
|
||||
#}
|
||||
threads->exit();
|
||||
|
||||
};
|
||||
|
||||
servicedebug($proxy,'start waiting (do_async) ...',$logger);
|
||||
$task_set->wait(timeout => $task->timeout);
|
||||
#return wantarray ? @{$self->{ret}} : $self->{ret}->[0];
|
||||
{
|
||||
lock $async_running_ref;
|
||||
$$async_running_ref = 0;
|
||||
}
|
||||
|
||||
servicedebug($proxy,'shutting down wait thread tid ' . $proxy->{tid} . ' ...',$logger);
|
||||
#threads->exit();
|
||||
}
|
||||
|
||||
sub do {
|
||||
my $self = shift;
|
||||
my ($function_name,$on_error,@args) = @_;
|
||||
|
||||
if ($self->_check_async_running($on_error,'do \'' . $function_name . '\' failed because do_async \'' . $self->{function} . '\' is waiting',0)) {
|
||||
return undef;
|
||||
}
|
||||
|
||||
$self->{function} = $function_name;
|
||||
$self->{ret} = undef;
|
||||
$self->{exception} = undef;
|
||||
|
||||
#$self->{taskset} = undef;
|
||||
#$self->{task} = undef;
|
||||
#$self->{thread} = undef;
|
||||
#$self->{wait_tid} = undef;
|
||||
#$self->{queue} = undef;
|
||||
|
||||
$self->{on_error} = $on_error;
|
||||
$self->{on_complete} = undef;
|
||||
$self->{on_fail} = undef;
|
||||
$self->{on_status} = undef;
|
||||
|
||||
my $arg = serialize(\@args,$self->{serialization_format});
|
||||
$self->{arg} = \$arg;
|
||||
|
||||
my $task_opts = $self->_get_task_opts();
|
||||
$task_opts->{on_complete} = sub { $self->_on_complete(@_); };
|
||||
$task_opts->{on_fail} = sub { $self->_on_fail(@_); };
|
||||
$task_opts->{on_retry} = sub { $self->_on_retry(@_); };
|
||||
$task_opts->{on_status} = sub { $self->_on_status(@_); };
|
||||
$task_opts->{on_exception} = sub { $self->_on_exception(@_); };
|
||||
|
||||
$self->{client} = Gearman::Client->new(( job_servers => \@jobservers,
|
||||
prefix => $jobnamespace,
|
||||
exceptions => 1));
|
||||
|
||||
my $task = Gearman::Task->new($function_name, \$arg, $task_opts);
|
||||
#$self->{task} = $task;
|
||||
if ($self->{timeout_secs} > 0) {
|
||||
$task->timeout($self->{timeout_secs});
|
||||
}
|
||||
|
||||
my $task_set = $self->{client}->new_task_set();
|
||||
#$self->{taskset} = $task_set;
|
||||
$task_set->add_task($task);
|
||||
|
||||
servicedebug($self,'start waiting do \'' . $function_name . '\', args length: ' . length(encode_utf8($arg)),$logger);
|
||||
$task_set->wait(timeout => $task->timeout);
|
||||
return wantarray ? @{$self->{ret}} : $self->{ret}->[0];
|
||||
|
||||
}
|
||||
|
||||
sub _enqueue_event {
|
||||
my $self = shift;
|
||||
my ($event,$args) = @_;
|
||||
my $packet = {event => $event,
|
||||
args => $args};
|
||||
$self->{queue}->enqueue($packet);
|
||||
servicedebug($self,'event ' . $event . ' enqueued, ' . $self->{queue}->pending() . ' event(s) pending',$logger);
|
||||
}
|
||||
|
||||
sub _on_complete {
|
||||
my $self = shift;
|
||||
my $result_ref = shift;
|
||||
if ($self->_is_wait_thread()) {
|
||||
$self->_enqueue_event('_on_complete',[$result_ref]);
|
||||
} elsif ($self->_is_create_thread()) {
|
||||
my $result = $$result_ref;
|
||||
$self->{ret} = deserialize($result,$self->{serialization_format});
|
||||
servicedebug($self,'on_complete event received, result length: ' . length(encode_utf8($result)),$logger);
|
||||
if (defined $self->{on_complete} and ref $self->{on_complete} eq 'CODE') {
|
||||
&{$self->{on_complete}}(@{$self->{ret}});
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
sub _on_fail {
|
||||
my $self = shift;
|
||||
if ($self->_is_wait_thread()) {
|
||||
$self->_enqueue_event('_on_fail');
|
||||
} elsif ($self->_is_create_thread()) {
|
||||
servicedebug($self,'on_fail event received',$logger);
|
||||
if (defined $self->{on_fail} and ref $self->{on_fail} eq 'CODE') {
|
||||
&{$self->{on_fail}}();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _on_retry {
|
||||
my $self = shift;
|
||||
if ($self->_is_wait_thread()) {
|
||||
$self->_enqueue_event('_on_retry');
|
||||
} elsif ($self->_is_create_thread()) {
|
||||
servicedebug($self,'on_retry event received',$logger);
|
||||
if (defined $self->{on_retry} and ref $self->{on_retry} eq 'CODE') {
|
||||
&{$self->{on_retry}}();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _on_status {
|
||||
my $self = shift;
|
||||
my ($numerator, $denominator) = @_;
|
||||
if ($self->_is_wait_thread()) {
|
||||
$self->_enqueue_event('_on_status',[$numerator, $denominator]);
|
||||
} elsif ($self->_is_create_thread()) {
|
||||
servicedebug($self,'on_status event received: ' . $numerator . '/' . $denominator,$logger);
|
||||
if (defined $self->{on_status} and ref $self->{on_status} eq 'CODE') {
|
||||
&{$self->{on_status}}($numerator, $denominator);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _on_exception {
|
||||
my $self = shift;
|
||||
my $exception = shift;
|
||||
$self->{exception} = $exception;
|
||||
if ($self->_is_wait_thread()) {
|
||||
$self->_enqueue_event('_on_exception',[$exception]);
|
||||
#${$self->{async_running_ref}} = 0;
|
||||
} elsif ($self->_is_create_thread()) {
|
||||
if (defined $self->{on_error} and ref $self->{on_error} eq 'CODE') {
|
||||
servicedebug($self,'on_exception event received: ' . $exception,$logger);
|
||||
&{$self->{on_error}}($exception);
|
||||
} else {
|
||||
servicewarn($self,'on_exception event received: ' . $exception,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _check_async_running {
|
||||
my $self = shift;
|
||||
my ($on_error,$message,$async_running) = @_;
|
||||
if ($self->_is_create_thread()) {
|
||||
my $async_running_ref = $self->{async_running_ref};
|
||||
lock $async_running_ref;
|
||||
if ($$async_running_ref) {
|
||||
if (defined $on_error and ref $on_error eq 'CODE') {
|
||||
servicedebug($self,$message,$logger);
|
||||
&$on_error($message);
|
||||
} elsif (length($message) > 0) {
|
||||
servicewarn($self,$message,$logger);
|
||||
}
|
||||
return 1;
|
||||
} elsif ($async_running) {
|
||||
$$async_running_ref = 1;
|
||||
}
|
||||
#} else {
|
||||
# servicewarn($self,$message,$logger);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _get_stop_wait_thread {
|
||||
my $self = shift;
|
||||
my $timeout_secs = shift;
|
||||
my $async_running;
|
||||
{
|
||||
my $async_running_ref = $self->{async_running_ref};
|
||||
lock $async_running_ref;
|
||||
$async_running = $$async_running_ref;
|
||||
}
|
||||
if ((not $async_running and $self->{queue}->pending() == 0) or (defined $timeout_secs and $timeout_secs <= 0)) {
|
||||
servicedebug($self,'stop waiting now (' .
|
||||
($async_running ? 'wait thread running' : 'wait thread not running') .', '.
|
||||
$self->{queue}->pending() . ' event(s) queued, ' .
|
||||
((defined $timeout_secs) ? 'timeout in ' . sprintf('%.1f',$timeout_secs) . 'secs' : 'no timeout') . ')'
|
||||
,$logger);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub wait {
|
||||
my $self = shift;
|
||||
my $timeout_secs = shift;
|
||||
if ($self->_is_create_thread()) { #$self->_check_async_running()) {
|
||||
while (not $self->_get_stop_wait_thread($timeout_secs)) {
|
||||
my $packet = $self->{queue}->dequeue_nb();
|
||||
if (defined $packet) {
|
||||
my $event = $packet->{event};
|
||||
servicedebug($self,'event ' . $event . ' dequeued, ' . $self->{queue}->pending() . ' event(s) pending',$logger);
|
||||
$self->$event(@{$packet->{args}});
|
||||
yield();
|
||||
} else {
|
||||
if (defined $timeout_secs) {
|
||||
$timeout_secs -= $poll_interval_secs;
|
||||
}
|
||||
sleep $poll_interval_secs;
|
||||
}
|
||||
}
|
||||
my $killtread = 0;
|
||||
{
|
||||
my $async_running_ref = $self->{async_running_ref};
|
||||
lock $async_running_ref;
|
||||
$killtread = ($$async_running_ref and (defined $timeout_secs and $timeout_secs <= 0));
|
||||
if ($killtread) {
|
||||
servicedebug($self,'wait timeout exceeded (' . sprintf('%.1f',$timeout_secs) . '), killing wait thread ...',$logger);
|
||||
$self->{thread}->kill('KILL')->detach();
|
||||
$$async_running_ref = 0;
|
||||
}
|
||||
}
|
||||
if (not $killtread) {
|
||||
$self->{thread}->join();
|
||||
servicedebug($self,'wait thread joined',$logger);
|
||||
}
|
||||
##if ($self->{thread}) {
|
||||
# if ($killtread) {
|
||||
# servicedebug($self,'killing thread XX',$logger);
|
||||
# $self->{thread}->kill('KILL')->detach();
|
||||
# } else {
|
||||
# $self->{thread}->join();
|
||||
# servicedebug($self,'thread joined',$logger);
|
||||
# }
|
||||
##}
|
||||
$self->{queue} = undef;
|
||||
$self->{thread} = undef;
|
||||
$self->{wait_tid} = undef;
|
||||
|
||||
#if ($killtread) {
|
||||
# #servicedebug($self,'killing thread XX',$logger);
|
||||
# #$self->{thread}->kill('KILL')->detach();
|
||||
#} else {
|
||||
# $self->{thread}->join();
|
||||
# servicedebug($self,'thread joined',$logger);
|
||||
#}
|
||||
#$self->{queue} = undef;
|
||||
#$self->{thread} = undef;
|
||||
##$self->{wait_tid} = undef;
|
||||
#}
|
||||
#} else {
|
||||
# print "INGORE WAIT??????????\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
|
||||
my $self = shift;
|
||||
if ($self->_is_create_thread()) {
|
||||
servicedebug($self,'destroying proxy ...',$logger);
|
||||
if ($self->{block_destroy}) {
|
||||
$self->wait($self->{timeout_secs} > 0 ? $self->{timeout_secs} : undef);
|
||||
} else {
|
||||
$self->_check_async_running(undef,'do_async \'' . $self->{function} . '\' is still waiting');
|
||||
}
|
||||
servicedebug($self,'proxy destroyed',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
sub _is_wait_thread {
|
||||
my $self = shift;
|
||||
return (defined $self->{wait_tid} and $self->{wait_tid} == threadid());
|
||||
}
|
||||
|
||||
sub _is_create_thread {
|
||||
my $self = shift;
|
||||
return $self->{create_tid} == threadid();
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,872 @@
|
||||
package SqlConnector;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use threads;
|
||||
use threads::shared;
|
||||
|
||||
use Globals qw($enablemultithreading);
|
||||
|
||||
use Logging qw(
|
||||
getlogger
|
||||
dbdebug
|
||||
dbinfo);
|
||||
use LogError qw(
|
||||
dberror
|
||||
dbwarn
|
||||
notimplementederror
|
||||
sortconfigerror);
|
||||
|
||||
use DBI;
|
||||
|
||||
use Utils qw(threadid);
|
||||
use Array qw(arrayeq);
|
||||
use RandomString qw(createtmpstring);
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_tableidentifier);
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $temptable_randomstringlength = 4;
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
my $self = bless {}, $class;
|
||||
my $instanceid = shift;
|
||||
my $cluster = shift;
|
||||
|
||||
$self->{drh} = undef;
|
||||
$self->{dbh} = undef;
|
||||
|
||||
$self->{instanceid} = $instanceid;
|
||||
$self->{tid} = threadid();
|
||||
|
||||
$self->{sth} = undef;
|
||||
$self->{query} = undef;
|
||||
$self->{params} = undef;
|
||||
|
||||
$self->{temp_tables} = [];
|
||||
|
||||
$self->{cluster} = $cluster;
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _gettemptablename {
|
||||
my $self = shift;
|
||||
my $temp_tablename = 'TMP_TBL_' . $self->{tid} . '_';
|
||||
if (length($self->{instanceid}) > 0) {
|
||||
$temp_tablename .= $self->{instanceid} . '_';
|
||||
}
|
||||
$temp_tablename .= createtmpstring($temptable_randomstringlength); #$self->{temp_table_count};
|
||||
return $temp_tablename;
|
||||
}
|
||||
|
||||
sub instanceidentifier {
|
||||
my $self = shift;
|
||||
|
||||
$self->{instanceid} = shift if @_;
|
||||
return $self->{instanceid};
|
||||
|
||||
}
|
||||
|
||||
sub cluster {
|
||||
my $self = shift;
|
||||
$self->{cluster} = shift if @_;
|
||||
return $self->{cluster};
|
||||
}
|
||||
|
||||
sub _connectidentifier {
|
||||
|
||||
my $self = shift;
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return undef;
|
||||
|
||||
}
|
||||
|
||||
sub connectidentifier {
|
||||
my $self = shift;
|
||||
my $cluster = $self->{cluster};
|
||||
if (defined $cluster) {
|
||||
return $cluster->{name};
|
||||
} else {
|
||||
$self->_connectidentifier();
|
||||
}
|
||||
}
|
||||
|
||||
sub tableidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
my (@params) = @_;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return undef;
|
||||
|
||||
}
|
||||
|
||||
sub columnidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $columnname = shift;
|
||||
my (@params) = @_;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return undef;
|
||||
|
||||
}
|
||||
|
||||
sub get_tableidentifier {
|
||||
|
||||
my ($tablename,@params) = @_;
|
||||
|
||||
notimplementederror(__PACKAGE__ . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return undef;
|
||||
|
||||
}
|
||||
|
||||
sub getsafetablename {
|
||||
|
||||
# make a table name (identifier) string save for use within create table statements
|
||||
# of this rdbms connector.
|
||||
my $self = shift;
|
||||
my ($tableidentifier) = @_; #shift;
|
||||
$tableidentifier =~ s/[^0-9a-z_]/_/gi;
|
||||
return $tableidentifier;
|
||||
|
||||
}
|
||||
|
||||
sub _extract_indexcols {
|
||||
|
||||
my $self = shift;
|
||||
my $indexcols = shift;
|
||||
if (defined $indexcols and ref $indexcols eq 'ARRAY') {
|
||||
my @blankcols = map { local $_ = $_; s/\s*\(\d+\).*$//g; $_; } @$indexcols;
|
||||
return \@blankcols;
|
||||
} else {
|
||||
return [];
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub vacuum {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub paginate_sort_query {
|
||||
my $self = shift;
|
||||
my $statement = shift;
|
||||
my $offset = shift;
|
||||
my $limit = shift;
|
||||
my $sortingconfigurations = shift;
|
||||
|
||||
my $orderby = $self->_orderby_columns($sortingconfigurations);
|
||||
if (length($orderby) > 0) {
|
||||
$statement .= ' ORDER BY ' . $orderby;
|
||||
}
|
||||
if (defined $offset and defined $limit) {
|
||||
$statement .= ' LIMIT ' . $offset . ', ' . $limit;
|
||||
}
|
||||
return $statement;
|
||||
|
||||
}
|
||||
|
||||
sub _force_numeric_column {
|
||||
my $self = shift;
|
||||
my $column = shift;
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
}
|
||||
|
||||
sub _orderby_columns {
|
||||
|
||||
my $self = shift;
|
||||
my $sortingconfigurations = shift;
|
||||
|
||||
my @orderby = ();
|
||||
if (defined $sortingconfigurations) {
|
||||
foreach my $sc (@$sortingconfigurations) {
|
||||
if (defined $sc and ref $sc eq 'HASH') {
|
||||
my $columnname = ((exists $sc->{memberchain}) ? $sc->{memberchain} : $sc->{column});
|
||||
if (ref $columnname eq 'ARRAY') {
|
||||
$columnname = $columnname->[0];
|
||||
}
|
||||
if (length($columnname) > 0) {
|
||||
$columnname = $self->columnidentifier($columnname);
|
||||
my $orderby_column;
|
||||
if ($sc->{numeric}) {
|
||||
$orderby_column = $self->_force_numeric_column($columnname);
|
||||
} else {
|
||||
$orderby_column = $columnname;
|
||||
}
|
||||
if (!defined $sc->{dir} or $sc->{dir} > 0) {
|
||||
$orderby_column .= ' ASC';
|
||||
} else {
|
||||
$orderby_column .= ' DESC';
|
||||
}
|
||||
push(@orderby,$orderby_column);
|
||||
} else {
|
||||
sortconfigerror(undef,'sort column required',$logger);
|
||||
}
|
||||
} else {
|
||||
sortconfigerror(undef,'invalid sorting configuration',$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
return join(', ',@orderby);
|
||||
|
||||
}
|
||||
|
||||
sub getdatabases {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return [];
|
||||
|
||||
}
|
||||
|
||||
sub _createdatabase {
|
||||
|
||||
my $self = shift;
|
||||
my ($databasename) = @_;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return [];
|
||||
|
||||
}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my (@params) = @_;
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
$self->_db_disconnect();
|
||||
}
|
||||
|
||||
# child class will do the connect stuff...
|
||||
|
||||
}
|
||||
|
||||
sub db_disconnect {
|
||||
my $self = shift;
|
||||
#my $tid = threadid();
|
||||
my $cluster = $self->{cluster};
|
||||
if (defined $cluster) {
|
||||
dbdebug($self,'disconnecting database cluster ' . $cluster->{name},$logger);
|
||||
foreach my $node (@{$cluster->{nodes}}) {
|
||||
if ($node->{active}) {
|
||||
my $node_db = &{$node->{get_db}}($self->{instanceid},0);
|
||||
$node_db->_db_disconnect();
|
||||
}
|
||||
}
|
||||
#$cluster->{scheduling_vars} = {};
|
||||
} else {
|
||||
$self->_db_disconnect();
|
||||
}
|
||||
}
|
||||
|
||||
sub _db_disconnect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
# since this is also called from DESTROY, no die() here!
|
||||
|
||||
$self->db_finish();
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
#cleartableinfo($self);
|
||||
#dbdebug($self,'disconnecting' . ((defined $self->{cluster}) ? ' ' . $self->_connectidentifier() : ''),$logger);
|
||||
dbdebug($self,'disconnecting',$logger);
|
||||
|
||||
foreach my $temp_tablename (@{$self->{temp_tables}}) {
|
||||
#if ($self->table_exists($temp_tablename)) {
|
||||
$self->drop_table($temp_tablename);
|
||||
#}
|
||||
}
|
||||
$self->{temp_tables} = [];
|
||||
|
||||
$self->{dbh}->disconnect() or dbwarn($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger);
|
||||
$self->{dbh} = undef;
|
||||
|
||||
dbinfo($self,'disconnected',$logger);
|
||||
#dbinfo($self,((defined $self->{cluster}) ? $self->_connectidentifier() . ' ' : '') . 'disconnected',$logger);
|
||||
|
||||
}
|
||||
|
||||
# further disconect code follows in child classes....
|
||||
|
||||
}
|
||||
|
||||
sub is_connected {
|
||||
|
||||
my $self = shift;
|
||||
return (defined $self->{dbh});
|
||||
|
||||
}
|
||||
|
||||
sub getfieldnames {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return [];
|
||||
|
||||
}
|
||||
|
||||
sub getprimarykeycols {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return [];
|
||||
|
||||
}
|
||||
|
||||
sub create_temptable {
|
||||
|
||||
my $self = shift;
|
||||
my $select_stmt = shift;
|
||||
my $indexes = shift;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return '';
|
||||
|
||||
}
|
||||
|
||||
sub create_primarykey {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$keycols,$fieldnames) = @_;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return 0;
|
||||
|
||||
}
|
||||
sub create_indexes {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$indexes,$keycols) = @_;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub create_texttable {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub truncate_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub table_exists {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub _prepare_error {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
dberror($self,"failed to prepare:\n" . $query . "\nDBI error:\n" . $self->{dbh}->errstr(),$logger);
|
||||
|
||||
}
|
||||
|
||||
sub _execute_error {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $sth = shift;
|
||||
my $errstr;
|
||||
if (defined $sth) {
|
||||
$errstr = $sth->errstr();
|
||||
} else {
|
||||
$errstr = $self->{dbh}->errstr();
|
||||
}
|
||||
dberror($self,"failed to execute:\n" . $query . "\nparameters:\n". join(', ', @_) . "\nDBI error:\n" . $errstr,$logger);
|
||||
|
||||
}
|
||||
sub _fetch_error {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $sth = shift;
|
||||
my $operation = shift;
|
||||
my $index = shift;
|
||||
my $errstr;
|
||||
if (defined $sth) {
|
||||
$errstr = $sth->errstr();
|
||||
} else {
|
||||
$errstr = $self->{dbh}->errstr();
|
||||
}
|
||||
dberror($self,'failed with ' . $operation . ":\n" . $query . "\n" . ((defined $index) ? 'column index: ' . $index . "\n" : '') . "parameters:\n". join(', ', @_) . "\nDBI error:\n" . $errstr,$logger);
|
||||
|
||||
}
|
||||
|
||||
# This method executes a SQL query that doesn't return any data. The
|
||||
# query may contain placeholders, that will be replaced by the elements
|
||||
# in @params during execute(). The method will die if any error occurs
|
||||
# and return whatever DBI's execute() returned.
|
||||
sub db_do {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
|
||||
my $result = 0;
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
dbdebug($self,'db_do: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$result = $sth->execute(@_) or $self->_execute_error($query,$sth,@_);
|
||||
}
|
||||
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
# get the first value of the first row of data that is returned from the
|
||||
# database. Returns undef if no data is found.
|
||||
sub db_get_value {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
|
||||
my $row = undef;
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
dbdebug($self,'db_get_value: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$sth->execute(@_) or $self->_execute_error($query,$sth,@_);
|
||||
|
||||
$row = $sth->fetchrow_arrayref();
|
||||
$self->_fetch_error($query,$sth,'fetchrow_arrayref',undef,@_) if !defined $row and $sth->err();
|
||||
$sth->finish();
|
||||
|
||||
}
|
||||
|
||||
return ((defined $row) ? $$row[0] : undef);
|
||||
|
||||
}
|
||||
|
||||
# get a reference to the first row of data that is returned from the database.
|
||||
# (I.e. whatever is returned by DBI's fetchrow_hashref().)
|
||||
sub db_get_row {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
|
||||
my $row = [];
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
dbdebug($self,'db_get_row: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$sth->execute(@_) or $self->_execute_error($query,$sth,@_);
|
||||
|
||||
$row = $sth->fetchrow_hashref();
|
||||
$self->_fetch_error($query,$sth,'fetchrow_hashref',undef,@_) if !defined $row and $sth->err();
|
||||
$sth->finish();
|
||||
|
||||
}
|
||||
|
||||
return $row;
|
||||
|
||||
}
|
||||
|
||||
# get a reference to an array containing the first value of every data row that
|
||||
# is returned from the database like DBI's selectcol_arrayref() does.
|
||||
sub db_get_col {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
|
||||
my $col = [];
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
dbdebug($self,'db_get_col: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
|
||||
$col = $self->{dbh}->selectcol_arrayref($sth, undef, @_);
|
||||
#die "Failed to selectcol_arrayref:\n$query\nDBI error:". $sth->errstr() if !defined $col and $sth->err();
|
||||
$self->_fetch_error($query,$sth,'selectcol_arrayref',undef,@_) if !defined $col and $sth->err();
|
||||
$sth->finish();
|
||||
|
||||
}
|
||||
|
||||
return $col;
|
||||
|
||||
}
|
||||
|
||||
# get all data that is returned from the database. (I.e. a reference to an
|
||||
# array containing entries returned by DBI's fetchrow_hashref().)
|
||||
sub db_get_all_arrayref {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
|
||||
my @rows = ();
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
dbdebug($self,'db_get_all_arrayref: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$sth->execute(@_) or $self->_execute_error($query,$sth,@_);
|
||||
|
||||
while (my $row = $sth->fetchrow_hashref()) {
|
||||
$self->_fetch_error($query,$sth,'fetchrow_hashref',undef,@_) if $sth->err();
|
||||
push @rows, $row;
|
||||
}
|
||||
$sth->finish();
|
||||
|
||||
}
|
||||
|
||||
return \@rows;
|
||||
|
||||
}
|
||||
|
||||
# get a reference to a hash containing a hashreference for each row, like DBI's
|
||||
# fetchall_hashref() does.
|
||||
sub db_get_all_hashref {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $index = shift;
|
||||
|
||||
my $result = {};
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
dbdebug($self,'db_get_all_hashref: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$sth->execute(@_) or $self->_execute_error($query,$sth,@_);
|
||||
|
||||
$result = $sth->fetchall_hashref($index);
|
||||
$self->_fetch_error($query,$sth,'fetchall_hashref',$index,@_) if $sth->err();
|
||||
$sth->finish();
|
||||
|
||||
}
|
||||
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
# get a reference to a hash that is composed of the key_column as keys and the
|
||||
# value_column as values.
|
||||
sub db_get_mapref {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $index = shift;
|
||||
my $value = shift;
|
||||
|
||||
my $result = {};
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
dbdebug($self,'db_get_mapref: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$sth->execute(@_) or $self->_execute_error($query,$sth,@_);
|
||||
|
||||
my $rows = $sth->fetchall_hashref($index);
|
||||
#die "Failed to fetchall_hashref:\n$query\nDBI error:". $sth->errstr() if $sth->err();
|
||||
$self->_fetch_error($query,$sth,'fetchall_hashref',$index,@_) if $sth->err();
|
||||
|
||||
foreach my $key (keys %$rows) {
|
||||
$result->{$key} = $$rows{$key}{$value};
|
||||
}
|
||||
$sth->finish();
|
||||
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
sub db_begin {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{dbh}) {
|
||||
dbdebug($self,'db_begin',$logger);
|
||||
$self->{dbh}->begin_work() or dberror($self, "failed with begin_transaction \nDBI error:\n" . $self->{dbh}->errstr(),$logger);
|
||||
|
||||
if ($self->{dbh}->{AutoCommit}) {
|
||||
dbwarn($self,'autocommit was not disabled',$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_commit {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{dbh}) {
|
||||
dbdebug($self,'db_commit',$logger);
|
||||
#komodo workaround:
|
||||
my @wa = $self->{dbh}->commit() or dberror($self, "failed to commit changes\nDBI error:\n" . $self->{dbh}->errstr(),$logger); #remove dberror for debugging
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_rollback {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{dbh}) {
|
||||
dbdebug($self,'db_rollback',$logger);
|
||||
$self->{dbh}->rollback() or dberror($self, "failed to rollback changes\nDBI error:\n" . $self->{dbh}->errstr(),$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_quote {
|
||||
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
|
||||
my $result = $value;
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
$result = $self->{dbh}->quote($value) or dberror($self, "failed to quote value\nDBI error:\n" . $self->{dbh}->errstr(),$logger);
|
||||
}
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
# perl threads works like a fork, each thread owns a shalow? copy
|
||||
# of the entire current context, at the moment it starts.
|
||||
# due to this, if the thread is finished, perl gc will invoke destructors
|
||||
# on the thread's scope elements, that potentially contains connectors from
|
||||
# the main tread. it will actually attempt destroy them (disconect, etc.)
|
||||
# this is a problem with destructors that change object state like this one
|
||||
#
|
||||
# to avoid this, we perform destruction tasks only if the destructing tid
|
||||
# is the same as the creating one:
|
||||
|
||||
if ($self->{tid} == threadid()) {
|
||||
$self->_db_disconnect();
|
||||
delete $self->{drh};
|
||||
dbdebug($self,(ref $self) . ' connector destroyed',$logger);
|
||||
#} else {
|
||||
# print "NOT destroyed\n";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub lock_tables {
|
||||
|
||||
my $self = shift;
|
||||
my $tablestolock = shift;
|
||||
|
||||
$self->db_begin();
|
||||
|
||||
}
|
||||
|
||||
sub unlock_tables {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->db_commit();
|
||||
|
||||
}
|
||||
|
||||
sub db_do_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
my $lock = shift;
|
||||
|
||||
#notimplementederror('db_do_begin',$logger);
|
||||
|
||||
if (defined $self->{dbh} and not defined $self->{sth} and length($tablename) > 0) {
|
||||
|
||||
if ($lock) {
|
||||
$self->lock_tables({ $tablename => 'WRITE' });
|
||||
}
|
||||
|
||||
dbdebug($self,'db_do_begin: ' . $query,$logger);
|
||||
$self->{sth} = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$self->{query} = $query;
|
||||
$self->{params} = [];
|
||||
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
sub db_do_rowblock {
|
||||
|
||||
my $self = shift;
|
||||
my $rows = shift;
|
||||
|
||||
#notimplementederror('db_do_rowblock',$logger);
|
||||
|
||||
if (defined $self->{dbh} and defined $self->{sth} and defined $rows and ref $rows eq 'ARRAY') {
|
||||
|
||||
#dberror($self,'test error',$logger);
|
||||
#mysqldbdebug($self,"db_do_rowblock\nrows:\n" . (scalar @$rows),$logger);
|
||||
#mysqldbdebug($self,'db_do_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
foreach my $row (@$rows) {
|
||||
dbdebug($self,'db_do_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @$row),$logger);
|
||||
$self->{sth}->execute(@$row) or $self->_execute_error($self->{query},$self->{sth},@$row);
|
||||
$self->{params} = $row;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_get_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
my $lock = shift;
|
||||
|
||||
if (defined $self->{dbh} and not defined $self->{sth} and length($tablename) > 0) {
|
||||
|
||||
#eval { $self->lock_tables({ $tablename => 'WRITE' }); };
|
||||
if ($lock) {
|
||||
$self->lock_tables({ $tablename => 'WRITE' });
|
||||
}
|
||||
|
||||
dbdebug($self,'db_get_begin: ' . $query . "\nparameters:\n" . join(', ', @_),$logger);
|
||||
$self->{sth} = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$self->{sth}->execute(@_) or $self->_execute_error($query,$self->{sth},@_);
|
||||
$self->{query} = $query;
|
||||
$self->{params} = \@_;
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub multithreading_supported {
|
||||
|
||||
my $self = shift;
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub db_get_rowblock {
|
||||
|
||||
my $self = shift;
|
||||
my $max_rows = shift;
|
||||
|
||||
if ($enablemultithreading) {
|
||||
|
||||
#my $rows : shared = [];
|
||||
my @rows :shared = ();
|
||||
#my $rows = &share([]); # beware of '&' here!!!!
|
||||
#my $rows = shared_clone({});
|
||||
|
||||
if (defined $self->{dbh} and defined $self->{sth}) {
|
||||
|
||||
dbdebug($self,'db_get_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @{$self->{params}}),$logger);
|
||||
|
||||
foreach (@{$self->{sth}->fetchall_arrayref(undef, $max_rows)}) {
|
||||
my @row : shared = @{$_};
|
||||
push @rows, \@row;
|
||||
}
|
||||
|
||||
|
||||
$self->_fetch_error($self->{query},$self->{sth},'db_get_rowblock',undef,@{$self->{params}}) if $self->{sth}->err();
|
||||
|
||||
}
|
||||
|
||||
#share(@rows);
|
||||
return \@rows;
|
||||
#return $rows;
|
||||
#return \@rows;
|
||||
|
||||
} else {
|
||||
|
||||
my $rows = [];
|
||||
|
||||
if (defined $self->{dbh} and defined $self->{sth}) {
|
||||
|
||||
dbdebug($self,'db_get_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @{$self->{params}}),$logger);
|
||||
$rows = $self->{sth}->fetchall_arrayref(undef, $max_rows);
|
||||
$self->_fetch_error($self->{query},$self->{sth},'db_get_rowblock',undef,@{$self->{params}}) if $self->{sth}->err();
|
||||
|
||||
}
|
||||
|
||||
return $rows;
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_finish {
|
||||
|
||||
my $self = shift;
|
||||
my $unlock = shift;
|
||||
|
||||
# since this is also called from DESTROY, no die() here!
|
||||
|
||||
if (defined $self->{dbh} and defined $self->{sth}) {
|
||||
|
||||
dbdebug($self,'db_finish',$logger);
|
||||
|
||||
$self->{sth}->finish();
|
||||
$self->{sth} = undef;
|
||||
|
||||
if ($unlock) {
|
||||
$self->unlock_tables();
|
||||
}
|
||||
|
||||
$self->{query} = undef;
|
||||
$self->{params} = undef;
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,833 @@
|
||||
package SqlConnectors::CSVDB;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Globals qw(
|
||||
$LongReadLen_limit
|
||||
$csv_path);
|
||||
|
||||
use Logging qw(
|
||||
getlogger
|
||||
dbdebug
|
||||
dbinfo
|
||||
xls2csvinfo
|
||||
texttablecreated
|
||||
indexcreated
|
||||
tabletruncated
|
||||
tabledropped);
|
||||
|
||||
use LogError qw(
|
||||
dberror
|
||||
dbwarn
|
||||
fieldnamesdiffer
|
||||
fileerror
|
||||
filewarn
|
||||
xls2csverror
|
||||
xls2csvwarn);
|
||||
|
||||
use Array qw(contains setcontains);
|
||||
|
||||
use Utils qw(makedir changemod chopstring);
|
||||
|
||||
use SqlConnector;
|
||||
|
||||
use DBI;
|
||||
use DBD::CSV 0.26;
|
||||
use File::Path qw(remove_tree);
|
||||
use Locale::Recode;
|
||||
use Spreadsheet::ParseExcel;
|
||||
use Spreadsheet::ParseExcel::FmtUnicode;
|
||||
use Excel::Reader::XLSX;
|
||||
use Text::CSV_XS;
|
||||
use File::Basename;
|
||||
use MIME::Parser;
|
||||
use HTML::PullParser qw();
|
||||
use HTML::Entities qw(decode_entities);
|
||||
use IO::Uncompress::Unzip qw(unzip $UnzipError);
|
||||
|
||||
use DateTime::Format::Excel;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlConnector);
|
||||
our @EXPORT_OK = qw(
|
||||
cleanupcvsdirs
|
||||
xlsbin2csv
|
||||
xlsxbin2csv
|
||||
sanitize_column_name
|
||||
sanitize_spreadsheet_name
|
||||
excel_to_timestamp
|
||||
excel_to_date
|
||||
get_tableidentifier
|
||||
$csvextension);
|
||||
|
||||
our $csvextension = '.csv';
|
||||
|
||||
my $default_csv_config = { eol => "\r\n",
|
||||
sep_char => ';',
|
||||
quote_char => '"',
|
||||
escape_char => '"',
|
||||
};
|
||||
|
||||
my @TABLE_TAGS = qw(table tr td);
|
||||
|
||||
my $LongReadLen = $LongReadLen_limit; #bytes
|
||||
my $LongTruncOk = 0;
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $lock_do_chunk = 0;
|
||||
my $lock_get_chunk = 0;
|
||||
|
||||
my $invalid_excel_spreadsheet_chars_pattern = '[' . quotemeta('[]:*?/\\') . ']';
|
||||
|
||||
sub sanitize_spreadsheet_name { #Invalid character []:*?/\ in worksheet name
|
||||
my $spreadsheet_name = shift;
|
||||
$spreadsheet_name =~ s/$invalid_excel_spreadsheet_chars_pattern//g;
|
||||
return chopstring($spreadsheet_name,31); #Sheetname eventually inconsistent etc. must be <= 31 chars
|
||||
}
|
||||
|
||||
sub sanitize_column_name {
|
||||
my $column_name = shift;
|
||||
$column_name =~ s/\W/_/g;
|
||||
return $column_name;
|
||||
}
|
||||
|
||||
sub excel_to_date {
|
||||
my $excel_date_value = shift;
|
||||
if ($excel_date_value > 0) {
|
||||
my $datetime = DateTime::Format::Excel->parse_datetime($excel_date_value);
|
||||
return $datetime->ymd('-'); # prints 1992-02-28
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub excel_to_timestamp {
|
||||
my $excel_datetime_value = shift;
|
||||
if ($excel_datetime_value > 0) {
|
||||
my $datetime = DateTime::Format::Excel->parse_datetime($excel_datetime_value);
|
||||
return $datetime->ymd('-') . ' ' . $datetime->hms(':');
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
|
||||
my $self = SqlConnector->new(@_);
|
||||
|
||||
$self->{db_dir} = undef;
|
||||
$self->{f_dir} = undef;
|
||||
$self->{csv_tables} = undef;
|
||||
$self->{files} = undef;
|
||||
|
||||
$self->{drh} = DBI->install_driver('CSV');
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
dbdebug($self,__PACKAGE__ . ' connector created',$logger);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _connectidentifier {
|
||||
|
||||
my $self = shift;
|
||||
return $self->{f_dir};
|
||||
|
||||
}
|
||||
|
||||
sub tableidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $tablename;
|
||||
|
||||
}
|
||||
|
||||
sub columnidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $columnname = shift;
|
||||
|
||||
return sanitize_column_name($columnname); #actually happens automatically by dbd::csv
|
||||
|
||||
}
|
||||
|
||||
sub get_tableidentifier {
|
||||
|
||||
my ($tablename,$db_dir) = @_;
|
||||
if (defined $db_dir) {
|
||||
return $db_dir . '.' . $tablename;
|
||||
} else {
|
||||
return $tablename;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getsafetablename {
|
||||
|
||||
my $self = shift;
|
||||
my $tableidentifier = shift;
|
||||
return lc($self->SUPER::getsafetablename($tableidentifier));
|
||||
|
||||
}
|
||||
|
||||
sub getdatabases {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
local *DBDIR;
|
||||
if (not opendir(DBDIR, $csv_path)) {
|
||||
fileerror('cannot opendir ' . $csv_path . ': ' . $!,$logger);
|
||||
return [];
|
||||
}
|
||||
my @dirs = grep { $_ ne '.' && $_ ne '..' && -d $csv_path . $_ } readdir(DBDIR);
|
||||
closedir DBDIR;
|
||||
my @databases = ();
|
||||
foreach my $dir (@dirs) {
|
||||
push @databases,$dir;
|
||||
}
|
||||
return \@databases;
|
||||
|
||||
}
|
||||
|
||||
sub _createdatabase {
|
||||
|
||||
my $self = shift;
|
||||
my ($db_dir) = @_;
|
||||
|
||||
my $f_dir; # = _get_f_dir($db_dir);
|
||||
if (length($db_dir) > 0) {
|
||||
$f_dir = $csv_path . $db_dir . '/';
|
||||
} else {
|
||||
$f_dir = $csv_path;
|
||||
}
|
||||
|
||||
dbinfo($self,'opening csv folder',$logger);
|
||||
|
||||
#mkdir $f_dir;
|
||||
makedir($f_dir);
|
||||
|
||||
local *DBDIR;
|
||||
if (not opendir(DBDIR, $f_dir)) {
|
||||
fileerror('cannot opendir ' . $f_dir . ': ' . $!,$logger);
|
||||
return;
|
||||
}
|
||||
closedir DBDIR;
|
||||
|
||||
changemod($f_dir);
|
||||
|
||||
return $f_dir;
|
||||
}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my ($db_dir,$csv_tables) = @_;
|
||||
|
||||
$self->SUPER::db_connect($db_dir,$csv_tables);
|
||||
|
||||
$self->{db_dir} = $db_dir;
|
||||
$self->{csv_tables} = $csv_tables;
|
||||
$self->{f_dir} = $self->_createdatabase($db_dir);
|
||||
|
||||
my $dbh_config = {
|
||||
f_schema => undef,
|
||||
#f_lock => 0, n/a in 0.26 yet?
|
||||
cvs_eol => $default_csv_config->{eol},
|
||||
cvs_sep_char => $default_csv_config->{sep_char},
|
||||
cvs_quote_char => $default_csv_config->{quote_char},
|
||||
cvs_escape_char => $default_csv_config->{escape_char},
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
};
|
||||
my $usetabledef = 0;
|
||||
if (defined $csv_tables and ref $csv_tables eq 'HASH') {
|
||||
$usetabledef = 1;
|
||||
} else {
|
||||
$dbh_config->{f_dir} = $self->{f_dir};
|
||||
$dbh_config->{f_ext} = $csvextension . '/r';
|
||||
}
|
||||
|
||||
my $dbh = DBI->connect ('dbi:CSV:','','',$dbh_config) or
|
||||
dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger);
|
||||
|
||||
$dbh->{InactiveDestroy} = 1;
|
||||
|
||||
$dbh->{LongReadLen} = $LongReadLen;
|
||||
$dbh->{LongTruncOk} = $LongTruncOk;
|
||||
|
||||
$self->{dbh} = $dbh;
|
||||
|
||||
if ($usetabledef) {
|
||||
my @files = ();
|
||||
foreach my $tablename (keys %$csv_tables) {
|
||||
$dbh->{csv_tables}->{$tablename} = $csv_tables->{$tablename};
|
||||
push @files,$csv_tables->{$tablename}->{file};
|
||||
dbinfo($self,'using ' . $csv_tables->{$tablename}->{file},$logger);
|
||||
}
|
||||
$self->{files} = \@files;
|
||||
} else {
|
||||
my @tablenames = $self->_list_tables();
|
||||
foreach my $tablename (@tablenames) {
|
||||
$dbh->{csv_tables}->{$tablename} = { eol => $default_csv_config->{eol},
|
||||
sep_char => $default_csv_config->{sep_char},
|
||||
quote_char => $default_csv_config->{quote_char},
|
||||
escape_char => $default_csv_config->{escape_char},
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
dbinfo($self,'connected',$logger);
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub _list_tables {
|
||||
my $self = shift;
|
||||
my @table_list;
|
||||
|
||||
eval {
|
||||
@table_list = map { local $_ = $_; s/^\.\///g; $_; } $self->{dbh}->func('list_tables');
|
||||
};
|
||||
if ($@) {
|
||||
my @tables;
|
||||
eval {
|
||||
@tables = $self->{dbh}->func("get_avail_tables") or return;
|
||||
};
|
||||
if ($@) {
|
||||
dberror($self,'error listing csv tables: ' . $@,$logger);
|
||||
} else {
|
||||
foreach my $ref (@tables) {
|
||||
if (defined $ref) {
|
||||
if (ref $ref eq 'ARRAY') {
|
||||
push @table_list, $ref->[2];
|
||||
#} else {
|
||||
# push @table_list, $ref;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return @table_list; #removeduplicates(\@table_list);
|
||||
}
|
||||
|
||||
sub _db_disconnect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->SUPER::_db_disconnect();
|
||||
|
||||
}
|
||||
|
||||
sub vacuum {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
}
|
||||
|
||||
sub cleanupcvsdirs {
|
||||
|
||||
my (@remainingdbdirs) = @_;
|
||||
local *DBDIR;
|
||||
if (not opendir(DBDIR, $csv_path)) {
|
||||
fileerror('cannot opendir ' . $csv_path . ': ' . $!,$logger);
|
||||
return;
|
||||
}
|
||||
my @dirs = grep { $_ ne '.' && $_ ne '..' && -d $csv_path . $_ } readdir(DBDIR);
|
||||
closedir DBDIR;
|
||||
my @remainingdbdirectories = ();
|
||||
foreach my $dirname (@remainingdbdirs) {
|
||||
push @remainingdbdirectories,$csv_path . $dirname . '/';
|
||||
}
|
||||
foreach my $dir (@dirs) {
|
||||
#print $file;
|
||||
my $dirpath = $csv_path . $dir . '/';
|
||||
if (not contains($dirpath,\@remainingdbdirectories)) {
|
||||
if (remove_tree($dirpath) == 0) {
|
||||
filewarn('cannot remove ' . $dirpath . ': ' . $!,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getfieldnames {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
my $fieldnames = [];
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
my $query = 'SELECT * FROM ' . $self->tableidentifier($tablename) . ' LIMIT 1';
|
||||
dbdebug($self,'getfieldnames: ' . $query,$logger);
|
||||
my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query);
|
||||
$sth->execute() or $self->_execute_error($query,$sth,());
|
||||
$fieldnames = $sth->{NAME};
|
||||
$sth->finish();
|
||||
|
||||
}
|
||||
|
||||
return $fieldnames;
|
||||
|
||||
}
|
||||
|
||||
sub getprimarykeycols {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return [];
|
||||
|
||||
}
|
||||
|
||||
sub create_primarykey {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$keycols,$fieldnames) = @_;
|
||||
|
||||
return 0;
|
||||
}
|
||||
sub create_indexes {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$indexes,$keycols) = @_;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _gettablefilename {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $self->{f_dir} . $tablename . $csvextension;
|
||||
|
||||
}
|
||||
|
||||
sub create_texttable {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$fieldnames,$keycols,$indexes,$truncate) = @_;
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
my $created = 0;
|
||||
if ($self->table_exists($tablename) == 0) {
|
||||
|
||||
if (not exists $self->{dbh}->{csv_tables}->{$tablename}) {
|
||||
$self->{dbh}->{csv_tables}->{$tablename} = { eol => $default_csv_config->{eol},
|
||||
sep_char => $default_csv_config->{sep_char},
|
||||
quote_char => $default_csv_config->{quote_char},
|
||||
escape_char => $default_csv_config->{escape_char},
|
||||
};
|
||||
}
|
||||
|
||||
my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' (';
|
||||
$statement .= join(' TEXT, ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$fieldnames) . ' TEXT';
|
||||
$statement .= ')';
|
||||
|
||||
$self->db_do($statement);
|
||||
|
||||
changemod($self->_gettablefilename($tablename));
|
||||
|
||||
texttablecreated($self,$tablename,$logger);
|
||||
|
||||
$created = 1;
|
||||
} else {
|
||||
my $fieldnamesfound = $self->getfieldnames($tablename);
|
||||
if (not setcontains($fieldnames,$fieldnamesfound,1)) {
|
||||
fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $created and $truncate) {
|
||||
$self->truncate_table($tablename);
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub multithreading_supported {
|
||||
|
||||
my $self = shift;
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub truncate_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('DELETE FROM ' . $self->tableidentifier($tablename));
|
||||
tabletruncated($self,$tablename,$logger);
|
||||
|
||||
}
|
||||
|
||||
sub table_exists {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
my @tables = $self->_list_tables();
|
||||
return contains($tablename,\@tables);
|
||||
}
|
||||
|
||||
return undef;
|
||||
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if ($self->table_exists($tablename) > 0) {
|
||||
$self->db_do('DROP TABLE ' . $self->tableidentifier($tablename));
|
||||
delete $self->{dbh}->{csv_tables}->{$tablename};
|
||||
tabledropped($self,$tablename,$logger);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub db_begin {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{dbh}) {
|
||||
dbdebug($self, "transactions not supported",$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_commit {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{dbh}) {
|
||||
dbdebug($self, "transactions not supported",$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_rollback {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{dbh}) {
|
||||
dbdebug($self, "transactions not supported",$logger);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_do_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_get_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_finish {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk);
|
||||
|
||||
}
|
||||
|
||||
sub xlsbin2csv {
|
||||
|
||||
my ($inputfile,$outputfile,$worksheetname,$sourcecharset) = @_;
|
||||
|
||||
return _convert_xlsbin2csv($inputfile,
|
||||
$worksheetname,
|
||||
$sourcecharset,
|
||||
$outputfile,
|
||||
'UTF-8',
|
||||
$default_csv_config->{quote_char},
|
||||
$default_csv_config->{escape_char},
|
||||
$default_csv_config->{sep_char},
|
||||
$default_csv_config->{eol});
|
||||
|
||||
}
|
||||
|
||||
sub _convert_xlsbin2csv {
|
||||
|
||||
my ($SourceFilename,$worksheet,$SourceCharset,$DestFilename,$DestCharset,$quote_char,$escape_char,$sep_char,$eol) = @_;
|
||||
|
||||
my $csvlinecount = 0;
|
||||
|
||||
xls2csvinfo('start converting ' . $SourceFilename . ' (worksheet ' . $worksheet . ') to ' . $DestFilename . ' ...',$logger);
|
||||
|
||||
$SourceCharset = 'UTF-8' unless $SourceCharset;
|
||||
$DestCharset = $SourceCharset unless $DestCharset;
|
||||
|
||||
xls2csvinfo('reading ' . $SourceFilename . ' as ' . $SourceCharset,$logger);
|
||||
|
||||
my $XLS = new IO::File;
|
||||
if (not $XLS->open('<' . $SourceFilename)) {
|
||||
fileerror('cannot open file ' . $SourceFilename . ': ' . $!,$logger);
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $Formatter = Spreadsheet::ParseExcel::FmtUnicode->new(Unicode_Map => $SourceCharset);
|
||||
|
||||
my $parser = Spreadsheet::ParseExcel->new();
|
||||
my $Book = $parser->parse($XLS,$Formatter); #$SourceFilename
|
||||
|
||||
if ( !defined $Book ) {
|
||||
xls2csverror($parser->error(),$logger);
|
||||
#die $parser->error(), ".\n";
|
||||
$XLS->close();
|
||||
return 0;
|
||||
}
|
||||
|
||||
#my $Book = Spreadsheet::ParseExcel::Workbook->Parse($XLS, $Formatter) or xls2csverror('can\'t read spreadsheet',$logger);
|
||||
|
||||
my $Sheet;
|
||||
if ($worksheet) {
|
||||
|
||||
#my $test = $Book->GetContent();
|
||||
|
||||
$Sheet = $Book->Worksheet($worksheet);
|
||||
if (not defined $Sheet) {
|
||||
xls2csverror('invalid spreadsheet',$logger);
|
||||
return 0;
|
||||
}
|
||||
#unless ($O{'q'})
|
||||
#{
|
||||
# print qq|Converting the "$Sheet->{Name}" worksheet.\n|;
|
||||
#}
|
||||
xls2csvinfo('converting the ' . $Sheet->{Name} . ' worksheet',$logger);
|
||||
} else {
|
||||
($Sheet) = @{$Book->{Worksheet}};
|
||||
if ($Book->{SheetCount}>1) {
|
||||
#print qq|Multiple worksheets found. Will convert the "$Sheet->{Name}" worksheet.\n|;
|
||||
xls2csvinfo('multiple worksheets found, converting ' . $Sheet->{Name},$logger);
|
||||
}
|
||||
}
|
||||
|
||||
unlink $DestFilename;
|
||||
local *CSV;
|
||||
if (not open(CSV,'>' . $DestFilename)) {
|
||||
fileerror('cannot open file ' . $DestFilename . ': ' . $!,$logger);
|
||||
$XLS->close();
|
||||
return 0;
|
||||
}
|
||||
binmode CSV;
|
||||
|
||||
my $Csv = Text::CSV_XS->new({
|
||||
'quote_char' => $quote_char,
|
||||
'escape_char' => $escape_char,
|
||||
'sep_char' => $sep_char,
|
||||
'binary' => 1,
|
||||
});
|
||||
|
||||
my $Recoder;
|
||||
if ($DestCharset) {
|
||||
$Recoder = Locale::Recode->new(from => $SourceCharset, to => $DestCharset);
|
||||
}
|
||||
|
||||
for (my $Row = $Sheet->{MinRow}; defined $Sheet->{MaxRow} && $Row <= $Sheet->{MaxRow}; $Row++) {
|
||||
my @Row;
|
||||
for (my $Col = $Sheet->{MinCol}; defined $Sheet->{MaxCol} && $Col <= $Sheet->{MaxCol}; $Col++) {
|
||||
my $Cell = $Sheet->{Cells}[$Row][$Col];
|
||||
|
||||
my $Value = "";
|
||||
if ($Cell) {
|
||||
$Value = $Cell->Value;
|
||||
if ($Value eq 'GENERAL') {
|
||||
# Sometimes numbers are read incorrectly as "GENERAL".
|
||||
# In this case, the correct value should be in ->{Val}.
|
||||
$Value = $Cell->{Val};
|
||||
}
|
||||
if ($DestCharset) {
|
||||
$Recoder->recode($Value);
|
||||
}
|
||||
}
|
||||
|
||||
# We assume the line is blank if there is nothing in the first column.
|
||||
last if $Col == $Sheet->{MinCol} and !$Value;
|
||||
|
||||
push(@Row,$Value);
|
||||
}
|
||||
|
||||
next unless @Row;
|
||||
|
||||
my $Status = $Csv->combine(@Row);
|
||||
|
||||
if (!defined $Status) {
|
||||
xls2csvwarn('csv error: ' . $Csv->error_input(),$logger);
|
||||
}
|
||||
|
||||
if (defined $Status) {
|
||||
print CSV $Csv->string();
|
||||
if ($Row < $Sheet->{MaxRow}) {
|
||||
print CSV $eol;
|
||||
}
|
||||
$csvlinecount++;
|
||||
}
|
||||
}
|
||||
|
||||
close CSV;
|
||||
$XLS->close;
|
||||
|
||||
xls2csvinfo($csvlinecount . ' line(s) converted',$logger);
|
||||
|
||||
return $csvlinecount;
|
||||
|
||||
}
|
||||
|
||||
sub xlsxbin2csv {
|
||||
|
||||
my ($inputfile,$outputfile,$worksheetname) = @_;
|
||||
|
||||
return _convert_xlsxbin2csv($inputfile,
|
||||
$worksheetname,
|
||||
$outputfile,
|
||||
'UTF-8',
|
||||
$default_csv_config->{quote_char},
|
||||
$default_csv_config->{escape_char},
|
||||
$default_csv_config->{sep_char},
|
||||
$default_csv_config->{eol});
|
||||
|
||||
}
|
||||
|
||||
sub _convert_xlsxbin2csv {
|
||||
my ($SourceFilename,$worksheet,$DestFilename,$DestCharset,$quote_char,$escape_char,$sep_char,$eol) = @_;
|
||||
|
||||
my $csvlinecount = 0;
|
||||
|
||||
xls2csvinfo('start converting ' . $SourceFilename . ' (worksheet ' . $worksheet . ') to ' . $DestFilename . ' ...',$logger);
|
||||
|
||||
|
||||
my $XLS = new IO::File;
|
||||
if (not $XLS->open('<' . $SourceFilename)) {
|
||||
fileerror('cannot open file ' . $SourceFilename . ': ' . $!,$logger);
|
||||
return 0;
|
||||
} else {
|
||||
$XLS->close();
|
||||
}
|
||||
|
||||
#my $Formatter = Spreadsheet::ParseExcel::FmtUnicode->new(Unicode_Map => $SourceCharset);
|
||||
|
||||
my $reader = Excel::Reader::XLSX->new();
|
||||
my $workbook = $reader->read_file($SourceFilename); #->parse($XLS,$Formatter); #$SourceFilename
|
||||
|
||||
my $SourceCharset = $workbook->{_reader}->encoding();
|
||||
$DestCharset = $SourceCharset unless $DestCharset;
|
||||
|
||||
xls2csvinfo('reading ' . $SourceFilename . ' as ' . $SourceCharset,$logger);
|
||||
|
||||
if ( !defined $workbook ) {
|
||||
xls2csverror($reader->error(),$logger);
|
||||
#die $parser->error(), ".\n";
|
||||
#$XLS->close();
|
||||
return 0;
|
||||
}
|
||||
|
||||
#my $Book = Spreadsheet::ParseExcel::Workbook->Parse($XLS, $Formatter) or xls2csverror('can\'t read spreadsheet',$logger);
|
||||
|
||||
my $sheet;
|
||||
if ($worksheet) {
|
||||
|
||||
#my $test = $Book->GetContent();
|
||||
|
||||
$sheet = $workbook->worksheet($worksheet);
|
||||
if (not defined $sheet) {
|
||||
xls2csverror('invalid spreadsheet',$logger);
|
||||
return 0;
|
||||
}
|
||||
#unless ($O{'q'})
|
||||
#{
|
||||
# print qq|Converting the "$Sheet->{Name}" worksheet.\n|;
|
||||
#}
|
||||
xls2csvinfo('converting the ' . $sheet->name() . ' worksheet',$logger);
|
||||
} else {
|
||||
$sheet = $workbook->worksheet(0);
|
||||
if (@{$workbook->worksheets()} > 1) {
|
||||
#print qq|Multiple worksheets found. Will convert the "$Sheet->{Name}" worksheet.\n|;
|
||||
xls2csvinfo('multiple worksheets found, converting ' . $sheet->name(),$logger);
|
||||
}
|
||||
}
|
||||
|
||||
unlink $DestFilename;
|
||||
local *CSV;
|
||||
if (not open(CSV,'>' . $DestFilename)) {
|
||||
fileerror('cannot open file ' . $DestFilename . ': ' . $!,$logger);
|
||||
#$XLS->close();
|
||||
return 0;
|
||||
}
|
||||
binmode CSV;
|
||||
|
||||
my $csv = Text::CSV_XS->new({
|
||||
'quote_char' => $quote_char,
|
||||
'escape_char' => $escape_char,
|
||||
'sep_char' => $sep_char,
|
||||
'binary' => 1,
|
||||
});
|
||||
|
||||
my $Recoder;
|
||||
if ($DestCharset) {
|
||||
$Recoder = Locale::Recode->new(from => $SourceCharset, to => $DestCharset);
|
||||
}
|
||||
|
||||
while ( my $row = $sheet->next_row() ) {
|
||||
|
||||
foreach my $value ($row->values()) {
|
||||
$Recoder->recode($value);
|
||||
}
|
||||
|
||||
my $status = $csv->combine($row->values());
|
||||
|
||||
if (!defined $status) {
|
||||
xls2csvwarn('csv error: ' . $csv->error_input(),$logger);
|
||||
}
|
||||
|
||||
if (defined $status) {
|
||||
if ($row->row_number() > 0) {
|
||||
print CSV $eol;
|
||||
}
|
||||
print CSV $csv->string();
|
||||
$csvlinecount++;
|
||||
}
|
||||
}
|
||||
|
||||
close CSV;
|
||||
#$XLS->close;
|
||||
|
||||
xls2csvinfo($csvlinecount . ' line(s) converted',$logger);
|
||||
|
||||
return $csvlinecount;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,534 @@
|
||||
package SqlConnectors::MySQLDB;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Globals qw($LongReadLen_limit);
|
||||
use Logging qw(
|
||||
getlogger
|
||||
dbinfo
|
||||
dbdebug
|
||||
texttablecreated
|
||||
temptablecreated
|
||||
indexcreated
|
||||
primarykeycreated
|
||||
tabletruncated
|
||||
tabledropped);
|
||||
use LogError qw(dberror fieldnamesdiffer);
|
||||
|
||||
use DBI;
|
||||
use DBD::mysql 4.014;
|
||||
|
||||
use Array qw(arrayeq itemcount contains setcontains);
|
||||
|
||||
use SqlConnector;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlConnector);
|
||||
our @EXPORT_OK = qw(get_tableidentifier);
|
||||
|
||||
my $defaulthost = '127.0.0.1';
|
||||
my $defaultport = '3306';
|
||||
my $defaultusername = 'root';
|
||||
my $defaultpassword = '';
|
||||
my $defaultdatabasename = 'test';
|
||||
|
||||
my $varcharsize = 256;
|
||||
|
||||
my $texttable_charset = 'latin1';
|
||||
my $texttable_collation = 'latin1_swedish_ci';
|
||||
my $default_texttable_engine = 'MyISAM'; #InnoDB'; # ... provide transactions y/n?
|
||||
|
||||
my $session_charset = 'latin1';
|
||||
|
||||
my $LongReadLen = $LongReadLen_limit; #bytes
|
||||
my $LongTruncOk = 0;
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $lock_do_chunk = 1;
|
||||
my $lock_get_chunk = 0;
|
||||
|
||||
my $serialization_level = ''; #'SERIALIZABLE'
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
|
||||
my $self = SqlConnector->new(@_);
|
||||
|
||||
$self->{host} = undef;
|
||||
$self->{port} = undef;
|
||||
$self->{databasename} = undef;
|
||||
$self->{username} = undef;
|
||||
$self->{password} = undef;
|
||||
|
||||
$self->{drh} = DBI->install_driver('mysql');
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
dbdebug($self,__PACKAGE__ . ' connector created',$logger);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _connectidentifier {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{databasename}) {
|
||||
return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '.' . $self->{databasename};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tableidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if (defined $self->{databasename}) {
|
||||
return '`' . $self->{databasename} . '`.`' . $tablename . '`';
|
||||
} else {
|
||||
return '`' . $tablename . '`';
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub columnidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $columnname = shift;
|
||||
|
||||
return '`' . $columnname . '`';
|
||||
|
||||
}
|
||||
|
||||
sub get_tableidentifier {
|
||||
|
||||
my ($tablename,$databasename) = @_;
|
||||
|
||||
if (defined $databasename) {
|
||||
return $databasename . '.' . $tablename;
|
||||
} else {
|
||||
return $tablename;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getsafetablename {
|
||||
|
||||
my $self = shift;
|
||||
my $tableidentifier = shift;
|
||||
|
||||
return lc($self->SUPER::getsafetablename($tableidentifier));
|
||||
|
||||
}
|
||||
|
||||
sub _force_numeric_column {
|
||||
my $self = shift;
|
||||
my $column = shift;
|
||||
return '(' . $column . ' + 0.0)';
|
||||
}
|
||||
|
||||
sub getdatabases {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my @dbs = $self->{drh}->func($self->{host},
|
||||
$self->{port},
|
||||
$self->{username},
|
||||
$self->{password},
|
||||
'_ListDBs') or
|
||||
dberror($self,'error listing databases: ' . $self->{drh}->errstr(),$logger);
|
||||
|
||||
return \@dbs;
|
||||
|
||||
}
|
||||
|
||||
sub _createdatabase {
|
||||
|
||||
my $self = shift;
|
||||
my ($databasename) = @_;
|
||||
|
||||
if ($self->{drh}->func('createdb',
|
||||
$databasename,
|
||||
'host=' . $self->{host} . ';port=' . $self->{port},
|
||||
$self->{username},
|
||||
$self->{password},
|
||||
'admin')) {
|
||||
dbinfo($self,'database \'' . $databasename . '\' created',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my ($databasename,$username,$password,$host,$port) = @_;
|
||||
|
||||
$self->SUPER::db_connect($databasename,$username,$password,$host,$port);
|
||||
|
||||
$host = $defaulthost if (not $host);
|
||||
$port = $defaultport if (not $port);
|
||||
$databasename = $defaultdatabasename if (not $databasename);
|
||||
$username = $defaultusername if (not $username);
|
||||
$password = $defaultpassword if (not $password);
|
||||
|
||||
$self->{host} = $host;
|
||||
$self->{port} = $port;
|
||||
$self->{databasename} = $databasename;
|
||||
$self->{username} = $username;
|
||||
$self->{password} = $password;
|
||||
|
||||
if (not contains($databasename,$self->getdatabases(),0)) {
|
||||
$self->_createdatabase($databasename);
|
||||
}
|
||||
|
||||
dbdebug($self,'connecting',$logger);
|
||||
|
||||
my $dbh = DBI->connect(
|
||||
'dbi:mysql:database=' . $databasename . ';host=' . $host . ';port=' . $port,$username,$password,
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
AutoCommit => 1,
|
||||
#AutoCommit => 0,
|
||||
}
|
||||
) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger);
|
||||
|
||||
$dbh->{InactiveDestroy} = 1;
|
||||
|
||||
$dbh->{LongReadLen} = $LongReadLen;
|
||||
$dbh->{LongTruncOk} = $LongTruncOk;
|
||||
|
||||
$self->{dbh} = $dbh;
|
||||
|
||||
my $server_version = substr($self->db_get_all_hashref('SHOW VARIABLES LIKE \'version\'','Variable_name')->{version}->{Value},0,2);
|
||||
if ($server_version ge '4.1') {
|
||||
# $self->db_do('SET SESSION character_set_client = \'utf8\'');
|
||||
# $self->db_do('SET SESSION character_set_connection = \'utf8\'');
|
||||
# $self->db_do('SET SESSION character_set_results = \'utf8\'');
|
||||
$self->db_do('SET CHARACTER SET ' . $session_charset . '');
|
||||
dbdebug($self,'session charset ' . $session_charset . ' applied',$logger);
|
||||
} else {
|
||||
# $self->db_do('SET SESSION CHARACTER SET = \'utf8\'');
|
||||
#$self->db_do('SET SESSION CHARACTER SET = \'latin1\'');
|
||||
|
||||
#$self->db_do('SET SESSION CHARACTER SET \'cp1251_koi8\''); # the only valid if convert.cc on server is not modified
|
||||
}
|
||||
|
||||
|
||||
#$self->db_do('SET character_set_client = \'utf8\'');
|
||||
#$self->db_do('SET character_set_connection = \'utf8\'');
|
||||
#$self->db_do('SET character_set_results = \'utf8\'');
|
||||
#$self->db_do('SET SESSION NAMES = \'utf8\'');
|
||||
#$self->db_do('SET character_set_connection = \'utf8\'');
|
||||
#$self->db_do('SET character_set_results = \'utf8\'');
|
||||
|
||||
#$self->db_do('SET SESSION date_format = \'%Y-%m-%d\'');
|
||||
#$self->db_do('SET SESSION time_format = \'%H:%i:%s\'');
|
||||
#$self->db_do('SET SESSION time_zone = \'Europe/Paris\'');
|
||||
#$self->db_do('SET SESSION datetime_format = \'%Y-%m-%d %H:%i:%s\'');
|
||||
|
||||
if (length($serialization_level) > 0) {
|
||||
$self->db_do('SET SESSION TRANSACTION ISOLATION LEVEL ' . $serialization_level);
|
||||
}
|
||||
|
||||
dbinfo($self,'connected',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub vacuum {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('OPTIMIZE TABLE ' . $self->tableidentifier($tablename));
|
||||
|
||||
}
|
||||
|
||||
sub _db_disconnect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->SUPER::_db_disconnect();
|
||||
|
||||
}
|
||||
|
||||
sub getfieldnames {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $self->db_get_col('SHOW FIELDS FROM ' . $self->tableidentifier($tablename));
|
||||
|
||||
}
|
||||
|
||||
sub getprimarykeycols {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
my $fieldinfo = $self->db_get_all_hashref('SHOW FIELDS FROM ' . $self->tableidentifier($tablename),'Field');
|
||||
my @keycols = ();
|
||||
foreach my $fieldname (keys %$fieldinfo) {
|
||||
if (uc($fieldinfo->{$fieldname}->{'Key'}) eq 'PRI') {
|
||||
push @keycols,$fieldname;
|
||||
}
|
||||
}
|
||||
return \@keycols;
|
||||
|
||||
}
|
||||
|
||||
sub create_temptable {
|
||||
|
||||
my $self = shift;
|
||||
my $select_stmt = shift;
|
||||
my $indexes = shift;
|
||||
|
||||
my $index_tablename = $self->_gettemptablename();
|
||||
my $temp_tablename = $self->tableidentifier($index_tablename);
|
||||
|
||||
$self->db_do('CREATE TEMPORARY TABLE ' . $temp_tablename . ' AS ' . $select_stmt);
|
||||
temptablecreated($self,$index_tablename,$logger);
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
#my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
#if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
my $temptable_indexname = lc($index_tablename) . '_' . $indexname;
|
||||
$self->db_do('CREATE INDEX ' . $temptable_indexname . ' ON ' . $temp_tablename . ' (' . join(', ', map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @{$indexes->{$indexname}}) . ')');
|
||||
indexcreated($self,$index_tablename,$indexname,$logger);
|
||||
#}
|
||||
}
|
||||
}
|
||||
|
||||
return $temp_tablename;
|
||||
|
||||
}
|
||||
|
||||
sub create_primarykey {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$keycols,$fieldnames) = @_;
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @$keycols) . ')';
|
||||
$self->db_do($statement);
|
||||
primarykeycreated($self,$tablename,$keycols,$logger);
|
||||
return 1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub create_indexes {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$indexes,$keycols) = @_;
|
||||
|
||||
my $index_count = 0;
|
||||
if (length($tablename) > 0) {
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
if (not arrayeq($self->_extract_indexcols($indexes->{$indexname}),$keycols,1)) {
|
||||
my $statement = 'CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @{$indexes->{$indexname}}) . ')';
|
||||
$self->db_do($statement);
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
$index_count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return $index_count;
|
||||
}
|
||||
|
||||
sub create_texttable {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes,$texttable_engine) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
#my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
my $created = 0;
|
||||
if ($self->table_exists($tablename) == 0) {
|
||||
my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' (';
|
||||
#$statement .= join(' TEXT, ',@$fieldnames) . ' TEXT';
|
||||
|
||||
my @fieldspecs = ();
|
||||
foreach my $fieldname (@$fieldnames) {
|
||||
if (contains($fieldname,$keycols,1)) {
|
||||
push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(' . $varcharsize . ')';
|
||||
#$statement .= $fieldname . ' VARCHAR(256)';
|
||||
} else {
|
||||
push @fieldspecs,$self->columnidentifier($fieldname) . ' TEXT';
|
||||
#$statement .= $fieldname . ' TEXT';
|
||||
}
|
||||
}
|
||||
$statement .= join(', ',@fieldspecs);
|
||||
|
||||
|
||||
#if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
$statement .= ', PRIMARY KEY (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @$keycols) . ')';
|
||||
}
|
||||
if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
if (not arrayeq($self->_extract_indexcols($indexes->{$indexname}),$keycols,1)) {
|
||||
$statement .= ', INDEX ' . $indexname . ' (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @{$indexes->{$indexname}}) . ')';
|
||||
}
|
||||
}
|
||||
}
|
||||
if (length($texttable_engine) == 0) {
|
||||
$texttable_engine = $default_texttable_engine;
|
||||
}
|
||||
$statement .= ') CHARACTER SET ' . $texttable_charset . ', COLLATE ' . $texttable_collation . ', ENGINE ' . $texttable_engine;
|
||||
|
||||
$self->db_do($statement);
|
||||
texttablecreated($self,$tablename . ' (' . $texttable_engine . ')',$logger);
|
||||
$created = 1;
|
||||
} else {
|
||||
my $fieldnamesfound = $self->getfieldnames($tablename);
|
||||
if (not setcontains($fieldnames,$fieldnamesfound,1)) {
|
||||
fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $created and $truncate) {
|
||||
$self->truncate_table($tablename);
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub multithreading_supported {
|
||||
|
||||
my $self = shift;
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub truncate_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('TRUNCATE ' . $self->tableidentifier($tablename));
|
||||
tabletruncated($self,$tablename,$logger);
|
||||
|
||||
}
|
||||
|
||||
sub table_exists {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
# ... again, avoid using mysql's information_schema table,
|
||||
# since its availability is obviously user/version dependent.
|
||||
return itemcount($tablename,$self->db_get_col('SHOW TABLES')); #,1);
|
||||
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if ($self->table_exists($tablename) > 0) {
|
||||
$self->db_do('DROP TABLE ' . $self->tableidentifier($tablename));
|
||||
tabledropped($self,$tablename,$logger);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub lock_tables {
|
||||
|
||||
my $self = shift;
|
||||
my $tablestolock = shift;
|
||||
|
||||
if (defined $self->{dbh} and defined $tablestolock and ref $tablestolock eq 'HASH') {
|
||||
|
||||
my $locks = join(', ',map { local $_ = $_; $_ = $self->tableidentifier($_) . ' ' . $tablestolock->{$_}; $_; } keys %$tablestolock);
|
||||
dbdebug($self,"lock_tables:\n" . $locks,$logger);
|
||||
$self->db_do('LOCK TABLES ' . $locks);
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub unlock_tables {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{dbh}) {
|
||||
|
||||
dbdebug($self,'unlock_tables',$logger);
|
||||
$self->db_do('UNLOCK TABLES');
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_do_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_get_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
#my $lock = shift;
|
||||
|
||||
$self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_finish {
|
||||
|
||||
my $self = shift;
|
||||
#my $unlock = shift;
|
||||
|
||||
$self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk);
|
||||
|
||||
}
|
||||
|
||||
sub _split_indexcol {
|
||||
my $indexcol = shift;
|
||||
if ($indexcol =~ /(.+)(\(\d+\))/g) {
|
||||
return ($1,$2);
|
||||
}
|
||||
return ($indexcol, '');
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,532 @@
|
||||
package SqlConnectors::OracleDB;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Globals qw($LongReadLen_limit);
|
||||
use Logging qw(
|
||||
getlogger
|
||||
dbinfo
|
||||
dbdebug
|
||||
texttablecreated
|
||||
temptablecreated
|
||||
indexcreated
|
||||
primarykeycreated
|
||||
tabletruncated
|
||||
tabledropped);
|
||||
use LogError qw(dberror dbwarn fieldnamesdiffer);
|
||||
|
||||
use DBI;
|
||||
use DBD::Oracle 1.21;
|
||||
|
||||
use Array qw(contains arrayeq setcontains);
|
||||
|
||||
use SqlConnector;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlConnector);
|
||||
our @EXPORT_OK = qw(get_tableidentifier);
|
||||
|
||||
my $defaultport = '1521';
|
||||
|
||||
#$NLS_LANG = 'GERMAN_AUSTRIA.WE8ISO8859P1';
|
||||
|
||||
my $connNLS_LANGUAGE = 'GERMAN';
|
||||
my $connNLS_TERRITORY = 'AUSTRIA';
|
||||
|
||||
#my $connNLS_CHARACTERSET = 'WE8ISO8859P1';
|
||||
|
||||
my $varcharsize = 4000;
|
||||
my $max_identifier_length = 30;
|
||||
|
||||
my $LongReadLen = $LongReadLen_limit; #bytes
|
||||
my $LongTruncOk = 0;
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $lock_do_chunk = 0;
|
||||
my $lock_get_chunk = 0;
|
||||
|
||||
my $isolation_level = ''; #'SERIALIZABLE'
|
||||
|
||||
my $enable_numeric_sorting = 0;
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
|
||||
my $self = SqlConnector->new(@_);
|
||||
|
||||
$self->{host} = undef;
|
||||
$self->{port} = undef;
|
||||
$self->{servicename} = undef;
|
||||
$self->{sid} = undef;
|
||||
$self->{username} = undef;
|
||||
$self->{password} = undef;
|
||||
$self->{schema} = undef;
|
||||
|
||||
$self->{drh} = DBI->install_driver('Oracle');
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
dbdebug($self,__PACKAGE__ . ' connector created',$logger);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _connectidentifier {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{schema}) {
|
||||
if ($self->{servicename}) {
|
||||
return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '/' . $self->{servicename} . '.' . $self->{schema};
|
||||
} elsif ($self->{sid}) {
|
||||
return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '/SID ' . $self->{sid} . '.' . $self->{schema};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
sub tableidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return get_tableidentifier($tablename,$self->{schema});
|
||||
|
||||
}
|
||||
|
||||
sub columnidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $columnname = shift;
|
||||
|
||||
return $columnname;
|
||||
|
||||
}
|
||||
|
||||
sub _chopidentifier {
|
||||
my $identifier = shift;
|
||||
return substr($identifier,0,$max_identifier_length);
|
||||
}
|
||||
|
||||
sub get_tableidentifier {
|
||||
|
||||
my ($tablename,$schema,$servicename,$sid) = @_;
|
||||
my $tableidentifier = $tablename;
|
||||
if (defined $schema) {
|
||||
$tableidentifier = $schema . '.' . $tableidentifier;
|
||||
}
|
||||
if ($servicename) {
|
||||
$tableidentifier = $servicename . '.' . $tableidentifier;
|
||||
} elsif ($sid) {
|
||||
$tableidentifier = $sid . '.' . $tableidentifier;
|
||||
}
|
||||
return $tableidentifier;
|
||||
|
||||
}
|
||||
|
||||
sub getsafetablename {
|
||||
|
||||
my $self = shift;
|
||||
my $tableidentifier = shift;
|
||||
return uc($self->SUPER::getsafetablename($tableidentifier));
|
||||
#if (defined $self->{schema}) {
|
||||
# return $self->{schema} . '.' . $tablename;
|
||||
#} else {
|
||||
# return $tablename;
|
||||
#}
|
||||
|
||||
}
|
||||
|
||||
sub paginate_sort_query {
|
||||
|
||||
my $self = shift;
|
||||
my $statement = shift;
|
||||
my $offset = shift;
|
||||
my $limit = shift;
|
||||
my $sortingconfigurations = shift;
|
||||
|
||||
my $orderby = $self->_orderby_columns($sortingconfigurations);
|
||||
if (length($orderby) > 0) {
|
||||
$statement .= ' ORDER BY ' . $orderby;
|
||||
}
|
||||
if (defined $offset and defined $limit) {
|
||||
$statement = 'SELECT * FROM (SELECT p.*, rownum rnum FROM (' . $statement . ') p WHERE rownum < ' . ($offset + $limit + 1) . ') WHERE rnum >= ' . ($offset + 1);
|
||||
}
|
||||
return $statement;
|
||||
|
||||
}
|
||||
|
||||
sub _force_numeric_column {
|
||||
my $self = shift;
|
||||
my $column = shift;
|
||||
return 'try_to_number(' . $column . ')';
|
||||
}
|
||||
|
||||
sub getdatabases {
|
||||
|
||||
my $self = shift;
|
||||
return $self->db_get_col('SELECT DISTINCT owner FROM all_objects');
|
||||
|
||||
}
|
||||
|
||||
#sub _createdatabase {
|
||||
#
|
||||
# my $self = shift;
|
||||
# my ($schema) = @_;
|
||||
#
|
||||
# #SQL> create tablespace test datafile 'C:\oraclexe\app\oracle\oradata\XE\test.dbf' size 10M autoextend on;
|
||||
# #Tablespace created.
|
||||
# #SQL> create user test identified by test default tablespace test;
|
||||
# #User created.
|
||||
# #alter user test quota unlimited on test
|
||||
#
|
||||
# $self->db_do('CREATE SCHEMA AUTHORIZATION ' . $schema);
|
||||
# dbinfo($self,'schema \'' . $schema . '\' created',$logger);
|
||||
#
|
||||
#}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my ($servicename,$sid,$schema,$username,$password,$host,$port) = @_;
|
||||
|
||||
$self->SUPER::db_connect($servicename,$sid,$schema,$username,$password,$host,$port);
|
||||
|
||||
$port = $defaultport if (not $port);
|
||||
|
||||
$self->{host} = $host;
|
||||
$self->{port} = $port;
|
||||
$self->{servicename} = $servicename;
|
||||
$self->{sid} = $sid;
|
||||
$self->{username} = $username;
|
||||
$self->{password} = $password;
|
||||
$self->{schema} = $schema;
|
||||
|
||||
dbdebug($self,'connecting',$logger);
|
||||
|
||||
my $dbh;
|
||||
if ($servicename) {
|
||||
$dbh = DBI->connect(
|
||||
'dbi:Oracle:host=' . $host . ';service_name=' . $servicename . ';port=' . $port,$username,$password,
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
AutoCommit => 1,
|
||||
#AutoCommit => 0,
|
||||
}
|
||||
) or dberror($self,'error connecting - service name: ' . $self->{drh}->errstr(),$logger);
|
||||
} elsif ($sid) {
|
||||
$dbh = DBI->connect(
|
||||
'dbi:Oracle:host=' . $host . ';sid=' . $sid . ';port=' . $port,$username,$password,
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
AutoCommit => 1,
|
||||
}
|
||||
) or dberror($self,'error connecting - sid: ' . $self->{drh}->errstr(),$logger);
|
||||
} else {
|
||||
dberror($self,'neither service name nor sid specified',$logger);
|
||||
}
|
||||
|
||||
$self->{dbh} = $dbh;
|
||||
|
||||
if (not contains($schema,$self->getdatabases(),0)) {
|
||||
$self->_createdatabase($schema); #notimplemented error...
|
||||
}
|
||||
|
||||
$dbh->{InactiveDestroy} = 1;
|
||||
|
||||
$dbh->{LongReadLen} = $LongReadLen;
|
||||
$dbh->{LongTruncOk} = $LongTruncOk;
|
||||
|
||||
$self->db_do('ALTER SESSION SET NLS_LANGUAGE = \'' . $connNLS_LANGUAGE . '\'');
|
||||
$self->db_do('ALTER SESSION SET NLS_TERRITORY = \'' . $connNLS_TERRITORY . '\'');
|
||||
#$self->db_do('ALTER SESSION SET NLS_CHARACTERSET = \'' . $connNLS_CHARACTERSET . '\'');
|
||||
$self->db_do('ALTER SESSION SET NLS_NUMERIC_CHARACTERS = \'.,\'');
|
||||
$self->db_do('ALTER SESSION SET NLS_DATE_FORMAT = \'YYYY-MM-DD HH24:MI:SS\'');
|
||||
|
||||
if (length($isolation_level) > 0) {
|
||||
$self->db_do('ALTER SESSION SET ISOLATION_LEVEL = ' . $isolation_level);
|
||||
}
|
||||
|
||||
if ($enable_numeric_sorting) {
|
||||
#http://stackoverflow.com/questions/6470819/sql-if-cannot-convert-to-number-set-as-null
|
||||
eval {
|
||||
$self->db_do("CREATE OR REPLACE FUNCTION try_to_number( p_str IN VARCHAR2 )\n" .
|
||||
" RETURN NUMBER\n" .
|
||||
"IS\n" .
|
||||
" l_num NUMBER;\n" .
|
||||
"BEGIN\n" .
|
||||
" BEGIN\n" .
|
||||
" l_num := to_number( p_str );\n" .
|
||||
" EXCEPTION\n" .
|
||||
" WHEN others THEN\n" .
|
||||
" l_num := null;\n" .
|
||||
" END;\n" .
|
||||
" RETURN l_num;\n" .
|
||||
"END;");
|
||||
};
|
||||
if ($@) {
|
||||
dbwarn($self,'numeric sorting not supported',$logger);
|
||||
}
|
||||
} else {
|
||||
dbdebug($self,'numeric sorting not enabled',$logger);
|
||||
}
|
||||
|
||||
dbinfo($self,'connected',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub vacuum {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
}
|
||||
|
||||
sub _db_disconnect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->SUPER::_db_disconnect();
|
||||
|
||||
}
|
||||
|
||||
sub getfieldnames {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $self->db_get_col('SELECT column_name FROM all_tab_columns WHERE CONCAT(CONCAT(owner,\'.\'),table_name) = ?',$self->tableidentifier($tablename));
|
||||
|
||||
}
|
||||
|
||||
sub getprimarykeycols {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $self->db_get_col('SELECT cols.column_name FROM all_constraints cons, all_cons_columns cols WHERE
|
||||
CONCAT(CONCAT(cols.owner,\'.\'),cols.table_name) = ? AND
|
||||
cons.constraint_type = \'P\' AND
|
||||
cons.constraint_name = cols.constraint_name AND
|
||||
cons.owner = cols.owner
|
||||
ORDER BY cols.table_name, cols.position',$self->tableidentifier($tablename));
|
||||
|
||||
}
|
||||
|
||||
sub create_temptable {
|
||||
|
||||
my $self = shift;
|
||||
my $select_stmt = shift;
|
||||
my $indexes = shift;
|
||||
|
||||
my $index_tablename = $self->_gettemptablename();
|
||||
my $temp_tablename = $self->tableidentifier($index_tablename);
|
||||
|
||||
#$self->db_do('CREATE GLOBAL TEMPORARY TABLE ' . $temp_tablename . ' ON COMMIT PRESERVE ROWS AS ' . $select_stmt);
|
||||
$self->db_do('CREATE TABLE ' . $temp_tablename . ' AS ' . $select_stmt);
|
||||
push(@{$self->{temp_tables}},$index_tablename);
|
||||
|
||||
temptablecreated($self,$index_tablename,$logger);
|
||||
|
||||
#$self->{temp_table_count} += 1;
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
#if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$indexname = _chopidentifier(lc($index_tablename) . '_' . $indexname);
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$index_tablename,$indexname,$logger);
|
||||
#}
|
||||
}
|
||||
}
|
||||
|
||||
return $temp_tablename;
|
||||
|
||||
}
|
||||
|
||||
sub create_primarykey {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$keycols,$fieldnames) = @_;
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')';
|
||||
$self->db_do($statement);
|
||||
primarykeycreated($self,$tablename,$keycols,$logger);
|
||||
return 1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub create_indexes {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$indexes,$keycols) = @_;
|
||||
|
||||
my $index_count = 0;
|
||||
if (length($tablename) > 0) {
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$indexname = _chopidentifier($indexname);
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return $index_count;
|
||||
}
|
||||
|
||||
sub create_texttable {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_;
|
||||
#my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
my $created = 0;
|
||||
if ($self->table_exists($tablename) == 0) {
|
||||
my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' (';
|
||||
$statement .= join(' VARCHAR2(' . $varcharsize . '), ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$fieldnames) . ' VARCHAR2(' . $varcharsize . ')';
|
||||
if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
#$statement .= ', CONSTRAINT ' . $tablename . '_pk PRIMARY KEY (' . join(', ',@$keycols) . ')';
|
||||
$statement .= ', CONSTRAINT PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')';
|
||||
}
|
||||
#if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
# foreach my $indexname (keys %$indexes) {
|
||||
# $statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
# }
|
||||
#}
|
||||
$statement .= ')';
|
||||
|
||||
$self->db_do($statement);
|
||||
texttablecreated($self,$tablename,$logger);
|
||||
|
||||
if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$indexname = _chopidentifier($indexname);
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
$created = 1;
|
||||
} else {
|
||||
my $fieldnamesfound = $self->getfieldnames($tablename);
|
||||
if (not setcontains($fieldnames,$fieldnamesfound,1)) {
|
||||
fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $created and $truncate) {
|
||||
$self->truncate_table($tablename);
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub multithreading_supported {
|
||||
|
||||
my $self = shift;
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub truncate_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('TRUNCATE ' . $self->tableidentifier($tablename));
|
||||
tabletruncated($self,$tablename,$logger);
|
||||
|
||||
}
|
||||
|
||||
sub table_exists {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
return $self->db_get_value('SELECT COUNT(*) FROM all_tables WHERE CONCAT(CONCAT(owner,\'.\'),table_name) = ?',$self->tableidentifier($tablename));
|
||||
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if ($self->table_exists($tablename) > 0) {
|
||||
$self->db_do('DROP TABLE ' . $self->tableidentifier($tablename) . ' PURGE'); #CASCADE CONSTRAINTS PURGE');
|
||||
tabledropped($self,$tablename,$logger);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub db_do_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_do_begin($query,$tablename,0,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_get_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_get_begin($query,$tablename,0,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_finish {
|
||||
|
||||
my $self = shift;
|
||||
#my $unlock = shift;
|
||||
|
||||
$self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk);
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,536 @@
|
||||
package SqlConnectors::PostgreSQLDB;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Globals qw($LongReadLen_limit);
|
||||
use Logging qw(
|
||||
getlogger
|
||||
dbinfo
|
||||
dbdebug
|
||||
texttablecreated
|
||||
temptablecreated
|
||||
indexcreated
|
||||
primarykeycreated
|
||||
tabletruncated
|
||||
tabledropped);
|
||||
use LogError qw(dberror dbwarn fieldnamesdiffer);
|
||||
|
||||
use DBI;
|
||||
use DBD::Pg 2.17.2;
|
||||
|
||||
use Array qw(arrayeq itemcount contains setcontains);
|
||||
|
||||
use SqlConnector;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlConnector);
|
||||
our @EXPORT_OK = qw(get_tableidentifier);
|
||||
|
||||
my $defaulthost = '127.0.0.1';
|
||||
my $defaultport = '5432';
|
||||
my $defaultusername = 'postgres';
|
||||
my $defaultpassword = '';
|
||||
my $defaultschemaname = 'template1';
|
||||
|
||||
my $varcharsize = 256;
|
||||
|
||||
my $encoding = 'LATIN1';
|
||||
my $lc_collate = 'C'; #OS locales only
|
||||
my $lc_ctype = 'C';
|
||||
|
||||
my $client_encoding = 'LATIN1';
|
||||
|
||||
#my $LongReadLen = $LongReadLen_limit; #bytes
|
||||
#my $LongTruncOk = 0;
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $lock_do_chunk = 0;
|
||||
my $lock_get_chunk = 0;
|
||||
|
||||
#my $to_number_pattern = '9.9999999999999'; #EEEE';
|
||||
|
||||
my $transaction_isolation_level = ''; #'SERIALIZABLE'
|
||||
|
||||
my $enable_numeric_sorting = 0;
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
|
||||
my $self = SqlConnector->new(@_);
|
||||
|
||||
$self->{host} = undef;
|
||||
$self->{port} = undef;
|
||||
$self->{schemaname} = undef;
|
||||
$self->{username} = undef;
|
||||
$self->{password} = undef;
|
||||
|
||||
$self->{drh} = DBI->install_driver('Pg');
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
dbdebug($self,__PACKAGE__ . ' connector created',$logger);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _connectidentifier {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{schemaname}) {
|
||||
return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '.' . $self->{schemaname};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tableidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $tablename;
|
||||
|
||||
}
|
||||
|
||||
sub columnidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $columnname = shift;
|
||||
|
||||
return $columnname;
|
||||
|
||||
}
|
||||
|
||||
sub get_tableidentifier {
|
||||
|
||||
my ($tablename,$schemaname) = @_;
|
||||
|
||||
#return SUPER::get_tableidentifier($tablename,$schemaname);
|
||||
|
||||
if (defined $schemaname) {
|
||||
return $schemaname . '.' . $tablename;
|
||||
} else {
|
||||
return $tablename;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getsafetablename {
|
||||
|
||||
# make a table name (identifier) string save for use within create table statements
|
||||
# of this rdbms connector.
|
||||
my $self = shift;
|
||||
my $tableidentifier = shift;
|
||||
|
||||
return lc($self->SUPER::getsafetablename($tableidentifier));
|
||||
|
||||
#$tableidentifier =~ s/[^0-9a-z_]/_/gi;
|
||||
#return lc($tableidentifier); # ... windows!
|
||||
|
||||
}
|
||||
|
||||
sub paginate_sort_query {
|
||||
my $self = shift;
|
||||
my $statement = shift;
|
||||
my $offset = shift;
|
||||
my $limit = shift;
|
||||
my $sortingconfigurations = shift;
|
||||
|
||||
my $orderby = $self->_orderby_columns($sortingconfigurations);
|
||||
if (length($orderby) > 0) {
|
||||
$statement .= ' ORDER BY ' . $orderby;
|
||||
}
|
||||
if (defined $offset and defined $limit) {
|
||||
$statement .= ' LIMIT ' . $limit . ' OFFSET ' . $offset;
|
||||
}
|
||||
return $statement;
|
||||
|
||||
}
|
||||
|
||||
sub _force_numeric_column {
|
||||
my $self = shift;
|
||||
my $column = shift;
|
||||
return 'try_to_number(' . $column . '::text)'; # ,\'' . $to_number_pattern . '\')';
|
||||
}
|
||||
|
||||
sub getdatabases {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my $DBI_USER = $ENV{DBI_USER};
|
||||
my $DBI_PASS = $ENV{DBI_PASS};
|
||||
$ENV{DBI_USER} = $self->{username};
|
||||
$ENV{DBI_PASS} = $self->{password};
|
||||
|
||||
my @dbs = $self->{drh}->data_sources('port=' . $self->{port} . ';host=' . $self->{host});
|
||||
|
||||
$DBI_USER = $ENV{DBI_USER};
|
||||
$DBI_PASS = $ENV{DBI_PASS};
|
||||
|
||||
if (scalar @dbs == 0) {
|
||||
dberror($self,'error listing databases: ' . $self->{drh}->errstr(),$logger);
|
||||
} else {
|
||||
@dbs = map { local $_ = $_; $_ =~ s/^dbi:Pg:dbname=[\"\']?([a-zA-Z0-9_-]+)[\"\']?;.+$/$1/gi; $_; } @dbs;
|
||||
}
|
||||
|
||||
return \@dbs;
|
||||
|
||||
}
|
||||
|
||||
sub _createdatabase {
|
||||
|
||||
my $self = shift;
|
||||
my ($schemaname) = @_;
|
||||
|
||||
my $dbh = DBI->connect(
|
||||
'dbi:Pg:database=template1;host=' . $self->{host} . ';port=' . $self->{port},$self->{username},$self->{password},
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
AutoCommit => 1,
|
||||
#AutoCommit => 0,
|
||||
}
|
||||
) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger);
|
||||
$self->{dbh} = $dbh;
|
||||
$self->db_do('CREATE DATABASE ' . $schemaname . ' TEMPLATE template0 ENCODING = ? LC_COLLATE = ? LC_CTYPE = ?', $encoding, $lc_collate, $lc_ctype);
|
||||
dbinfo($self,'database \'' . $schemaname . '\' created',$logger);
|
||||
$self->{dbh}->disconnect() or dberror($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger);
|
||||
$self->{dbh} = undef;
|
||||
}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my ($schemaname,$username,$password,$host,$port) = @_;
|
||||
|
||||
$self->SUPER::db_connect($schemaname,$username,$password,$host,$port);
|
||||
|
||||
$host = $defaulthost if (not $host);
|
||||
$port = $defaultport if (not $port);
|
||||
$schemaname = $defaultschemaname if (not $schemaname);
|
||||
$username = $defaultusername if (not $username);
|
||||
$password = $defaultpassword if (not $password);
|
||||
|
||||
$self->{host} = $host;
|
||||
$self->{port} = $port;
|
||||
$self->{schemaname} = $schemaname;
|
||||
$self->{username} = $username;
|
||||
$self->{password} = $password;
|
||||
|
||||
if (not contains($schemaname,$self->getdatabases(),0)) {
|
||||
$self->_createdatabase($schemaname);
|
||||
}
|
||||
|
||||
dbdebug($self,'connecting',$logger);
|
||||
|
||||
my $dbh = DBI->connect(
|
||||
'dbi:Pg:database=' . $schemaname . ';host=' . $host . ';port=' . $port,$username,$password,
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
AutoCommit => 1,
|
||||
#AutoCommit => 0,
|
||||
}
|
||||
) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger);
|
||||
|
||||
$dbh->{InactiveDestroy} = 1;
|
||||
|
||||
#$dbh->{LongReadLen} = $LongReadLen;
|
||||
#$dbh->{LongTruncOk} = $LongTruncOk;
|
||||
|
||||
$self->{dbh} = $dbh;
|
||||
|
||||
$self->db_do('SET CLIENT_ENCODING TO ?',$client_encoding);
|
||||
|
||||
if (length($transaction_isolation_level) > 0) {
|
||||
$self->db_do('SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL ' . $transaction_isolation_level);
|
||||
}
|
||||
|
||||
#http://stackoverflow.com/questions/2082686/how-do-i-cast-a-string-to-integer-and-have-0-in-case-of-error-in-the-cast-with-p
|
||||
|
||||
if ($enable_numeric_sorting) {
|
||||
eval {
|
||||
$self->db_do("CREATE OR REPLACE FUNCTION try_to_number (v_input text) RETURNS NUMERIC AS\n" .
|
||||
'$$' . "\n" .
|
||||
"DECLARE v_value NUMERIC DEFAULT NULL;\n" .
|
||||
"BEGIN\n" .
|
||||
" BEGIN\n" .
|
||||
" v_value := v_input::NUMERIC;\n" .
|
||||
" EXCEPTION WHEN OTHERS THEN\n" .
|
||||
" RAISE NOTICE 'Invalid integer value: \"%\". Returning NULL.', v_input;\n" .
|
||||
" RETURN NULL;\n" .
|
||||
" END;\n" .
|
||||
" RETURN v_value;\n" .
|
||||
"END;\n" .
|
||||
'$$' . "\n" .
|
||||
"LANGUAGE 'plpgsql';\n");
|
||||
};
|
||||
if ($@) {
|
||||
dbwarn($self,'numeric sorting not supported',$logger);
|
||||
}
|
||||
} else {
|
||||
dbdebug($self,'numeric sorting not enabled',$logger);
|
||||
}
|
||||
|
||||
dbinfo($self,'connected',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub vacuum {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('VACUUM FULL ' . $self->tableidentifier($tablename));
|
||||
|
||||
}
|
||||
|
||||
sub _db_disconnect {
|
||||
|
||||
my $self = shift;
|
||||
##$self->db_finish();
|
||||
#$self->SUPER::db_finish();
|
||||
#
|
||||
#if (defined $self->{dbh}) {
|
||||
# cleartableinfo($self);
|
||||
# mysqldbinfo($self,'mysql db disconnecting',$logger);
|
||||
# $self->{dbh}->disconnect() or mysqldberror($self,'error disconnecting from mysql db',$logger);
|
||||
# $self->{dbh} = undef;
|
||||
#
|
||||
# mysqldbinfo($self,'mysql db disconnected',$logger);
|
||||
#
|
||||
#}
|
||||
|
||||
$self->SUPER::_db_disconnect();
|
||||
|
||||
}
|
||||
|
||||
sub getfieldnames {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
return $self->db_get_col('SELECT attname FROM pg_attribute WHERE attrelid = \'' . $tablename . '\'::regclass AND attnum > 0 AND NOT attisdropped ORDER BY attnum');
|
||||
|
||||
}
|
||||
|
||||
sub getprimarykeycols {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
return $self->db_get_col('SELECT pg_attribute.attname FROM pg_index, pg_class, pg_attribute WHERE pg_class.oid = \'' . $tablename . '\'::regclass AND indrelid = pg_class.oid AND pg_attribute.attrelid = pg_class.oid AND pg_attribute.attnum = any(pg_index.indkey) AND indisprimary');
|
||||
|
||||
}
|
||||
|
||||
sub create_temptable {
|
||||
|
||||
my $self = shift;
|
||||
my $select_stmt = shift;
|
||||
my $indexes = shift;
|
||||
|
||||
my $index_tablename = $self->_gettemptablename();
|
||||
my $temp_tablename = $self->tableidentifier($index_tablename);
|
||||
|
||||
$self->db_do('CREATE TEMPORARY TABLE ' . $temp_tablename . ' AS ' . $select_stmt);
|
||||
temptablecreated($self,$index_tablename,$logger);
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
#if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$indexname = lc($index_tablename) . '_' . $indexname;
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$index_tablename,$indexname,$logger);
|
||||
#}
|
||||
}
|
||||
}
|
||||
|
||||
return $temp_tablename;
|
||||
|
||||
}
|
||||
|
||||
sub create_primarykey {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$keycols,$fieldnames) = @_;
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')';
|
||||
$self->db_do($statement);
|
||||
primarykeycreated($self,$tablename,$keycols,$logger);
|
||||
return 1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub create_indexes {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$indexes,$keycols) = @_;
|
||||
|
||||
my $index_count = 0;
|
||||
if (length($tablename) > 0) {
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return $index_count;
|
||||
}
|
||||
|
||||
sub create_texttable {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
#my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
my $created = 0;
|
||||
if ($self->table_exists($tablename) == 0) {
|
||||
my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' (';
|
||||
#$statement .= join(' TEXT, ',@$fieldnames) . ' TEXT';
|
||||
|
||||
my @fieldspecs = ();
|
||||
foreach my $fieldname (@$fieldnames) {
|
||||
my $fieldnamespec = $self->columnidentifier($fieldname) . ' TEXT';
|
||||
if (not $defer_indexes and contains($fieldname,$keycols,1)) {
|
||||
$fieldnamespec .= ' PRIMARY KEY';
|
||||
}
|
||||
push @fieldspecs,$fieldnamespec;
|
||||
}
|
||||
$statement .= join(', ',@fieldspecs) . ')';
|
||||
$self->db_do($statement);
|
||||
texttablecreated($self,$tablename,$logger);
|
||||
|
||||
if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$created = 1;
|
||||
} else {
|
||||
my $fieldnamesfound = $self->getfieldnames($tablename);
|
||||
if (not setcontains($fieldnames,$fieldnamesfound,1)) {
|
||||
fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $created and $truncate) {
|
||||
$self->truncate_table($tablename);
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
#return $tablename;
|
||||
|
||||
}
|
||||
|
||||
sub multithreading_supported {
|
||||
|
||||
my $self = shift;
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub truncate_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('TRUNCATE ' . $self->tableidentifier($tablename));
|
||||
tabletruncated($self,$tablename,$logger);
|
||||
|
||||
}
|
||||
|
||||
sub table_exists {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
return $self->db_get_value('SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE tablename = ?',$tablename);
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if ($self->table_exists($tablename) > 0) {
|
||||
$self->db_do('DROP TABLE ' . $self->tableidentifier($tablename));
|
||||
tabledropped($self,$tablename,$logger);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub db_do_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_get_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
#my $lock = shift;
|
||||
|
||||
$self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_finish {
|
||||
|
||||
my $self = shift;
|
||||
#my $unlock = shift;
|
||||
|
||||
$self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk);
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,527 @@
|
||||
package SqlConnectors::SQLServerDB;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Globals qw($LongReadLen_limit);
|
||||
use Logging qw(
|
||||
getlogger
|
||||
dbinfo
|
||||
dbdebug
|
||||
texttablecreated
|
||||
temptablecreated
|
||||
indexcreated
|
||||
primarykeycreated
|
||||
tabletruncated
|
||||
tabledropped);
|
||||
use LogError qw(
|
||||
dberror
|
||||
fieldnamesdiffer);
|
||||
|
||||
use DBI;
|
||||
use DBD::ODBC 1.50;
|
||||
|
||||
#https://blog.afoolishmanifesto.com/posts/install-and-configure-the-ms-odbc-driver-on-debian/
|
||||
#http://community.spiceworks.com/how_to/show/78224-install-the-ms-sql-odbc-driver-on-debian-7
|
||||
|
||||
use Array qw(arrayeq itemcount contains setcontains removeduplicates mergearrays);
|
||||
|
||||
use SqlConnector;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlConnector);
|
||||
our @EXPORT_OK = qw(get_tableidentifier);
|
||||
|
||||
my $defaulthost = '127.0.0.1';
|
||||
my $defaultport = '1433';
|
||||
my $defaultusername = 'SA';
|
||||
my $defaultpassword = '';
|
||||
my $defaultdatabasename = 'master';
|
||||
|
||||
my $varcharsize = 900; #8000;
|
||||
|
||||
my $encoding = 'LATIN1';
|
||||
my $collation_name = 'Latin1_General_CI_AS'; #OS locales only
|
||||
my $lc_ctype = 'C';
|
||||
|
||||
my $client_encoding = 'LATIN1';
|
||||
|
||||
my $LongReadLen = $LongReadLen_limit; #bytes
|
||||
my $LongTruncOk = 0;
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $lock_do_chunk = 0;
|
||||
my $lock_get_chunk = 0;
|
||||
|
||||
my $transaction_isolation_level = ''; #'SERIALIZABLE'
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
|
||||
my $self = SqlConnector->new(@_);
|
||||
|
||||
$self->{host} = undef;
|
||||
$self->{port} = undef;
|
||||
$self->{databasename} = undef;
|
||||
$self->{username} = undef;
|
||||
$self->{password} = undef;
|
||||
|
||||
$self->{drh} = DBI->install_driver('ODBC');
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
dbdebug($self,__PACKAGE__ . ' connector created',$logger);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _connectidentifier {
|
||||
|
||||
my $self = shift;
|
||||
if (defined $self->{databasename}) {
|
||||
return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '.' . $self->{databasename};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tableidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $tablename;
|
||||
}
|
||||
|
||||
sub columnidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $columnname = shift;
|
||||
|
||||
return $columnname;
|
||||
|
||||
}
|
||||
|
||||
sub get_tableidentifier {
|
||||
|
||||
my ($tablename,$databasename) = @_;
|
||||
|
||||
if (defined $databasename) {
|
||||
return $databasename . '.' . $tablename;
|
||||
} else {
|
||||
return $tablename;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getsafetablename {
|
||||
|
||||
# make a table name (identifier) string save for use within create table statements
|
||||
# of this rdbms connector.
|
||||
my $self = shift;
|
||||
my $tableidentifier = shift;
|
||||
|
||||
return lc($self->SUPER::getsafetablename($tableidentifier));
|
||||
|
||||
}
|
||||
|
||||
sub paginate_sort_query {
|
||||
my $self = shift;
|
||||
my $statement = shift;
|
||||
my $offset = shift;
|
||||
my $limit = shift;
|
||||
my $sortingconfigurations = shift;
|
||||
|
||||
my $orderby = $self->_orderby_columns($sortingconfigurations);
|
||||
if (defined $offset and defined $limit and length($orderby) > 0) {
|
||||
my ($select_fields_part,$table_whereclause_part) = split /\s+from\s+/i,$statement,2;
|
||||
$select_fields_part =~ s/^\s*select\s+//i;
|
||||
|
||||
return 'SELECT * FROM (SELECT ' . $select_fields_part . ', ROW_NUMBER() OVER (ORDER BY ' . $orderby . ') as row FROM ' . $table_whereclause_part . ') AS p WHERE p.row > ' . $offset . ' AND p.row <= ' . ($offset + $limit);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _force_numeric_column {
|
||||
my $self = shift;
|
||||
my $column = shift;
|
||||
return 'TRY_CONVERT(NUMERIC, ' . $column . ')';
|
||||
}
|
||||
|
||||
sub _dbd_connect {
|
||||
my $self = shift;
|
||||
my $databasename = shift;
|
||||
my $connection_string;
|
||||
if ($^O eq 'MSWin32') {
|
||||
$connection_string = 'DBI:ODBC:Driver={SQL Server};Server=' . $self->{host} . ',' . $self->{port};
|
||||
} else {
|
||||
$connection_string = 'dbi:ODBC:driver=SQL Server Native Client 11.0;server=tcp:' . $self->{host} . ',' . $self->{port}; # . ';database=DB_TOWNE;MARS_Connection=yes;
|
||||
}
|
||||
if (length($databasename) > 0) {
|
||||
$connection_string .= ';database=' . $databasename;
|
||||
}
|
||||
return (DBI->connect($connection_string,$self->{username},$self->{password},
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
AutoCommit => 1,
|
||||
#AutoCommit => 0,
|
||||
}
|
||||
) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger));
|
||||
}
|
||||
|
||||
sub getdatabases {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my $connected_wo_db = 0;
|
||||
if (not defined $self->{dbh}) {
|
||||
$self->{dbh} = $self->_dbd_connect();
|
||||
$connected_wo_db = 1;
|
||||
}
|
||||
my $dbs = $self->db_get_col('SELECT name FROM master..sysdatabases');
|
||||
if ($connected_wo_db) {
|
||||
$self->{dbh}->disconnect() or dberror($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger);
|
||||
$self->{dbh} = undef;
|
||||
}
|
||||
|
||||
return $dbs;
|
||||
|
||||
}
|
||||
|
||||
sub _createdatabase {
|
||||
|
||||
my $self = shift;
|
||||
my ($databasename) = @_;
|
||||
|
||||
$self->{dbh} = $self->_dbd_connect();
|
||||
$self->db_do('CREATE DATABASE ' . $databasename . ' COLLATE ' . $collation_name);
|
||||
dbinfo($self,'database \'' . $databasename . '\' created',$logger);
|
||||
$self->{dbh}->disconnect() or dberror($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger);
|
||||
$self->{dbh} = undef;
|
||||
}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my ($databasename,$username,$password,$host,$port) = @_;
|
||||
|
||||
$self->SUPER::db_connect($databasename,$username,$password,$host,$port);
|
||||
|
||||
#if (defined $self->{dbh}) {
|
||||
# $self->db_disconnect();
|
||||
#}
|
||||
|
||||
$host = $defaulthost if (not $host);
|
||||
$port = $defaultport if (not $port);
|
||||
$databasename = $defaultdatabasename if (not $databasename);
|
||||
$username = $defaultusername if (not $username);
|
||||
$password = $defaultpassword if (not $password);
|
||||
|
||||
$self->{host} = $host;
|
||||
$self->{port} = $port;
|
||||
$self->{databasename} = $databasename;
|
||||
$self->{username} = $username;
|
||||
$self->{password} = $password;
|
||||
|
||||
if (not contains($databasename,$self->getdatabases(),0)) {
|
||||
$self->_createdatabase($databasename);
|
||||
}
|
||||
|
||||
dbdebug($self,'connecting',$logger);
|
||||
|
||||
my $dbh = $self->_dbd_connect($databasename);
|
||||
|
||||
$dbh->{InactiveDestroy} = 1;
|
||||
|
||||
$dbh->{LongReadLen} = $LongReadLen;
|
||||
$dbh->{LongTruncOk} = $LongTruncOk;
|
||||
|
||||
$self->{dbh} = $dbh;
|
||||
|
||||
#$self->db_do('SET CLIENT_ENCODING TO ?',$client_encoding);
|
||||
|
||||
if (length($transaction_isolation_level) > 0) {
|
||||
$self->db_do('SET TRANSACTION ISOLATION LEVEL ' . $transaction_isolation_level);
|
||||
}
|
||||
|
||||
dbinfo($self,'connected',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub vacuum {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('DBCC SHRINKDATABASE (0) WITH NO_INFOMSGS');
|
||||
|
||||
}
|
||||
|
||||
sub _db_disconnect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->SUPER::_db_disconnect();
|
||||
|
||||
}
|
||||
|
||||
sub getfieldnames {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $self->db_get_col('SELECT column_name FROM information_schema.columns WHERE table_name = ?',$tablename);
|
||||
#return $self->db_get_col('SELECT name FROM sys.columns WHERE object_id = OBJECT_ID(?)', 'dbo.' . $tablename);
|
||||
|
||||
}
|
||||
|
||||
sub getprimarykeycols {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $self->db_get_col('SELECT c.column_name from ' .
|
||||
'information_schema.table_constraints t, ' .
|
||||
'information_schema.constraint_column_usage c ' .
|
||||
'WHERE ' .
|
||||
'c.constraint_name = t.constraint_name ' .
|
||||
'AND c.table_name = t.table_name ' .
|
||||
'AND t.constraint_type = ? ' .
|
||||
'AND c.table_name = ?','PRIMARY KEY',$tablename);
|
||||
|
||||
}
|
||||
|
||||
sub create_temptable {
|
||||
|
||||
my $self = shift;
|
||||
my $select_stmt = shift;
|
||||
my $indexes = shift;
|
||||
|
||||
my $index_tablename = $self->_gettemptablename();
|
||||
my $temp_tablename = '##' . $index_tablename;
|
||||
|
||||
my ($select_fields_part,$table_whereclause_part) = split /\s+from\s+/i,$select_stmt,2;
|
||||
|
||||
$self->db_do($select_fields_part . ' INTO ' . $temp_tablename . ' FROM ' . $table_whereclause_part);
|
||||
temptablecreated($self,$index_tablename,$logger);
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
#if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$indexname = lc($index_tablename) . '_' . $indexname;
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$index_tablename,$indexname,$logger);
|
||||
#}
|
||||
}
|
||||
}
|
||||
|
||||
return $temp_tablename;
|
||||
|
||||
}
|
||||
|
||||
sub create_primarykey {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$keycols,$fieldnames) = @_;
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')';
|
||||
$self->db_do($statement);
|
||||
primarykeycreated($self,$tablename,$keycols,$logger);
|
||||
return 1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
sub create_indexes {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$indexes,$keycols) = @_;
|
||||
|
||||
my $index_count = 0;
|
||||
if (length($tablename) > 0) {
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return $index_count;
|
||||
}
|
||||
|
||||
sub create_texttable {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
#my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
my $created = 0;
|
||||
if ($self->table_exists($tablename) == 0) {
|
||||
my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' (';
|
||||
#$statement .= join(' TEXT, ',@$fieldnames) . ' TEXT';
|
||||
|
||||
my $allindexcols = [];
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
$allindexcols = mergearrays($allindexcols,$self->_extract_indexcols($indexes->{$indexname}));
|
||||
#push(@allindexcols, $self->_extract_indexcols($indexes->{$indexname}));
|
||||
}
|
||||
}
|
||||
$allindexcols = removeduplicates($allindexcols,1);
|
||||
|
||||
my @fieldspecs = ();
|
||||
foreach my $fieldname (@$fieldnames) {
|
||||
if (contains($fieldname,$keycols,1)) {
|
||||
push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(' . $varcharsize . ') NOT NULL';
|
||||
#$statement .= $fieldname . ' VARCHAR(256)';
|
||||
} elsif (contains($fieldname,$allindexcols,1)) {
|
||||
push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(' . $varcharsize . ')';
|
||||
#$statement .= $fieldname . ' VARCHAR(256)';
|
||||
} else {
|
||||
push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(MAX)';
|
||||
#$statement .= $fieldname . ' TEXT';
|
||||
}
|
||||
}
|
||||
$statement .= join(', ',@fieldspecs);
|
||||
|
||||
|
||||
#if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
$statement .= ', PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')';
|
||||
}
|
||||
|
||||
$statement .= ')'; # CHARACTER SET ' . $texttable_charset . ', COLLATE ' . $texttable_collation . ', ENGINE ' . $texttable_engine;
|
||||
|
||||
$self->db_do($statement);
|
||||
texttablecreated($self,$tablename,$logger);
|
||||
|
||||
if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$created = 1;
|
||||
} else {
|
||||
my $fieldnamesfound = $self->getfieldnames($tablename);
|
||||
if (not setcontains($fieldnames,$fieldnamesfound,1)) {
|
||||
fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $created and $truncate) {
|
||||
$self->truncate_table($tablename);
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
#return $tablename;
|
||||
|
||||
}
|
||||
|
||||
sub multithreading_supported {
|
||||
|
||||
my $self = shift;
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub truncate_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('TRUNCATE ' . $self->tableidentifier($tablename));
|
||||
tabletruncated($self,$tablename,$logger);
|
||||
|
||||
}
|
||||
|
||||
sub table_exists {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
return $self->db_get_value('SELECT COUNT(*) FROM information_schema.tables WHERE table_name = ?',$tablename);
|
||||
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if ($self->table_exists($tablename) > 0) {
|
||||
$self->db_do('DROP TABLE ' . $self->tableidentifier($tablename));
|
||||
tabledropped($self,$tablename,$logger);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub db_do_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_get_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
#my $lock = shift;
|
||||
|
||||
$self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_finish {
|
||||
|
||||
my $self = shift;
|
||||
#my $unlock = shift;
|
||||
|
||||
$self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk);
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,609 @@
|
||||
package SqlConnectors::SQLiteDB;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
use Globals qw(
|
||||
$local_db_path
|
||||
$LongReadLen_limit);
|
||||
use Logging qw(
|
||||
getlogger
|
||||
dbinfo
|
||||
dbdebug
|
||||
texttablecreated
|
||||
temptablecreated
|
||||
indexcreated
|
||||
tabletruncated
|
||||
tabledropped);
|
||||
use LogError qw(
|
||||
dberror
|
||||
fieldnamesdiffer
|
||||
dbwarn
|
||||
fileerror
|
||||
filewarn);
|
||||
|
||||
use DBI 1.608 qw(:sql_types);
|
||||
use DBD::SQLite 1.29;
|
||||
use Array qw(arrayeq contains setcontains);
|
||||
|
||||
use Utils qw(
|
||||
tempfilename
|
||||
timestampdigits
|
||||
timestamp);
|
||||
|
||||
use SqlConnectors::SQLiteVarianceAggregate;
|
||||
|
||||
use SqlConnector;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter SqlConnector);
|
||||
our @EXPORT_OK = qw($staticdbfilemode
|
||||
$timestampdbfilemode
|
||||
$temporarydbfilemode
|
||||
$memorydbfilemode
|
||||
$privatedbfilemode
|
||||
get_tableidentifier
|
||||
cleanupdbfiles);
|
||||
|
||||
our $staticdbfilemode = 0; #remains on disk after shutdown
|
||||
our $timestampdbfilemode = 1; #remains on disk after shutdown
|
||||
our $temporarydbfilemode = 2; #cleaned on shutdown
|
||||
our $memorydbfilemode = 3; #never on disk
|
||||
our $privatedbfilemode = 4; #somewhere on disk, cleaned on shutdown
|
||||
|
||||
my $cachesize = 16384; #40000;
|
||||
my $pagesize = 2048; #8192;
|
||||
my $busytimeout = 20000; #msecs
|
||||
|
||||
my $dbextension = '.db';
|
||||
my $journalpostfix = '-journal';
|
||||
|
||||
my $texttable_encoding = 'UTF-8'; # sqlite returns whats inserted...
|
||||
|
||||
$DBD::SQLite::COLLATION{no_accents} = sub {
|
||||
my ( $a, $b ) = map lc, @_;
|
||||
tr[àâáäåãçðèêéëìîíïñòôóöõøùûúüý]
|
||||
[aaaaaacdeeeeiiiinoooooouuuuy] for $a, $b;
|
||||
$a cmp $b;
|
||||
};
|
||||
|
||||
my $LongReadLen = $LongReadLen_limit; #bytes
|
||||
my $LongTruncOk = 0;
|
||||
|
||||
my $logger = getlogger(__PACKAGE__);
|
||||
|
||||
my $lock_do_chunk = 1;
|
||||
my $lock_get_chunk = 1;
|
||||
|
||||
#SQLite transactions are always serializable.
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
|
||||
my $self = SqlConnector->new(@_);
|
||||
|
||||
$self->{filemode} = undef;
|
||||
$self->{dbfilename} = undef;
|
||||
|
||||
$self->{drh} = DBI->install_driver('SQLite');
|
||||
|
||||
bless($self,$class);
|
||||
|
||||
dbdebug($self,__PACKAGE__ . ' connector created',$logger);
|
||||
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _connectidentifier {
|
||||
|
||||
my $self = shift;
|
||||
return _get_connectidentifier($self->{filemode},$self->{dbfilename});
|
||||
|
||||
}
|
||||
|
||||
sub tableidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
return $tablename;
|
||||
|
||||
}
|
||||
|
||||
sub columnidentifier {
|
||||
|
||||
my $self = shift;
|
||||
my $columnname = shift;
|
||||
|
||||
return $columnname;
|
||||
|
||||
}
|
||||
|
||||
sub get_tableidentifier {
|
||||
|
||||
my ($tablename,$filemode, $filename) = @_;
|
||||
my $connectionidentifier = _get_connectidentifier($filemode, $filename);
|
||||
if (defined $connectionidentifier) {
|
||||
return $connectionidentifier . '.' . $tablename;
|
||||
} else {
|
||||
return $tablename;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getsafetablename {
|
||||
|
||||
my $self = shift;
|
||||
my $tableidentifier = shift;
|
||||
|
||||
return $self->SUPER::getsafetablename($tableidentifier);
|
||||
|
||||
}
|
||||
|
||||
sub _force_numeric_column {
|
||||
my $self = shift;
|
||||
my $column = shift;
|
||||
return 'CAST(' . $column . ' AS REAL)';
|
||||
}
|
||||
|
||||
sub getdatabases {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my $rdbextension = quotemeta($dbextension);
|
||||
my $ucrdbextension = quotemeta(uc($dbextension));
|
||||
#my $rjournalpostfix = quotemeta($journalpostfix);
|
||||
local *DBDIR;
|
||||
if (not opendir(DBDIR, $local_db_path)) {
|
||||
fileerror('cannot opendir ' . $local_db_path . ': ' . $!,$logger);
|
||||
return [];
|
||||
}
|
||||
my @files = grep { /($rdbextension|$ucrdbextension)$/ && -f $local_db_path . $_ } readdir(DBDIR);
|
||||
closedir DBDIR;
|
||||
my @databases = ();
|
||||
foreach my $file (@files) {
|
||||
#print $file;
|
||||
my $databasename = $file;
|
||||
$databasename =~ s/($rdbextension|$ucrdbextension)$//g;
|
||||
push @databases,$databasename;
|
||||
}
|
||||
return \@databases;
|
||||
|
||||
}
|
||||
|
||||
sub _createdatabase {
|
||||
|
||||
my $self = shift;
|
||||
my ($filename) = @_;
|
||||
my $dbfilename = _getdbfilename($self->{filemode},$filename);
|
||||
|
||||
if ($self->_is_filebased() and not -e $dbfilename) {
|
||||
my $dbh = DBI->connect(
|
||||
'dbi:SQLite:dbname=' . $dbfilename, '', '',
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
#sqlite_unicode => 1, latin 1 chars
|
||||
#AutoCommit => 0,
|
||||
}
|
||||
) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger);
|
||||
$dbh->disconnect() or dbwarn($self,'error disconnecting: ' . $dbh->errstr(),$logger);
|
||||
dbinfo($self,'database \'' . $dbfilename . '\' created',$logger);
|
||||
}
|
||||
|
||||
return $dbfilename;
|
||||
|
||||
}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
my $self = shift;
|
||||
my ($filemode, $filename) = @_;
|
||||
|
||||
$self->SUPER::db_connect($filemode, $filename);
|
||||
|
||||
#if (defined $self->{dbh}) {
|
||||
# $self->db_disconnect();
|
||||
#}
|
||||
|
||||
$self->{filemode} = $filemode;
|
||||
$self->{dbfilename} = $self->_createdatabase($filename);
|
||||
|
||||
|
||||
my $dbh = DBI->connect(
|
||||
'dbi:SQLite:dbname=' . $self->{dbfilename}, '', '',
|
||||
{
|
||||
PrintError => 0,
|
||||
RaiseError => 0,
|
||||
#sqlite_unicode => 1, latin 1 chars
|
||||
#AutoCommit => 0,
|
||||
}
|
||||
) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger);
|
||||
#or sqlitedberror($dbfilename,'error connecting to sqlite db',$logger);
|
||||
|
||||
$dbh->{InactiveDestroy} = 1;
|
||||
|
||||
$dbh->{LongReadLen} = $LongReadLen;
|
||||
$dbh->{LongTruncOk} = $LongTruncOk;
|
||||
|
||||
$dbh->{AutoCommit} = 1;
|
||||
# we use a mysql style
|
||||
$dbh->sqlite_create_function('now', 0, \×tamp );
|
||||
$dbh->sqlite_create_function('concat', 2, \&_concat );
|
||||
#$dbh->sqlite_create_function(float_equal ??
|
||||
$dbh->sqlite_create_aggregate( 'variance', 1, 'SQLiteVarianceAggregate' );
|
||||
|
||||
$dbh->sqlite_busy_timeout($busytimeout);
|
||||
|
||||
$self->{dbh} = $dbh;
|
||||
|
||||
#SQLite transactions are always serializable.
|
||||
|
||||
$self->db_do('PRAGMA foreign_keys = OFF');
|
||||
#$self->db_do('PRAGMA default_synchronous = OFF');
|
||||
$self->db_do('PRAGMA synchronous = OFF');
|
||||
$self->db_do('PRAGMA page_size = ' . $pagesize);
|
||||
$self->db_do('PRAGMA cache_size = ' . $cachesize);
|
||||
#$self->db_do('PRAGMA encoding = "UTF-8"'); # only new databases!
|
||||
$self->db_do('PRAGMA encoding = "' . $texttable_encoding . '"'); # only new databases!
|
||||
#PRAGMA locking_mode = NORMAL ... by default
|
||||
#$self->db_do('PRAGMA auto_vacuum = INCREMENTAL');
|
||||
|
||||
dbinfo($self,'connected',$logger);
|
||||
|
||||
}
|
||||
|
||||
sub _concat {
|
||||
|
||||
return $_[0] . $_[1];
|
||||
|
||||
}
|
||||
|
||||
sub vacuum {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_finish();
|
||||
|
||||
if (defined $self->{dbh}) {
|
||||
if ($self->{filemode} == $staticdbfilemode or $self->{filemode} == $timestampdbfilemode) {
|
||||
$self->db_do('VACUUM'); # or sqlitedberror($self,"failed to VACUUM\nDBI error:\n" . $self->{dbh}->errstr(),$logger);
|
||||
dbinfo($self,'VACUUMed',$logger);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _db_disconnect {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->SUPER::_db_disconnect();
|
||||
|
||||
if ($self->{filemode} == $temporarydbfilemode and defined $self->{dbfilename} and -e $self->{dbfilename}) {
|
||||
if ((unlink $self->{dbfilename}) > 0) {
|
||||
dbinfo($self,'db file removed',$logger);
|
||||
} else {
|
||||
dbwarn($self,'cannot remove db file: ' . $!,$logger);
|
||||
}
|
||||
my $journalfilename = $self->{dbfilename} . '-journal';
|
||||
if (-e $journalfilename) {
|
||||
if ((unlink $journalfilename) > 0) {
|
||||
dbinfo($self,'journal file removed',$logger);
|
||||
} else {
|
||||
dbwarn($self,'cannot remove journal file: ' . $!,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub cleanupdbfiles {
|
||||
|
||||
my (@remainingdbfilenames) = @_;
|
||||
my $rdbextension = quotemeta($dbextension);
|
||||
my $ucrdbextension = quotemeta(uc($dbextension));
|
||||
my $rjournalpostfix = quotemeta($journalpostfix);
|
||||
local *DBDIR;
|
||||
if (not opendir(DBDIR, $local_db_path)) {
|
||||
fileerror('cannot opendir ' . $local_db_path . ': ' . $!,$logger);
|
||||
return;
|
||||
}
|
||||
my @files = grep { /($rdbextension|$ucrdbextension)($rjournalpostfix)?$/ && -f $local_db_path . $_ } readdir(DBDIR);
|
||||
closedir DBDIR;
|
||||
my @remainingdbfiles = ();
|
||||
foreach my $filename (@remainingdbfilenames) {
|
||||
push @remainingdbfiles,$local_db_path . $filename . $dbextension;
|
||||
push @remainingdbfiles,$local_db_path . $filename . $dbextension . $journalpostfix;
|
||||
push @remainingdbfiles,$local_db_path . uc($filename . $dbextension) . $journalpostfix;
|
||||
}
|
||||
foreach my $file (@files) {
|
||||
#print $file;
|
||||
my $filepath = $local_db_path . $file;
|
||||
if (not contains($filepath,\@remainingdbfiles)) {
|
||||
if ((unlink $filepath) == 0) {
|
||||
filewarn('cannot remove ' . $filepath . ': ' . $!,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getfieldnames {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
my @fieldnames = keys %{$self->db_get_all_hashref('PRAGMA table_info(' . $tablename . ')','name')};
|
||||
return \@fieldnames;
|
||||
|
||||
}
|
||||
|
||||
sub getprimarykeycols {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
#return $self->db_get_col('SHOW FIELDS FROM ' . $tablename);
|
||||
my $fieldinfo = $self->db_get_all_hashref('PRAGMA table_info(' . $tablename . ')','name');
|
||||
my @keycols = ();
|
||||
foreach my $fieldname (keys %$fieldinfo) {
|
||||
if ($fieldinfo->{$fieldname}->{'pk'}) {
|
||||
push @keycols,$fieldname;
|
||||
}
|
||||
}
|
||||
return \@keycols;
|
||||
|
||||
}
|
||||
|
||||
sub create_primarykey {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$keycols,$fieldnames) = @_;
|
||||
|
||||
#not supported by sqlite
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub create_indexes {
|
||||
my $self = shift;
|
||||
my ($tablename,$indexes,$keycols) = @_;
|
||||
|
||||
my $index_count = 0;
|
||||
if (length($tablename) > 0) {
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return $index_count;
|
||||
}
|
||||
|
||||
sub create_temptable {
|
||||
|
||||
my $self = shift;
|
||||
my $select_stmt = shift;
|
||||
my $indexes = shift;
|
||||
|
||||
my $index_tablename = $self->_gettemptablename();
|
||||
my $temp_tablename = $self->tableidentifier($index_tablename);
|
||||
|
||||
$self->db_do('CREATE TEMPORARY TABLE ' . $temp_tablename . ' AS ' . $select_stmt);
|
||||
#push(@{$self->{temp_tables}},$temp_tablename);
|
||||
temptablecreated($self,$index_tablename,$logger);
|
||||
|
||||
#$self->{temp_table_count} += 1;
|
||||
|
||||
if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
#if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$indexname = lc($index_tablename) . '_' . $indexname;
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$index_tablename,$indexname,$logger);
|
||||
#}
|
||||
}
|
||||
}
|
||||
|
||||
return $temp_tablename;
|
||||
|
||||
}
|
||||
|
||||
sub create_texttable {
|
||||
|
||||
my $self = shift;
|
||||
my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_;
|
||||
#my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_;
|
||||
|
||||
#my $tablename = $self->getsafetablename($tableidentifier);
|
||||
|
||||
if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') {
|
||||
|
||||
my $created = 0;
|
||||
if ($self->table_exists($tablename) == 0) {
|
||||
my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' (';
|
||||
$statement .= join(' TEXT, ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$fieldnames) . ' TEXT'; # sqlite_unicode off... outcoming strings not marked utf8
|
||||
#$statement .= join(' BLOB, ',@$fieldnames) . ' BLOB'; #to maintain source char encoding when inserting?
|
||||
#if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) {
|
||||
$statement .= ', PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')';
|
||||
}
|
||||
$statement .= ')';
|
||||
|
||||
$self->db_do($statement);
|
||||
texttablecreated($self,$tablename,$logger);
|
||||
|
||||
if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) {
|
||||
foreach my $indexname (keys %$indexes) {
|
||||
my $indexcols = $self->_extract_indexcols($indexes->{$indexname});
|
||||
if (not arrayeq($indexcols,$keycols,1)) {
|
||||
#$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')';
|
||||
$self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')');
|
||||
indexcreated($self,$tablename,$indexname,$logger);
|
||||
}
|
||||
}
|
||||
}
|
||||
$created = 1;
|
||||
} else {
|
||||
my $fieldnamesfound = $self->getfieldnames($tablename);
|
||||
if (not setcontains($fieldnames,$fieldnamesfound,1)) {
|
||||
fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $created and $truncate) {
|
||||
$self->truncate_table($tablename);
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
#return $tablename;
|
||||
|
||||
}
|
||||
|
||||
sub multithreading_supported {
|
||||
|
||||
my $self = shift;
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub truncate_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->db_do('DELETE FROM ' . $self->tableidentifier($tablename));
|
||||
#$self->db_do('VACUUM');
|
||||
tabletruncated($self,$tablename,$logger);
|
||||
|
||||
}
|
||||
|
||||
sub table_exists {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
return $self->db_get_value('SELECT COUNT(*) FROM sqlite_master WHERE type = \'table\' AND name = ?',$tablename);
|
||||
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
|
||||
my $self = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
if ($self->table_exists($tablename) > 0) {
|
||||
$self->db_do('DROP TABLE ' . $self->tableidentifier($tablename));
|
||||
|
||||
#my $indexes = $self->db_get_col('SELECT name FROM sqlite_master WHERE type = \'index\' AND tbl_name = ?',$tablename);
|
||||
#foreach my $indexname (@$indexes) {
|
||||
# $self->db_do('DROP INDEX IF EXISTS ' . $indexname);
|
||||
#}
|
||||
|
||||
|
||||
#$self->db_do('VACUUM');
|
||||
tabledropped($self,$tablename,$logger);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub _get_connectidentifier {
|
||||
|
||||
my ($filemode, $filename) = @_;
|
||||
if ($filemode == $staticdbfilemode and defined $filename) {
|
||||
return $filename;
|
||||
} elsif ($filemode == $timestampdbfilemode) {
|
||||
return $filename;
|
||||
} elsif ($filemode == $temporarydbfilemode) {
|
||||
return $filename;
|
||||
} elsif ($filemode == $memorydbfilemode) {
|
||||
return '<InMemoryDB>';
|
||||
} elsif ($filemode == $privatedbfilemode) {
|
||||
return '<PrivateDB>';
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _getdbfilename {
|
||||
|
||||
my ($filemode,$filename) = @_;
|
||||
if ($filemode == $staticdbfilemode and defined $filename) {
|
||||
return $local_db_path . $filename . $dbextension;
|
||||
} elsif ($filemode == $timestampdbfilemode) {
|
||||
return $local_db_path . timestampdigits() . $dbextension;
|
||||
} elsif ($filemode == $temporarydbfilemode) {
|
||||
return tempfilename('XXXX',$local_db_path,$dbextension);
|
||||
} elsif ($filemode == $memorydbfilemode) {
|
||||
return ':memory:';
|
||||
} elsif ($filemode == $privatedbfilemode) {
|
||||
return '';
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _is_filebased {
|
||||
|
||||
my $self = shift;
|
||||
if ($self->{filemode} == $staticdbfilemode or $self->{filemode} == $timestampdbfilemode or $self->{filemode} == $temporarydbfilemode) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub db_do_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
|
||||
$self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_get_begin {
|
||||
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $tablename = shift;
|
||||
#my $lock = shift;
|
||||
|
||||
$self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_);
|
||||
|
||||
}
|
||||
|
||||
sub db_finish {
|
||||
|
||||
my $self = shift;
|
||||
#my $unlock = shift;
|
||||
|
||||
$self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk);
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,67 @@
|
||||
# helper module to implement variance aggregate function with SQLite
|
||||
# adamk@cpan.org
|
||||
# 2009
|
||||
|
||||
# used only for testing custom functions ...
|
||||
|
||||
package SqlConnectors::SQLiteVarianceAggregate;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use File::Basename;
|
||||
use Cwd;
|
||||
use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../');
|
||||
|
||||
#sub new { bless [], shift; }
|
||||
#
|
||||
#sub step {
|
||||
# my ( $self, $value ) = @_;
|
||||
#
|
||||
# push @$self, $value;
|
||||
#}
|
||||
#
|
||||
#sub finalize {
|
||||
# my $self = $_[0];
|
||||
#
|
||||
# my $n = @$self;
|
||||
#
|
||||
# # Variance is NULL unless there is more than one row
|
||||
# return undef unless $n || $n == 1;
|
||||
#
|
||||
# my $mu = 0;
|
||||
# foreach my $v ( @$self ) {
|
||||
# $mu += $v;
|
||||
# }
|
||||
# $mu /= $n;
|
||||
#
|
||||
# my $sigma = 0;
|
||||
# foreach my $v ( @$self ) {
|
||||
# #$sigma += ($x - $mu)**2;
|
||||
# $sigma += ($v - $mu)**2;
|
||||
# }
|
||||
# $sigma = $sigma / ($n - 1);
|
||||
#
|
||||
# return $sigma;
|
||||
#}
|
||||
|
||||
my $mu = 0;
|
||||
my $count = 0;
|
||||
my $S = 0;
|
||||
|
||||
sub new { bless [], shift; }
|
||||
|
||||
sub step {
|
||||
my ( $self, $value ) = @_;
|
||||
$count++;
|
||||
my $delta = $value - $mu;
|
||||
$mu += $delta / $count;
|
||||
$S += $delta * ($value - $mu);
|
||||
}
|
||||
|
||||
sub finalize {
|
||||
my $self = $_[0];
|
||||
return $S / ($count - 1);
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,236 @@
|
||||
# table module: a 2D array object = array of arrays = fetchall_arrayref result
|
||||
|
||||
package Table;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use Digest::MD5;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_rowhash);
|
||||
|
||||
sub new {
|
||||
|
||||
my $class = shift;
|
||||
my $self = bless {}, $class;
|
||||
$self->_set_data($_[0],$_[1]);
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub _set_data {
|
||||
|
||||
my $self = shift;
|
||||
my ($data,$dupecheck) = shift;
|
||||
$self->clear();
|
||||
if (defined $data and ref $data eq 'ARRAY') {
|
||||
if ($dupecheck) {
|
||||
foreach my $row (@$data) {
|
||||
$self->addrow_ref_nodupe($row);
|
||||
}
|
||||
} else {
|
||||
foreach my $row (@$data) {
|
||||
$self->addrow_ref($row);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub clear {
|
||||
|
||||
my $self = shift;
|
||||
$self->{data} = [];
|
||||
$self->{rowhashes} = {};
|
||||
|
||||
}
|
||||
|
||||
sub data_ref {
|
||||
|
||||
my $self = shift;
|
||||
if ($_[0]) {
|
||||
#if argument, set the value
|
||||
$self->_set_data($_[0],$_[1]);
|
||||
} else {
|
||||
return $self->{data};
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub addrow {
|
||||
|
||||
my $self = shift;
|
||||
#my @row = @_;
|
||||
return $self->addrow_ref(\@_);
|
||||
|
||||
}
|
||||
|
||||
sub addrow_nodupe {
|
||||
|
||||
my $self = shift;
|
||||
#my @row = @_;
|
||||
return $self->addrow_ref_nodupe(\@_);
|
||||
|
||||
}
|
||||
|
||||
sub addrow_ref {
|
||||
|
||||
my $self = shift;
|
||||
my $row_ref = shift;
|
||||
my $rowhash = get_rowhash($row_ref);
|
||||
my $itemcount = 0;
|
||||
if (defined $rowhash) {
|
||||
if (not exists $self->{rowhashes}->{$rowhash}) {
|
||||
$self->{rowhashes}->{$rowhash} = 0;
|
||||
}
|
||||
$itemcount = $self->{rowhashes}->{$rowhash} + 1;
|
||||
$self->{rowhashes}->{$rowhash} = $itemcount;
|
||||
push @{$self->{data}},$row_ref;
|
||||
}
|
||||
return $itemcount;
|
||||
|
||||
}
|
||||
|
||||
sub addrow_ref_nodupe {
|
||||
|
||||
my $self = shift;
|
||||
my $row_ref = shift;
|
||||
my $rowhash = get_rowhash($row_ref);
|
||||
my $itemcount = 0;
|
||||
if (defined $rowhash) {
|
||||
if (not exists $self->{rowhashes}->{$rowhash}) {
|
||||
$self->{rowhashes}->{$rowhash} = 1;
|
||||
$itemcount = 1;
|
||||
push @{$self->{data}},$row_ref;
|
||||
} else {
|
||||
$itemcount = $self->{rowhashes}->{$rowhash};
|
||||
}
|
||||
}
|
||||
return $itemcount;
|
||||
|
||||
}
|
||||
|
||||
sub rowexists {
|
||||
|
||||
my $self = shift;
|
||||
#my @row = @_;
|
||||
return $self->rowexists_ref(\@_);
|
||||
|
||||
}
|
||||
|
||||
sub rowexists_ref {
|
||||
|
||||
my $self = shift;
|
||||
my $row_ref = shift;
|
||||
my $rowhash = get_rowhash($row_ref);
|
||||
my $itemcount = 0;
|
||||
if (defined $rowhash) {
|
||||
if (exists $self->{rowhashes}->{$rowhash}) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
sub get_rowhash {
|
||||
|
||||
my $row_ref = shift;
|
||||
if (defined $row_ref and ref $row_ref eq 'ARRAY') {
|
||||
my $md5 = Digest::MD5->new;
|
||||
foreach my $element (@$row_ref) {
|
||||
$md5->add($element);
|
||||
}
|
||||
return $md5->hexdigest;
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub rowcount {
|
||||
|
||||
my $self = shift;
|
||||
#my @rows = @{$self->{data}};
|
||||
return scalar @{$self->{data}}; # + 1;
|
||||
|
||||
}
|
||||
|
||||
sub element {
|
||||
|
||||
my $self = shift;
|
||||
return $self->{data}->[$_[0]]->[$_[1]];
|
||||
|
||||
}
|
||||
|
||||
sub getrow {
|
||||
|
||||
my $self = shift;
|
||||
my $row_ref = $self->{data}->[$_[0]];
|
||||
if ($row_ref) {
|
||||
return @$row_ref;
|
||||
} else {
|
||||
return ();
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getrow_ref {
|
||||
|
||||
my $self = shift;
|
||||
my $row_ref = $self->{data}->[$_[0]];
|
||||
if ($row_ref) {
|
||||
return $row_ref;
|
||||
} else {
|
||||
return [];
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getcol {
|
||||
|
||||
my $self = shift;
|
||||
my @col = ();
|
||||
for (my $i = 0; $i < $self->rowcount(); $i++) {
|
||||
push(@col,$self->{data}->[$i]->[$_[0]]);
|
||||
}
|
||||
return @col;
|
||||
|
||||
}
|
||||
|
||||
sub getcol_ref {
|
||||
|
||||
my $self = shift;
|
||||
my @col = $self->getcol($_[0]);
|
||||
return \@col;
|
||||
|
||||
}
|
||||
|
||||
sub sortrows {
|
||||
|
||||
my $self = shift;
|
||||
my $sortfunction = shift;
|
||||
my @new_rows = sort $sortfunction @{$self->{data}};
|
||||
#$self->_set_data(\@new_rows);
|
||||
# since sorting can not affect uniqueness of rows and rowhashes, we just set:
|
||||
$self->{data} = \@new_rows;
|
||||
|
||||
}
|
||||
|
||||
sub tostring {
|
||||
|
||||
my $self = shift;
|
||||
my @rows = @{$self->{data}};
|
||||
my $result = '';
|
||||
my $row_ref;
|
||||
for (my $i = 0; $i < scalar @rows; $i++) {
|
||||
$row_ref = $rows[$i];
|
||||
$result .= join($_[0],@$row_ref) . $_[1];
|
||||
}
|
||||
return substr($result,0,length($result) - length($_[1]));
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,787 @@
|
||||
package Utils;
|
||||
use strict;
|
||||
|
||||
## no critic
|
||||
|
||||
use threads;
|
||||
|
||||
#use POSIX qw(strtod);
|
||||
use POSIX qw(strtod locale_h);
|
||||
setlocale(LC_NUMERIC, 'C');
|
||||
#use Logging qw(fileerror);
|
||||
|
||||
use Data::UUID;
|
||||
|
||||
use Net::Address::IP::Local;
|
||||
#use FindBin qw($Bin);
|
||||
#use File::Spec::Functions qw(splitdir catdir);
|
||||
use Net::Domain qw(hostname hostfqdn hostdomain);
|
||||
|
||||
use Cwd 'abs_path';
|
||||
#use File::Basename qw(fileparse);
|
||||
|
||||
use Date::Manip qw(Date_Init ParseDate UnixDate);
|
||||
#Date_Init('Language=English','DateFormat=non-US');
|
||||
Date_Init('DateFormat=US');
|
||||
#use Net::Address::IP::Local;
|
||||
|
||||
use Date::Calc qw(Normalize_DHMS Add_Delta_DHMS);
|
||||
|
||||
use Text::Wrap;
|
||||
#use FindBin qw($Bin);
|
||||
use Digest::MD5; #qw(md5 md5_hex md5_base64);
|
||||
use File::Temp qw(tempfile tempdir);
|
||||
use File::Path qw(remove_tree);
|
||||
|
||||
#use Sys::Info;
|
||||
#use Sys::Info::Constants qw( :device_cpu );
|
||||
|
||||
# after all, the only reliable way to get the true vCPU count:
|
||||
use Sys::CpuAffinity; # qw(getNumCpus); not exported?
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
float_equal
|
||||
round
|
||||
stringtobool
|
||||
booltostring
|
||||
check_bool
|
||||
tempfilename
|
||||
timestampdigits
|
||||
datestampdigits
|
||||
parse_datetime
|
||||
parse_date
|
||||
timestampfromdigits
|
||||
datestampfromdigits
|
||||
timestamptodigits
|
||||
datestamptodigits
|
||||
timestamptostring
|
||||
timestampaddsecs
|
||||
file_md5
|
||||
cat_file
|
||||
wrap_text
|
||||
create_guid
|
||||
urlencode
|
||||
urldecode
|
||||
timestamp
|
||||
datestamp
|
||||
timestamp_fromepochsecs
|
||||
get_year
|
||||
get_year_month
|
||||
get_year_month_day
|
||||
secs_to_years
|
||||
zerofill
|
||||
trim
|
||||
chopstring
|
||||
get_ipaddress
|
||||
get_hostfqdn
|
||||
getscriptpath
|
||||
|
||||
kbytes2gigs
|
||||
cleanupdir
|
||||
threadid
|
||||
format_number
|
||||
|
||||
dec2bin
|
||||
bin2dec
|
||||
|
||||
check_number
|
||||
min_timestamp
|
||||
max_timestamp
|
||||
add_months
|
||||
makedir
|
||||
changemod
|
||||
|
||||
get_cpucount
|
||||
|
||||
$chmod_umask
|
||||
|
||||
);
|
||||
|
||||
our $chmod_umask = '0777';
|
||||
|
||||
my $default_epsilon = 1e-3; #float comparison tolerance
|
||||
|
||||
sub float_equal {
|
||||
|
||||
my ($a, $b, $epsilon) = @_;
|
||||
if ((!defined $epsilon) || ($epsilon <= 0.0)) {
|
||||
$epsilon = $default_epsilon;
|
||||
}
|
||||
return (abs($a - $b) < $epsilon);
|
||||
|
||||
}
|
||||
|
||||
sub round {
|
||||
|
||||
my ($number) = shift;
|
||||
return int($number + .5 * ($number <=> 0));
|
||||
|
||||
}
|
||||
|
||||
sub stringtobool {
|
||||
|
||||
my $inputstring = shift;
|
||||
if (lc($inputstring) eq 'y' or lc($inputstring) eq 'true' or $inputstring >= 1) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub booltostring {
|
||||
|
||||
if (shift) {
|
||||
return 'true';
|
||||
} else {
|
||||
return 'false';
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub check_bool {
|
||||
|
||||
my $inputstring = shift;
|
||||
if (lc($inputstring) eq 'y' or lc($inputstring) eq 'true' or $inputstring >= 1) {
|
||||
return 1;
|
||||
} elsif (lc($inputstring) eq 'n' or lc($inputstring) eq 'false' or $inputstring == 0) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub timestampdigits {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
|
||||
return sprintf "%4d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec;
|
||||
|
||||
}
|
||||
|
||||
sub datestampdigits {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
|
||||
return sprintf "%4d%02d%02d",$year+1900,$mon+1,$mday;
|
||||
|
||||
}
|
||||
|
||||
sub parse_datetime {
|
||||
|
||||
my ($datetimestring,$non_us) = @_;
|
||||
if ($non_us) {
|
||||
Date_Init('DateFormat=non-US');
|
||||
} else {
|
||||
Date_Init('DateFormat=US');
|
||||
}
|
||||
my $datetime = ParseDate($datetimestring);
|
||||
if (!$datetime) {
|
||||
return undef;
|
||||
} else {
|
||||
my ($year,$mon,$mday,$hour,$min,$sec) = UnixDate($datetime,"%Y","%m","%d","%H","%M","%S");
|
||||
return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$year,$mon,$mday,$hour,$min,$sec;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub parse_date {
|
||||
|
||||
my ($datetimestring,$non_us) = @_;
|
||||
if ($non_us) {
|
||||
Date_Init('DateFormat=non-US');
|
||||
} else {
|
||||
Date_Init('DateFormat=US');
|
||||
}
|
||||
my $datetime = ParseDate($datetimestring);
|
||||
if (!$datetime) {
|
||||
return undef;
|
||||
} else {
|
||||
my ($year,$mon,$mday) = UnixDate($datetime,"%Y","%m","%d");
|
||||
return sprintf "%4d-%02d-%02d",$year,$mon,$mday;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub timestampfromdigits {
|
||||
|
||||
my ($timestampdigits) = @_;
|
||||
if ($timestampdigits =~ /^[0-9]{14}$/g) {
|
||||
return substr($timestampdigits,0,4) . '-' .
|
||||
substr($timestampdigits,4,2) . '-' .
|
||||
substr($timestampdigits,6,2) . ' ' .
|
||||
substr($timestampdigits,8,2) . ':' .
|
||||
substr($timestampdigits,10,2) . ':' .
|
||||
substr($timestampdigits,12,2);
|
||||
} else {
|
||||
return $timestampdigits;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub datestampfromdigits {
|
||||
|
||||
my ($datestampdigits) = @_;
|
||||
if ($datestampdigits =~ /^[0-9]{8}$/g) {
|
||||
return substr($datestampdigits,0,4) . '-' .
|
||||
substr($datestampdigits,4,2) . '-' .
|
||||
substr($datestampdigits,6,2);
|
||||
} else {
|
||||
return $datestampdigits;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub timestamptodigits {
|
||||
|
||||
my ($datetimestring,$non_us) = @_;
|
||||
if ($non_us) {
|
||||
Date_Init('DateFormat=non-US');
|
||||
} else {
|
||||
Date_Init('DateFormat=US');
|
||||
}
|
||||
my $datetime = ParseDate($datetimestring);
|
||||
if (!$datetime) {
|
||||
return '0';
|
||||
} else {
|
||||
my ($year,$mon,$mday,$hour,$min,$sec) = UnixDate($datetime,"%Y","%m","%d","%H","%M","%S");
|
||||
return sprintf "%4d%02d%02d%02d%02d%02d",$year,$mon,$mday,$hour,$min,$sec;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub datestamptodigits {
|
||||
|
||||
my ($datestring,$non_us) = @_;
|
||||
if ($non_us) {
|
||||
Date_Init('DateFormat=non-US');
|
||||
} else {
|
||||
Date_Init('DateFormat=US');
|
||||
}
|
||||
my $datetime = ParseDate($datestring);
|
||||
if (!$datetime) {
|
||||
return '0';
|
||||
} else {
|
||||
my ($year,$mon,$mday) = UnixDate($datetime,"%Y","%m","%d");
|
||||
return sprintf "%4d%02d%02d",$year,$mon,$mday;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub timestamptostring {
|
||||
|
||||
Date_Init('DateFormat=US');
|
||||
return UnixDate(@_);
|
||||
|
||||
}
|
||||
|
||||
sub timestampaddsecs {
|
||||
|
||||
my ($datetimestring,$timespan,$non_us) = @_;
|
||||
|
||||
if ($non_us) {
|
||||
Date_Init('DateFormat=non-US');
|
||||
} else {
|
||||
Date_Init('DateFormat=US');
|
||||
}
|
||||
|
||||
my $datetime = ParseDate($datetimestring);
|
||||
|
||||
if (!$datetime) {
|
||||
|
||||
return $datetimestring;
|
||||
|
||||
} else {
|
||||
|
||||
my ($fromyear,$frommonth,$fromday,$fromhour,$fromminute,$fromsecond) = UnixDate($datetime,"%Y","%m","%d","%H","%M","%S");
|
||||
|
||||
my ($Dd,$Dh,$Dm,$Ds) = Date::Calc::Normalize_DHMS(0,0,0,$timespan);
|
||||
my ($toyear,$tomonth,$to_day,$tohour,$tominute,$tosecond) = Date::Calc::Add_Delta_DHMS($fromyear,$frommonth,$fromday,$fromhour,$fromminute,$fromsecond,
|
||||
$Dd,$Dh,$Dm,$Ds);
|
||||
|
||||
return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$toyear,$tomonth,$to_day,$tohour,$tominute,$tosecond;
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub tempfilename {
|
||||
|
||||
my ($template,$path,$suffix) = @_;
|
||||
my ($tmpfh,$tmpfilename) = tempfile($template,DIR => $path,SUFFIX => $suffix);
|
||||
close $tmpfh;
|
||||
return $tmpfilename;
|
||||
|
||||
}
|
||||
|
||||
sub file_md5 {
|
||||
|
||||
my ($filepath,$fileerrorcode,$logger) = @_;
|
||||
#use Logging qw(fileerror);
|
||||
local *MD5FILE;
|
||||
|
||||
if (not open (MD5FILE, '<' . $filepath)) {
|
||||
if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') {
|
||||
&$fileerrorcode('md5sum - cannot open file ' . $filepath . ': ' . $!,$logger);
|
||||
}
|
||||
return '';
|
||||
}
|
||||
binmode MD5FILE;
|
||||
my $md5digest = Digest::MD5->new->addfile(*MD5FILE)->hexdigest;
|
||||
close MD5FILE;
|
||||
return $md5digest;
|
||||
|
||||
}
|
||||
|
||||
sub cat_file {
|
||||
|
||||
my ($filepath,$fileerrorcode,$logger) = @_;
|
||||
|
||||
if (not open (CATFILE, '<' . $filepath)) {
|
||||
if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') {
|
||||
&$fileerrorcode('cat - cannot open file ' . $filepath . ': ' . $!,$logger);
|
||||
}
|
||||
return '';
|
||||
}
|
||||
my @linebuffer = <CATFILE>;
|
||||
close CATFILE;
|
||||
return join("\n",@linebuffer);
|
||||
|
||||
}
|
||||
|
||||
sub wrap_text {
|
||||
|
||||
my ($inputstring, $columns) = @_;
|
||||
$Text::Wrap::columns = $columns;
|
||||
return Text::Wrap::wrap("","",$inputstring);
|
||||
|
||||
}
|
||||
|
||||
sub create_guid {
|
||||
|
||||
my $ug = new Data::UUID;
|
||||
my $uuid = $ug->create();
|
||||
return $ug->to_string( $uuid );
|
||||
|
||||
}
|
||||
|
||||
sub urlencode {
|
||||
my ($urltoencode) = @_;
|
||||
$urltoencode =~ s/([^a-zA-Z0-9\/_\-.])/uc sprintf("%%%02x",ord($1))/eg;
|
||||
return $urltoencode;
|
||||
}
|
||||
|
||||
sub urldecode {
|
||||
my ($urltodecode) = @_;
|
||||
$urltodecode =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg;
|
||||
return $urltodecode;
|
||||
}
|
||||
|
||||
sub timestamp {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
|
||||
return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec;
|
||||
|
||||
}
|
||||
|
||||
sub timestamp_fromepochsecs {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(shift);
|
||||
return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec;
|
||||
|
||||
}
|
||||
|
||||
sub datestamp {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
|
||||
return sprintf "%4d-%02d-%02d",$year+1900,$mon+1,$mday;
|
||||
|
||||
}
|
||||
|
||||
sub get_year {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
|
||||
return (sprintf "%4d",$year+1900);
|
||||
|
||||
}
|
||||
|
||||
sub get_year_month {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
|
||||
return ((sprintf "%4d",$year+1900),(sprintf "%02d",$mon+1));
|
||||
|
||||
}
|
||||
|
||||
sub get_year_month_day {
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
|
||||
return ((sprintf "%4d",$year+1900),(sprintf "%02d",$mon+1),(sprintf "%02d",$mday));
|
||||
|
||||
}
|
||||
|
||||
sub zerofill {
|
||||
my ($integer,$digits) = @_;
|
||||
my $numberofzeroes = $digits - length($integer);
|
||||
my $resultstring = $integer;
|
||||
if ($digits > 0) {
|
||||
for (my $i = 0; $i < $numberofzeroes; $i += 1) {
|
||||
$resultstring = "0" . $resultstring;
|
||||
}
|
||||
}
|
||||
return $resultstring;
|
||||
}
|
||||
|
||||
sub trim {
|
||||
my ($inputstring) = @_;
|
||||
|
||||
$inputstring =~ s/[\n\r\t]/ /g;
|
||||
$inputstring =~ s/^ +//;
|
||||
$inputstring =~ s/ +$//;
|
||||
|
||||
return $inputstring;
|
||||
}
|
||||
|
||||
sub chopstring {
|
||||
|
||||
my ($inputstring,$trimlength,$ending) = @_;
|
||||
|
||||
my $result = $inputstring;
|
||||
|
||||
if (defined $inputstring) {
|
||||
|
||||
$result =~ s/[\n\r\t]/ /g;
|
||||
|
||||
if (not defined $trimlength) {
|
||||
$trimlength = 30;
|
||||
}
|
||||
if (not defined $ending) {
|
||||
$ending = '...'
|
||||
}
|
||||
|
||||
if (length($result) > $trimlength) {
|
||||
return substr($result,0,$trimlength-length($ending)) . $ending;
|
||||
}
|
||||
}
|
||||
|
||||
return $result;
|
||||
|
||||
}
|
||||
|
||||
sub get_ipaddress {
|
||||
|
||||
# Get the local system's IP address that is "en route" to "the internet":
|
||||
return Net::Address::IP::Local->public;
|
||||
|
||||
}
|
||||
|
||||
sub get_hostfqdn {
|
||||
|
||||
return hostfqdn();
|
||||
|
||||
}
|
||||
|
||||
sub getscriptpath {
|
||||
|
||||
return abs_path($0);
|
||||
|
||||
}
|
||||
|
||||
sub kbytes2gigs {
|
||||
my ($TotalkBytes,$kbytebase,$round) = @_;
|
||||
|
||||
if ($kbytebase <= 0) {
|
||||
$kbytebase = 1024;
|
||||
}
|
||||
|
||||
my $TotalkByteskBytes = $TotalkBytes;
|
||||
my $TotalkBytesMBytes = $TotalkBytes;
|
||||
my $TotalkBytesGBytes = $TotalkBytes;
|
||||
|
||||
my $rounded = 0;
|
||||
$TotalkByteskBytes = $TotalkBytes;
|
||||
$TotalkBytesMBytes = 0;
|
||||
$TotalkBytesGBytes = 0;
|
||||
|
||||
if ($TotalkByteskBytes >= $kbytebase) {
|
||||
$TotalkBytesMBytes = int($TotalkByteskBytes / $kbytebase);
|
||||
$rounded = int(($TotalkByteskBytes * 100) / $kbytebase) / 100;
|
||||
if ($round) { # == 1) {
|
||||
$rounded = int($rounded);
|
||||
}
|
||||
$rounded .= " MBytes";
|
||||
$TotalkByteskBytes = $TotalkBytes - $TotalkBytesGBytes * $kbytebase * $kbytebase - $TotalkBytesMBytes * $kbytebase;
|
||||
if ($TotalkBytesMBytes >= $kbytebase) {
|
||||
$TotalkBytesGBytes = int($TotalkBytesMBytes / $kbytebase);
|
||||
$rounded = int(($TotalkBytesMBytes * 100) / $kbytebase) / 100;
|
||||
if ($round) { # == 1) {
|
||||
$rounded = int($rounded);
|
||||
}
|
||||
$rounded .= " GBytes";
|
||||
$TotalkBytesMBytes = int(($TotalkBytes - $TotalkBytesGBytes * $kbytebase * $kbytebase) / $kbytebase);
|
||||
$TotalkByteskBytes = $TotalkBytes - $TotalkBytesGBytes * $kbytebase * $kbytebase - $TotalkBytesMBytes * $kbytebase;
|
||||
}
|
||||
}
|
||||
|
||||
if ($TotalkBytesGBytes == 0 && $TotalkBytesMBytes == 0) {
|
||||
$TotalkBytes .= " kBytes";
|
||||
} elsif ($TotalkBytesGBytes == 0) {
|
||||
$TotalkBytes = $rounded; # . " (" . $TotalkBytesMBytes . " MBytes " . $TotalkByteskBytes . " kBytes)";
|
||||
if ($round) { # == 1) {
|
||||
$TotalkBytes = $rounded;
|
||||
}
|
||||
} else {
|
||||
$TotalkBytes = $rounded; # . " (" . $TotalkBytesGBytes . " GBytes " . $TotalkBytesMBytes . " MBytes " . $TotalkByteskBytes . " kBytes)";
|
||||
if ($round) { # == 1) {
|
||||
$TotalkBytes = $rounded;
|
||||
}
|
||||
}
|
||||
return $TotalkBytes;
|
||||
}
|
||||
|
||||
sub cleanupdir {
|
||||
|
||||
my ($dirpath,$restoredir,$cleanupinfocode,$filewarncode,$logger) = @_;
|
||||
if (-e $dirpath) {
|
||||
if (remove_tree($dirpath) == 0) {
|
||||
if (defined $filewarncode and ref $filewarncode eq 'CODE') {
|
||||
&$filewarncode('cannot remove ' . $dirpath . ': ' . $!,$logger);
|
||||
}
|
||||
} else {
|
||||
if (defined $cleanupinfocode and ref $cleanupinfocode eq 'CODE') {
|
||||
&$cleanupinfocode($dirpath . ' removed',$logger);
|
||||
}
|
||||
}
|
||||
if ($restoredir) {
|
||||
makedir($dirpath);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub makedir {
|
||||
my ($dirpath) = @_;
|
||||
mkdir $dirpath;
|
||||
chmod oct($chmod_umask),$dirpath;
|
||||
}
|
||||
|
||||
sub changemod {
|
||||
my ($filepath) = @_;
|
||||
chmod oct($chmod_umask),$filepath;
|
||||
}
|
||||
|
||||
sub threadid {
|
||||
|
||||
return threads->tid();
|
||||
#return threads->_handle();
|
||||
|
||||
}
|
||||
|
||||
sub format_number {
|
||||
my ($value,$decimals) = @_;
|
||||
my $output = $value;
|
||||
#if (index($output,',') > -1) {
|
||||
# $output =~ s/,/\./g;
|
||||
#}
|
||||
if (defined $decimals and $decimals >= 0) {
|
||||
$output = round(($output * (10 ** ($decimals + 1))) / 10) / (10 ** $decimals);
|
||||
$output = sprintf("%." . $decimals . "f",$output);
|
||||
if (index($output,',') > -1) {
|
||||
$output =~ s/,/\./g;
|
||||
}
|
||||
} else {
|
||||
$output = sprintf("%f",$output);
|
||||
#if (index($output,',') > -1) {
|
||||
# $output =~ s/,/\./g;
|
||||
#}
|
||||
if (index($output,'.') > -1) {
|
||||
$output =~ s/0+$//g;
|
||||
$output =~ s/\.$//g;
|
||||
}
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub dec2bin {
|
||||
my $str = unpack("B32", pack("N", shift));
|
||||
$str =~ s/^0+(?=\d)//; # leading zeros otherwise
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub bin2dec {
|
||||
return unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
|
||||
}
|
||||
|
||||
sub getnum {
|
||||
|
||||
my $str = shift;
|
||||
$str =~ s/^\s+//;
|
||||
$str =~ s/\s+$//;
|
||||
$! = 0;
|
||||
my($num, $unparsed) = strtod($str);
|
||||
if (($str eq '') || ($unparsed != 0) || $!) {
|
||||
return;
|
||||
} else {
|
||||
return $num;
|
||||
}
|
||||
}
|
||||
|
||||
sub check_number {
|
||||
|
||||
my $potential_number = shift;
|
||||
if (defined getnum($potential_number)) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub min_timestamp {
|
||||
|
||||
my (@timestamps) = @_;
|
||||
|
||||
my $min_ts = $timestamps[0];
|
||||
foreach my $ts (@timestamps) {
|
||||
if (($ts cmp $min_ts) < 0) {
|
||||
$min_ts = $ts;
|
||||
}
|
||||
}
|
||||
|
||||
return $min_ts;
|
||||
|
||||
}
|
||||
|
||||
sub max_timestamp {
|
||||
|
||||
my (@timestamps) = @_;
|
||||
|
||||
my $min_ts = $timestamps[0];
|
||||
foreach my $ts (@timestamps) {
|
||||
if (($ts cmp $min_ts) > 0) {
|
||||
$min_ts = $ts;
|
||||
}
|
||||
}
|
||||
|
||||
return $min_ts;
|
||||
|
||||
}
|
||||
|
||||
sub add_months {
|
||||
|
||||
my ($month, $year, $ads) = @_;
|
||||
|
||||
if ($month > 0 and $month <= 12) {
|
||||
|
||||
my $sign = ($ads > 0) ? 1 : -1;
|
||||
my $rmonths = $month + $sign * (abs($ads) % 12);
|
||||
my $ryears = $year + int( $ads / 12 );
|
||||
|
||||
if ($rmonths < 1) {
|
||||
$rmonths += 12;
|
||||
$ryears -= 1;
|
||||
} elsif ($rmonths > 12) {
|
||||
$rmonths -= 12;
|
||||
$ryears += 1;
|
||||
}
|
||||
|
||||
return ($rmonths,$ryears);
|
||||
|
||||
} else {
|
||||
|
||||
return (undef,undef);
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub secs_to_years {
|
||||
|
||||
my $time_in_secs = shift;
|
||||
|
||||
my $negative = 0;
|
||||
if ($time_in_secs < 0) {
|
||||
$time_in_secs *= -1;
|
||||
$negative = 1;
|
||||
}
|
||||
|
||||
my $years = 0;
|
||||
my $months = 0;
|
||||
my $days = 0;
|
||||
my $hours = 0;
|
||||
my $mins = 0;
|
||||
my $secs = $time_in_secs;
|
||||
|
||||
if ($secs >= 60) {
|
||||
$mins = int($secs / 60);
|
||||
$secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60);
|
||||
if ($mins >= 60) {
|
||||
$hours = int($mins / 60);
|
||||
$mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60));
|
||||
$secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60);
|
||||
if ($hours >= 24) {
|
||||
$days = int($hours / 24);
|
||||
$hours = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24) / (60*60));
|
||||
$mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60));
|
||||
$secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60);
|
||||
if ($days >= 30) {
|
||||
$months = int($days / 30);
|
||||
$days = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30) / (60*60*24));
|
||||
$hours = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24) / (60*60));
|
||||
$mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60));
|
||||
$secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60);
|
||||
if ($months >= 12) {
|
||||
$years = int($months / 12);
|
||||
$months = int(($time_in_secs-$years*60*60*24*30*12) / (60*60*24*30));
|
||||
$days = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30) / (60*60*24));
|
||||
$hours = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24) / (60*60));
|
||||
$mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60));
|
||||
$secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$secs = zerofill(int($secs),2);
|
||||
$mins = zerofill($mins,2);
|
||||
$hours = zerofill($hours,2);
|
||||
|
||||
if ($years == 0 && $months == 0 && $days == 0) {
|
||||
$time_in_secs = $hours . ':' . $mins . ':' . $secs;
|
||||
} elsif($years == 0 && $months == 0) {
|
||||
$time_in_secs = $days . ' day(s) - ' . $hours . ':' . $mins . ':' . $secs;
|
||||
} elsif($years == 0) {
|
||||
$time_in_secs = $months . ' month(s)/' . $days . ' day(s) - ' . $hours . ':' . $mins . ':' . $secs;
|
||||
} else {
|
||||
$time_in_secs = $years . ' year(s)/' . $months . ' month(s)/' . $days . ' day(s) - ' . $hours . ':' . $mins . ':' . $secs;
|
||||
}
|
||||
|
||||
if ($negative == 1) {
|
||||
return '- ' . $time_in_secs;
|
||||
} else {
|
||||
return $time_in_secs;
|
||||
}
|
||||
}
|
||||
|
||||
sub get_cpucount {
|
||||
my $cpucount = Sys::CpuAffinity::getNumCpus() + 0;
|
||||
return ($cpucount > 0) ? $cpucount : 1;
|
||||
#my $info = Sys::Info->new();
|
||||
#my $cpu = $info->device('CPU'); # => %options );
|
||||
#print "cpuidentify:" . scalar($cpu->identify()) . "\n";
|
||||
#print "cpuidentify:" . scalar($cpu->identify()) . "\n";
|
||||
#my $cpucount = $cpu->count() + 0;
|
||||
#print "ht:" . $cpu->ht() . "\n";
|
||||
#if ($cpu->ht()) {
|
||||
# $cpucount *= 2;
|
||||
#}
|
||||
|
||||
return ($cpucount > 0) ? $cpucount : 1;
|
||||
#printf "CPU: %s\n", scalar($cpu->identify) || 'N/A';
|
||||
#printf "CPU speed is %s MHz\n", $cpu->speed || 'N/A';
|
||||
#printf "There are %d CPUs\n" , $cpu->count || 1;
|
||||
#printf "CPU load: %s\n" , $cpu->load || 0;
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
Reference in new issue