From 1529a4f1b9f3b5b9614d6c5740ae502a68d2bf0b Mon Sep 17 00:00:00 2001 From: "H. Buurman" Date: Thu, 22 May 2014 14:28:30 +0200 Subject: [PATCH 1/4] Updated readme --- README.md | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 35ae99d..b53e1fc 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,23 @@ -interfaces -========== +Perl Interfaces module. A dynamically extendable module that can interface with various file/database-readers and writers. +Currently implemented: + - Fixed width files (Flat files) + - Delimited files (RFC 4180 compliant) + - XLS files + - XLSX files + - MySQL tables +Partly implemented: + - XML + - JSON -Perl Interfaces module +Currently uses the following Perl modules (haven't separated debugging and release builds yet): +- Data::Dump +- Try::Tiny +- Moose +- Smart::Comments +- MooseX::Method::Signatures +- Readonly +- Spreadsheet::ParseExcel::S?tream +- Spreadsheet::Xlsx +- Excel::Writer::xlsx +- XML::Twig +- JSON From 3ef897c2daed1b5cdde7d597d2f943ac8ebc1bfd Mon Sep 17 00:00:00 2001 From: Herbert Buurman Date: Thu, 22 May 2014 16:18:25 +0200 Subject: [PATCH 2/4] Revert "Updated readme" This reverts commit 1529a4f1b9f3b5b9614d6c5740ae502a68d2bf0b. Conflicts: README.md --- README.md | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index e98b371..ef65195 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,5 @@ -Perl Interfaces module. A dynamically extendable module that can interface with various file/database-readers and writers. -Currently implemented: - - Fixed width files (Flat files) - - Delimited files (RFC 4180 compliant) - - XLS files - - XLSX files - - MySQL tables -Partly implemented: - - XML - - JSON +interfaces +========== Currently uses the following Perl modules (haven't separated debugging and release builds yet): - Data::Dump @@ -24,4 +16,3 @@ Currently uses the following Perl modules (haven't separated debugging and relea - File::Find::Rule V2 autodetects and loads additional modules - From 66244021e60168497d90862b91cea504b383b79b Mon Sep 17 00:00:00 2001 From: Herbert Buurman Date: Thu, 22 May 2014 16:26:42 +0200 Subject: [PATCH 3/4] Another attempt to undo the changes that went to master but had to go to v2. This time in master, and not in some detached state. --- Interfaces.pm | 576 ---------------------- Interfaces/DataTable.pm | 686 ++++++++++++++++++++++++-- Interfaces/DataTable/MySQL.pm | 474 ------------------ Interfaces/DataTable/SQLServer.pm | 322 ------------- Interfaces/DelimitedFile.pm | 591 ++++++++++++++--------- Interfaces/ExcelBinary.pm | 250 +++++----- Interfaces/ExcelX.pm | 6 +- Interfaces/FlatFile.pm | 498 +++++++++---------- Interfaces/Interface.html | 162 +++++++ Interfaces/Interface.pm | 775 ++++++++++++++++++++++++++++++ Interfaces/JSON.pm | 4 +- Interfaces/XMLFile.pm | 216 ++++----- README.md | 16 +- interfaces.t | 8 +- 14 files changed, 2393 insertions(+), 2191 deletions(-) delete mode 100644 Interfaces.pm mode change 100644 => 100755 Interfaces/DataTable.pm delete mode 100644 Interfaces/DataTable/MySQL.pm delete mode 100644 Interfaces/DataTable/SQLServer.pm mode change 100644 => 100755 Interfaces/DelimitedFile.pm mode change 100644 => 100755 Interfaces/ExcelBinary.pm mode change 100644 => 100755 Interfaces/ExcelX.pm mode change 100644 => 100755 Interfaces/FlatFile.pm create mode 100755 Interfaces/Interface.html create mode 100755 Interfaces/Interface.pm mode change 100644 => 100755 Interfaces/JSON.pm mode change 100644 => 100755 Interfaces/XMLFile.pm diff --git a/Interfaces.pm b/Interfaces.pm deleted file mode 100644 index 4657e8f..0000000 --- a/Interfaces.pm +++ /dev/null @@ -1,576 +0,0 @@ -package Interfaces; - -use Moose; # automatically turns on strict and warnings -use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater -use MooseX::Method::Signatures; -use File::Spec; -use File::Find::Rule; -use Data::Dump; -use Devel::Peek; -use List::Util; -use Carp; -use POSIX; -use constant DATATYPE_UNKNOWN => 0; # default -use constant DATATYPE_TEXT => 1; -use constant DATATYPE_DATETIME => 2; -use constant DATATYPE_NUMERIC => 16; -use constant DATATYPE_FLOATINGPOINT => 17; -use constant DATATYPE_FIXEDPOINT => 18; -use constant OVERFLOW_METHOD_ERROR => 0; -use constant OVERFLOW_METHOD_ROUND => 1; -use constant OVERFLOW_METHOD_TRUNC => 2; - -use constant DATATYPES => { - CHAR => { type => DATATYPE_TEXT }, - VARCHAR => { type => DATATYPE_TEXT }, - TEXT => { type => DATATYPE_TEXT }, - DATE => { type => DATATYPE_TEXT }, - TIME => { type => DATATYPE_TEXT }, - DATETIME => { type => DATATYPE_TEXT }, - TIMESTAMP => { type => DATATYPE_TEXT }, - TINYINT => { type => DATATYPE_NUMERIC, min => - (2**7), max => 2**8 - 1, }, - SMALLINT => { type => DATATYPE_NUMERIC, min => - (2**15), max => 2**16 - 1, }, - MEDIUMINT => { type => DATATYPE_NUMERIC, min => - (2**23), max => 2**24 - 1, }, - INT => { type => DATATYPE_NUMERIC, min => - (2**31), max => 2**32 - 1, }, - INTEGER => { type => DATATYPE_NUMERIC, min => - (2**31), max => 2**32 - 1, }, - BIGINT => { type => DATATYPE_NUMERIC, min => - (2**63), max => 2**64 - 1, }, - FLOAT => { type => DATATYPE_FLOATINGPOINT }, - DOUBLE => { type => DATATYPE_FLOATINGPOINT }, - NUMERIC => { type => DATATYPE_FIXEDPOINT }, - DECIMAL => { type => DATATYPE_FIXEDPOINT }, -}; - -BEGIN { - @Interfaces::methods = (); - $Interfaces::DEBUGMODE = 1; -} - -# General info -has 'config' => (is => 'rw', isa => 'HashRef[HashRef[HashRef[Maybe[Value]]]]', lazy_build => 1,); -has 'name' => (is => 'rw', isa => 'Maybe[Str]', lazy_build => 1,); -has 'decimalseparator' => (is => 'rw', isa => 'Str', lazy_build => 1,); -has 'thousandseparator' => (is => 'rw', isa => 'Str', lazy_build => 1,); -has 'overflow_method' => (is => 'rw', isa => 'Int', lazy_build => 1,); -# Fields info -has 'columns' => (is => 'rw', isa => 'ArrayRef[Str]', lazy_build => 1,); -has 'displayname' => (is => 'rw', isa => 'ArrayRef[Str]', lazy_build => 1,); -has 'datatype' => (is => 'rw', isa => 'ArrayRef[Str]', lazy_build => 1,); -has 'internal_datatype' => (is => 'rw', isa => 'ArrayRef[HashRef[Value]]', lazy_build => 0,); -has 'length' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); -has 'decimals' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); -has 'signed' => (is => 'rw', isa => 'ArrayRef[Maybe[Bool]]', lazy_build => 1,); -has 'allownull' => (is => 'rw', isa => 'ArrayRef[Bool]', lazy_build => 1,); -has 'default' => (is => 'rw', isa => 'ArrayRef[Maybe[Value]]', lazy_build => 1,); -has 'fieldid' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); - -sub BUILD { - my $self = shift; - my $hr_args = shift; - # Load configuration from given $dbh for interface with $name - if (exists $hr_args->{dbh} and defined $hr_args->{dbh} and exists $hr_args->{name}) { - # Multiple interfaces can be set up using a single definition. This is done using aliases. - my $hr_aliases = $hr_args->{dbh}->selectall_hashref("SELECT * FROM datarepos_alias", "tablename") - or Crash("Interface: Error fetching table aliases from repository: " . $hr_args->{dbh}->errstr); - my $repository_tablename = $hr_aliases->{$hr_args->{name}}->{use_tablename} // $hr_args->{name}; - # Fields - $self->{config}->{Fields} = $hr_args->{dbh}->selectall_hashref("SELECT * FROM datarepository WHERE tablename=? ORDER BY fieldid", "fieldname", undef, $repository_tablename) - or Crash("Interface: Error loading field information from repository: " . $hr_args->{dbh}->errstr); - # Indices - $self->{config}->{Indices} = $hr_args->{dbh}->selectall_hashref("SELECT * FROM datareposidx WHERE tablename=?", "keyname", undef, $repository_tablename) - or Crash("Interface: Error loading indices information from repository: " . $hr_args->{dbh}->errstr); - foreach my $fieldname (keys (%{$self->{config}->{Fields}})) { - $self->{config}->{Fields}->{$fieldname}->{signed} = $self->{config}->{Fields}->{$fieldname}->{signed} eq 'Y' ? 1 : 0; - $self->{config}->{Fields}->{$fieldname}->{allownull} = $self->{config}->{Fields}->{$fieldname}->{allownull} eq 'Y' ? 1 : 0; - } - # Apply retrieved configuration - $self->ReConfigureFromHash($self->config); - } ## end if (exists $hr_args->{...}) - # Initialize non-undef default values for attributes - $self->decimalseparator('.'); - $self->overflow_method(OVERFLOW_METHOD_ERROR); -} ## end sub BUILD - -method Check() { - # Check if all configuration data is valid (for Interface only) - if (!$self->has_config) { return undef; } - if (defined $Interfaces::DEBUGMODE) { - print ("Checking..."); - if ($self->has_name) { - print ($self->name); - } - print ("\n"); - } - my $meta = $self->meta; - # Check if all arrayref attributes contain the same amount of elements, use columns as leading - my $num_arrayref_elements = $#{$self->columns}; - print ("Checking if all arrayref attributes contain the same amount of elements...") if defined $Interfaces::DEBUGMODE; - foreach my $attribute ($meta->get_all_attributes) { - my $attributename = $attribute->name; - if ($attribute->{lazy_build} == 0) { next; } # Skip attributes die zonder lazy_build zijn gedefinieerd. - if ($attribute->type_constraint->name =~ /^ArrayRef/) { - if ($num_arrayref_elements != $#{$self->$attributename}) { - Crash( "Attribute [" - . $attributename - . "] does not have the same amount of elements as there are columns [" - . $#{$self->$attributename} - . "] vs [$num_arrayref_elements]" - ); - } ## end if ($num_arrayref_elements...) - } ## end if ($attribute->type_constraint...) - } ## end foreach my $attribute ($meta...) - print ("[OK]\n") if defined $Interfaces::Interface::DEBUGMODE; - # Check if all fields are accounted for ($self->fieldid is continuous) - # $self->fieldid->[0] = 1, $self->fieldid->[n] = $self->fieldid->[n-1] + 1 - print ("Checking if all fields are accounted for...") if defined $Interfaces::DEBUGMODE; - if ($self->fieldid->[0] != 1) { - Crash("Column [" . $self->columns->[0] . "] has fieldid [" . $self->fieldid->[0] . "], expected [1]. FieldIDs not continous"); - } - foreach (1 .. $num_arrayref_elements) { - if ($self->fieldid->[$_] != $self->fieldid->[$_ - 1] + 1) { - Crash("Column [" . $self->columns->[$_] . "] has fieldid [" . $self->fieldid->[$_] . "], expected [" . $_ + 1 . "]. FieldIDs not continous"); - } - } - print ("[OK]\n") if defined $Interfaces::DEBUGMODE; - # Check if all columns have a (valid) datatype - print ("Checking if all columns have a valid datatype...") if defined $Interfaces::DEBUGMODE; - if (!$self->has_datatype) { Crash("No datatypes configured."); } - foreach (0 .. $num_arrayref_elements) { - if (!defined DATATYPES->{$self->datatype->[$_]}) { - Crash("Column [" . $self->columns->[$_] . "] has unknown datatype [" . $self->datatype->[$_] . "]"); - } - } - print ("[OK]\n") if defined $Interfaces::DEBUGMODE; - # Check if all columns of type DATATYPE_TEXT have a length - # Check if all columns of type DATATYPE_FLOATINGPOINT and DATATYPE_FIXEDPOINT have defined decimals (0 is allowed, but $decimals == $length is not, at least 1 non-decimal digit has to be present) - # Check if all columns of type DATATYPE_NUMERIC have defined signed - print ("Checking if all text-columns have a length, all float/double columns have decimals and all integer columns have defined the 'signed' attribute...") if defined $Interfaces::DEBUGMODE; - foreach (0 .. $num_arrayref_elements) { - if ($self->internal_datatype->[$_]->{type} == DATATYPE_TEXT and $self->length->[$_] <= 0) { - Crash("Column [" . $self->columns->[$_] . "] has datatype [" . $self->datatype->[$_] . "] but length [" . $self->length->[$_] . "]"); - } elsif ($self->internal_datatype->[$_]->{type} > DATATYPE_NUMERIC and (!defined $self->decimals->[$_] or (($self->length->[$_] // 0) <= 0))) { - Crash("Column [" . $self->columns->[$_] . "] has datatype [" . $self->datatype->[$_] . "] but decimals,length has not been defined properly [" . $self->decimals->[$_] .',' . $self->length->[$_] . ']'); - } elsif ($self->internal_datatype->[$_]->{type} > DATATYPE_NUMERIC and ($self->decimals->[$_] == $self->length->[$_])) { - Crash("Column [" . $self->columns->[$_] . "] has datatype [" . $self->datatype->[$_] . "] with only decimals (at least 1 non-decimal is required) [" . $self->decimals->[$_] .',' . $self->length->[$_] . ']'); - } elsif ($self->internal_datatype->[$_]->{type} == DATATYPE_NUMERIC and ($self->decimals->[$_] // 0) > 0) { - Crash("Column [" . $self->columns->[$_] . "] has datatype [" . $self->datatype->[$_] . "] but has decimals"); - } - if ($self->internal_datatype->[$_]->{type} >= DATATYPE_NUMERIC and !defined $self->signed->[$_]) { - Crash("Column [" . $self->columns->[$_] . "] has datatype [" . $self->datatype->[$_] . "] but signed has not been defined"); - } - } ## end foreach (0 .. $num_arrayref_elements) - print ("[OK]\n") if defined $Interfaces::DEBUGMODE; - # Check if numeric-typed columns have numeric defaults - print("Checking if numeric-typed columns have numeric defaults: ") if defined $Interfaces::DEBUGMODE; - foreach (0 .. $num_arrayref_elements) { - # But only if allownull = false - if (defined $self->default->[$_] and $self->internal_datatype->[$_]->{type} >= DATATYPE_NUMERIC and !($self->default->[$_] eq '0' or $self->default->[$_] > 0)) { - Crash("Column [" . $self->columns->[$_] . "] has datatype [" . $self->datatype->[$_] . "] but non-numeric default [" . $self->default->[$_] . "]"); - } - } ## end foreach (0 .. $num_arrayref_elements) - print("[Done]\n") if defined $Interfaces::DEBUGMODE; - 1; -} ## end sub Check - -method ClearConfig () { - my $meta = $self->meta; - # Clear ArrayRef-type attributes (this clears ALL attribute values...including those generated by roles) - foreach ($meta->get_all_attributes) { - if ($_->type_constraint->name =~ /^ArrayRef/) { - $_->clear_value($self); - } - } -} - -method ReConfigureFromHash($hr_config !) { - my $meta = $self->meta; - $self->ClearConfig(); - if (!defined $hr_config and $self->has_config) { - Crash("Trying to reconfigure Base with empty configdata"); - } - # Reconfigure - $self->config($hr_config); - my @keys = keys (%{$hr_config->{Fields}}); - if (!@keys) { Crash("Empty config supplied"); } - # Set the columns - my $ar_Columns; - foreach my $Column (@keys) { - $ar_Columns->[$hr_config->{Fields}->{$Column}->{fieldid} - 1] = $Column; # fieldid starts at 1 - } - $self->columns($ar_Columns); - # Set all other attributes - foreach my $ColumnIndex (0 .. $#{$self->columns}) { - my $Column = $self->columns->[$ColumnIndex]; - my $hr_attributes; - foreach my $attribute ($meta->get_all_attributes) { - if ($attribute->{lazy_build} == 0) { next; } # Skip attributes die zonder lazy_build zijn gedefinieerd. - my $attributename = $attribute->name; - if ($attributename eq "columns") { next; } # Skip columns-attribute. We already did that one. - if (!defined $Column) { Crash("Undefined columnname with fieldid [" . ($ColumnIndex + 1) . "]"); } - if ($attribute->type_constraint->name =~ /^ArrayRef/) { - push (@{$self->$attributename}, $hr_config->{Fields}->{$Column}->{$attributename}); - } - } ## end foreach ($meta->get_all_attributes) - } ## end foreach my $ColumnIndex (0 ...) - # Init internal_datatype for speed (saves having to do regexes for each ReadRecord call) - foreach my $index (0 .. $#{$self->columns}) { - $self->{internal_datatype}->[$index] = DATATYPES->{$self->{datatype}->[$index]} // DATATYPE_UNKNOWN; - } - 1; -} ## end sub ReConfigureFromHash - -method MakeNewConfig() { - my $meta = $self->meta; - # Clear current config - delete $self->{config}; - my @attributes = $meta->get_all_attributes; - my @attributes_ArrayRef; - my @attributes_HashRef; - my @attributes_Scalar; - foreach my $attribute (@attributes) { - if ($attribute->name eq "columns") { next; } - given ($attribute->type_constraint->name) { - when (/^ArrayRef/) { push (@attributes_ArrayRef, $attribute); } - when (/^HashRef/) { push (@attributes_HashRef, $attribute); } - push (@attributes_Scalar, $attribute); - } - } ## end foreach my $attribute (@attributes) - foreach (@attributes_ArrayRef) { - my $attributename = $_->name; - foreach my $ColumnIndex (0 .. $#{$self->columns}) { - my $Column = $self->columns->[$ColumnIndex]; - $self->{config}->{Fields}->{$Column}->{$attributename} = $self->$attributename->[$ColumnIndex]; - } - } ## end foreach (@attributes_ArrayRef) -} ## end sub MakeNewConfig ($) - -method AddField($hr_config !) { - if (ref($hr_config) ne 'HASH') { - Crash("1st Argument passed is not a hashref"); - } - # Pre-add check - # 1 - Check if datatype is valid - if (!defined DATATYPES->{$hr_config->{datatype}}) { - Crash("Supplied datatype [$hr_config->{datatype}] is not valid"); - } - # 2 - Check if column of type CHAR|VARCHAR|TEXT have a length - # 2 - Check if column of type NUMERIC|DECIMAL have defined decimals (0 is allowed), default signed to 'Y' - # 2 - Check if column of type TINYINT|SMALLINT|MEDIUMINT|INT|BIGINT|INTEGER have defined signed - my $internal_datatype = DATATYPES->{$hr_config->{datatype}}->{type}; - given ($internal_datatype) { - when (DATATYPE_TEXT) { - if (($hr_config->{length} // 0) <= 0) { - Crash("Column [" . $hr_config->{fieldname} . "] has datatype [" . $hr_config->{datatype} . "] but length [" . $hr_config->{length} . "]"); - } - } - when ([DATATYPE_FLOATINGPOINT, DATATYPE_FIXEDPOINT]) { - if (!defined $hr_config->{decimals} or (($hr_config->{length} // 0) <= 0)) { - Crash("Column [" . $hr_config->{fieldname} . "] has datatype [" . $hr_config->{datatype} . "] but decimals,length has not been defined properly [" . $hr_config->{decimals} .',' . $hr_config->{length} . ']'); - } - $hr_config->{signed} = 'Y'; - } - when (DATATYPE_NUMERIC) { - if (!defined $hr_config->{signed}) { - Crash("Column [" . $hr_config->{fieldname} . "] has datatype [" . $hr_config->{datatype} . "] but signed has not been defined"); - } - $hr_config->{length} //= length("" . DATATYPES->{$hr_config->{datatype}}->{max}); - } - } - # 3 - Check if datatype is numeric but the default exists and is not numeric - if (defined $hr_config->{default} and $internal_datatype > DATATYPE_NUMERIC and !($hr_config->{default} eq '0' or $hr_config->{default} > 0)) { - Crash("Column [" . $hr_config->{fieldname} . "] has datatype [" . $hr_config->{datatype} . "] but non-numeric default [" . $hr_config->{default} . "]"); - } - # All ok, proceed with adding the field to the interface - # Generate field_id based on last used fieldid - $hr_config->{fieldid} = ($self->fieldid->[-1] // 0) + 1; - push(@{$self->columns}, $hr_config->{fieldname}); - my $meta = $self->meta; - foreach ($meta->get_all_attributes) { - my $attributename = $_->name; - if ($_->{lazy_build} == 0) { next; } # Skip attributes die zonder lazy_build zijn gedefinieerd. - if ($attributename eq "columns") { next; } # Skip columns-attribute. We already did that one. - if ($_->type_constraint->name =~ /^ArrayRef/) { - push (@{$self->$attributename}, $hr_config->{$attributename}); - } - } - # Custom initialization for lazy-built attributes - push(@{$self->{internal_datatype}}, DATATYPES->{$hr_config->{datatype}}); -} - -# Reduces length of $value until it fits $length,decimals, truncates from left to right (so only gets the LSB) -method fix_runlength(Int $fieldid !, $value !) { - my ($internal_datatype, $target_signed, $length, $decimals) = ($self->{internal_datatype}->[$fieldid], $self->{signed}->[$fieldid], $self->{length}->[$fieldid], $self->{decimals}->[$fieldid]); - # Translate signed = 'Y'/'N' to 1/0 - my $source_signed = $value < 0 ? 1 : 0; - $target_signed = $target_signed eq 'Y' ? 1 : 0; - # Split the value in an integer and fractional part - my $current_num_decimals = 0; - if (index($value, $self->decimalseparator) >= 0) { - $current_num_decimals = length($value) - index($value, $self->decimalseparator) - $source_signed; - } - my ($fraction, $integer) = POSIX::modf($value); - $fraction = sprintf("%.0${current_num_decimals}f", $fraction); # Fix floating point errors from POSIX::modf -#print("fix_runlength [$integer, $fraction], signed, decimals,current_num_decimals [$source_signed, $decimals, $current_num_decimals] [" . List::Util::min($length - $decimals, length($integer) - $source_signed) . "]\n"); - # Truncate - $integer = reverse(substr(reverse($integer), 0, List::Util::min($length - $decimals, length($integer) - $source_signed))) if $integer; - $fraction = substr($fraction, $source_signed + 2, List::Util::min($decimals, $current_num_decimals)) if length($fraction) > 2; -#print("fix_runlength2 [$integer, $fraction], [" . List::Util::min($length - $decimals, length($integer) - $source_signed) . "]\n"); - $value = ($source_signed ? -1 : 1) * ($integer + "0.$fraction"); -#print("fix_runlength3 [$value]\n"); - # Add trailing significant decimals - if ($decimals > 0) { - $value =~ s/\.([0-9]*)/'.' . substr($1, 0, $decimals)/e; - } - return $value; -} - -method fix_typesize(Int $fieldid !, $value !) { - my ($internal_datatype, $signed, $length, $decimals) = ($self->{internal_datatype}->[$fieldid], $self->{signed}->[$fieldid], $self->{length}->[$fieldid], $self->{decimals}->[$fieldid] // 0); - my ($minvalue, $maxvalue); - my ($minvalue_round, $maxvalue_round) = (- (10**($length - $decimals)) + (10**(-$decimals)), (10**($length - $decimals)) - (10**(-$decimals))); - # Translate signed = 'Y'/'N' to 1/0 - $signed = $signed eq 'Y' ? 1 : 0; - if ($internal_datatype->{type} == DATATYPE_NUMERIC) { - if ($signed) { - $minvalue = $internal_datatype->{min}; - $maxvalue = - $minvalue - 1; - } else { - $minvalue = 0; - $maxvalue = $internal_datatype->{max}; - } - # If the minimum or maximum value doesn't fit in $length, get the largest number that does fit in $length - if ($minvalue < $minvalue_round) { $minvalue = $minvalue_round; } - if ($maxvalue > $maxvalue_round) { $maxvalue = $maxvalue_round; } - } elsif ($internal_datatype->{type} > DATATYPE_NUMERIC) { - if ($signed) { - $minvalue = - (10**($length - $decimals)) + (10**(-$decimals)); - $maxvalue = (10**($length - $decimals)) - (10**(-$decimals)); - } else { - $minvalue = 0; - $maxvalue = (10**($length - $decimals)) - (10**(-$decimals)); - } - } -#print("Min [$minvalue] max [$maxvalue]\n"); - if ($value < $minvalue) { $value = $minvalue; } - elsif ($value > $maxvalue) { $value = $maxvalue; } - return $value; -} - -method minmax(Int $fieldid !, $value !) { - # For OVERFLOW_METHOD_ROUND, read the value as-is, then round to within respectively $datatype_size and $length,decimals - # For OVERFLOW_METHOD_TRUNC, read the value as-is, then truncate the value within respectively $length,decimals and $datatype_size - my ($internal_datatype, $signed, $length, $decimals) = ($self->{internal_datatype}->[$fieldid], $self->{signed}->[$fieldid], $self->{length}->[$fieldid], $self->{decimals}->[$fieldid] // 0); - # Translate signed = 'Y'/'N' to 1/0 -if (!defined $signed) { Crash("Not signed?!"); } - $signed = $signed eq 'Y' ? 1 : 0; - if ($self->{overflow_method} == OVERFLOW_METHOD_ERROR) { - if ($signed and $value < 0) { Crash('Value [' . $value . '] below minimum [0]'); } - my $copy_of_value = $value; - $copy_of_value =~ s/$self->{decimalseparator}//; - if (length($copy_of_value) > $length) { Crash('value [' . $value . '] too large to fit in [' . $length . '] figures'); } - } elsif ($self->{overflow_method} == OVERFLOW_METHOD_TRUNC) { - if (!$decimals) { - # Truncate to no decimals - $value = int($value); - } elsif ($decimals == $length) { - # Special case, truncate to only decimals - $value = POSIX::fmod($value, 1); - } - $value = $self->fix_runlength($fieldid, $value); - $value = $self->fix_typesize($fieldid, $value); - } elsif ($self->{overflow_method} == OVERFLOW_METHOD_ROUND) { - # First round to proper amount of decimals - $value = sprintf("%.${decimals}f", $value); - $value = $self->fix_typesize($fieldid, $value); - } else { - Crash("Unknown overflow method selected [" . $self->{overflow_method}); - } - return $value; -} - -sub Crash { - defined $Interfaces::DEBUGMODE ? Carp::confess(@_) : die(@_); -} - -sub DESTROY { - my $self = shift; - # Carp::carp("Destroying interface for [" . $self->tablename . "]\n"); -} - -# Scan for roles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own methods as aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; -} - -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } -} - -INIT { -# Automatically create accessors, _build_-functions for all attributes (including ones from roles, which are applied at this point) - my $meta = __PACKAGE__->meta; - no strict; - foreach my $build_attribute ($meta->get_all_attributes) { - my $build_attributename = $build_attribute->name; - if (!defined *{__PACKAGE__ . '::_build_' . $build_attributename}) { - *{__PACKAGE__ . '::_build_' . $build_attributename} = sub { - my $self = shift; - my $meta = $self->meta; - my $attribute = $meta->find_attribute_by_name($build_attributename); - if (!defined $attribute) { Carp::confess("Error: can't find attribute [$build_attributename]\n"); } - my $type_name = $attribute->type_constraint->name; - if ($attribute->type_constraint->is_a_type_of("ArrayRef")) { return []; } - elsif ($attribute->type_constraint->is_a_type_of("HashRef")) { return {}; } - elsif ($attribute->type_constraint->equals("Str")) { return ""; } - elsif ($attribute->type_constraint->is_a_type_of("Num")) { return 0; } - else { return undef } - }; - } ## end if (!defined *{__PACKAGE__...}) - } ## end foreach my $build_attribute... - use strict; -} - -1; - -=head1 NAME - -Interfaces::Interface - Generic data-interface between file-formats and databases - -=head1 VERSION - -This document refers to Interfaces::Interface version 0.10. - -=head1 SYNOPSIS - - use Interfaces::Interface; - my $interface = Interfaces::Interface->new(); - -=head1 C MODULES - -The C hierarchy of modules is an attempt at creating a general -method for transferring data from various file-formats and (MySQL) databases to -other file-formats and (MYSQL) databases. Currently implemented are: - -=over 4 - -=item * Interfaces::FlatFile - -=item * Interfaces::DelimitedFile - -=item * Interfaces::DataTable - -=item * Interface::ExcelBinary - -=back - -=head1 DESCRIPTION - -This module is the main module of the Interfaces-hierarchy and is the only -one that needs to be instantiated to use. All other modules add Moose::Roles to this -interface to extend funcionality. -The interface itself cannot do anything, it depends on additional modules to provide -the various read- and write-methods. -The interface can be configured using ReConfigureFromHash with a given hashref filled -with configuration data. The basic data that all interfaces require consists of the -following: - -=over 4 - -=item * a (table)name which defines the name of the interface (and is also the default -tablename used when interfacing with a (MySQL) database using Interfaces::DataTable). - -=item * an arrayref with columnnames. These are used when referencing specific columns, - and also when interfacing with a (MySQL) database. - -=item * an arrayref with (MySQL) datatypes describing the type of each column. - -=item * an arrayref with lengths describing the amount of characters (or digits for numeric -types) used for each column. - -=item * an arrayref describing the amount of digits used in the fraction of numeric types -(that support fractions) for each column. This is undefined for columns with types that -don't use fractions. - -=item * an arrayref describing whether or not a numeric type is signed. This is undefined -for columns with non-numeric types. - -=item * an arrayref describing whether a column may contain NULL (undefined) values. - -=item * an arrayref containing the default values that should be given to a column. - -=item * an arrayref containing a field-id for each column. This is not used in the -interface itself, but in the configuration of the interface to indicate the order in which -columns should be used. - -=back - -Modules which add roles can introduce other attributes that need to be supplied in the -configuration data. The DelimitedFile-module needs a delimiter and a displayname (for the -header row), and the FlatFile-module requires flatfield_start and flatfield_length-attributes. - - -=head2 Methods for C - -=over 4 - -=item * Cnew($dbh, $name);> - -Calls C's C method. Creates an unconfigured interface object. -Optionally can be supplied with an active database handle and an interface name. The -interface will automatically be configured using data from tables 'datarepository', -'datareposidx' and 'datarepos_alias' that should be present in the supplied database. -This method (BUILD) can be augmented (using Moose's "after") for each additional module -in the Interfaces-hierarchy. - -=item * C<$interface-EReConfigureFromHash($hr_config);> - -Configures the interface object with the supplied configuration. Will Carp::confess if some basic -checks pertaining the integrity of the configuration are not met. - -=item * C<$interface-ECheck();> - -Starts a more thorough check on the integrity and correctness of the currently configured interface -object. This method can be augmented (using Moose's "after") for each additional module in the -Interfaces-hierarchy. - -=back - -=head1 DEPENDENCIES - -L, L and L - -=head1 AUTHOR - -The original author is Herbert Buurman - -=head1 LICENSE - -This module is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. See L. - -=cut diff --git a/Interfaces/DataTable.pm b/Interfaces/DataTable.pm old mode 100644 new mode 100755 index 7f09ef5..8c1b2a2 --- a/Interfaces/DataTable.pm +++ b/Interfaces/DataTable.pm @@ -1,61 +1,28 @@ package Interfaces::DataTable; +# Version 2.0.0 3-1-2012 +# Copyright (C) OGD 2011-2012 #use Devel::Size; +use Smart::Comments; use Moose::Role; -use 5.010; +use MooseX::Method::Signatures; +use v5.10; +#use Devel::Peek; no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater -use Devel::Peek; - -BEGIN { - @Interfaces::DataTable::methods = qw(); -} has 'indices' => (is => 'rw', isa => 'Maybe[HashRef[ArrayRef[Str]]]', lazy_build => 1,); has 'useintable' => (is => 'rw', isa => 'ArrayRef[Bool]', lazy_build => 1,); -#has 'autoincrement' => (is => 'rw', isa => 'ArrayRef[Bool]', lazy_build => 1,); - -# Scan for roles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = (); #File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own methods as aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; -} +has 'autoincrement' => (is => 'rw', isa => 'ArrayRef[Bool]', lazy_build => 1,); -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } -} +requires qw(columns displayname datatype length decimals signed allownull default fieldid); after 'Check' => sub { my $self = shift; - print ("Checking DataTable constraints..."); # Check tablename if (!$self->has_name) { Carp::confess "Interface does not have a (table)name defined"; } - # Check if all the fields referenced in the indices (if any) actually exist +# Check if all the fields referenced in the indices (if any) actually exist my $hr_failures; if ($self->has_indices and defined $self->indices) { for my $keyname (keys (%{$self->indices})) { @@ -70,7 +37,6 @@ after 'Check' => sub { Carp::confess("Interface [" . $self->name . "] has indices defined on columns (shown above) that don't exist"); } } ## end if ($self->has_indices...) - print ("[OK]\n"); }; after 'ReConfigureFromHash' => sub { @@ -81,9 +47,639 @@ after 'ReConfigureFromHash' => sub { # Set indices my $hr_indices; foreach my $keyname (keys (%{$hr_config->{Indices}})) { - $hr_indices->{$keyname} = [split (',', $hr_config->{Indices}->{$keyname}->{keyfields})]; + $hr_indices->{$keyname} = [ map { s/^\s*(.+)\s*$/$1/; $_; } split (',', $hr_config->{Indices}->{$keyname}->{keyfields}) ]; } if (defined $hr_indices) { $self->indices($hr_indices); } }; -1; # so the require or use succeeds +# ReConfigureFromDatabase configures self using a specified table in a specified databasehandle. +# Configures self for datatable-interfacing only, all values pertaining to other interfaces are left undefined +method ReConfigureFromDatabase(Object $dbh !, Str $tablename !) { + my $meta = $self->meta; + # Clear attributes + foreach ($meta->get_attribute_list) { eval "$self->clear_" . "$_"; } + # Get columns-list from database + my $ar_ColumnInfo = $dbh->selectall_arrayref("SHOW COLUMNS FROM `$tablename`", {Slice => {}}) + or Carp::confess("Error getting column-info for [$tablename]: " . $dbh->errstr); + if (!@{$ar_ColumnInfo}) { return; } # No query results -> nothing to do + my $ar_IndexInfo = $dbh->selectall_arrayref("SHOW INDEX FROM `$tablename`", {Slice => {}}) + or Carp::confess("Error getting index-info for [$tablename]: " . $dbh->errstr); + # Start setting attributes + $self->name("$tablename"); + # Interface.pm supplies these column-attributes: + # columns, datatype, length, decimals, signed, allownull, default, fieldid + # if ($_->type_constraint->name =~ /^ArrayRef/) { + # push (@{$self->$attributename}, $hr_config->{$Column}->{$attributename}); + my $hr_indices; + my $hr_config; + foreach my $fieldid (0 .. $#$ar_ColumnInfo) { + my $column = $ar_ColumnInfo->[$fieldid]; + my $columntype; + ($columntype = $column->{Type}) =~ s/^(.*)[(]([0-9]+(?:,[0-9]+)?)[)][ ]?(.*)$/$1;$2;$3/; + my ($dbtype, $dbsize, $dbsigned) = split (';', $columntype); + my $decimals; + ($dbsize, $decimals) = split (',', ($dbsize // "0,0")); + + $hr_config->{Fields}->{$column->{Field}}->{columns} = $column->{Field}; + $hr_config->{Fields}->{$column->{Field}}->{displayname} = $column->{Field}; + $hr_config->{Fields}->{$column->{Field}}->{datatype} = uc $dbtype; + $hr_config->{Fields}->{$column->{Field}}->{length} = $dbsize; + + if ($dbtype =~ /REAL|FLOAT|DOUBLE|DECIMAL|NUMERIC/i) { + $hr_config->{Fields}->{$column->{Field}}->{decimals} = $decimals; + } + if ($dbtype =~ /(TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC)/i) { + $hr_config->{Fields}->{$column->{Field}}->{signed} = ($dbsigned eq "unsigned") ? "0" : "1"; + } + $hr_config->{Fields}->{$column->{Field}}->{allownull} = ($column->{Null} eq "YES") ? "1" : "0"; + $hr_config->{Fields}->{$column->{Field}}->{default} = $column->{Default}; + $hr_config->{Fields}->{$column->{Field}}->{fieldid} = $fieldid + 1; + $hr_config->{Fields}->{$column->{Field}}->{useintable} = 'Y'; + $hr_config->{Fields}->{$column->{Field}}->{autoincrement} = ($column->{Extra} =~ /auto_increment/i) ? 1 : 0; + } ## end foreach my $fieldid (0 .. $#$ar_ColumnInfo) + foreach (@{$ar_IndexInfo}) { + push (@{$hr_indices->{$_->{Key_name}}}, $_->{Column_name}); + } + $self->ReConfigureFromHash($hr_config); + foreach (keys (%{$hr_indices})) { + $self->{Indices}->{$_} = [@{$hr_indices->{$_}}]; + } + #$self->MakeNewConfig(); +} ## end sub ReConfigureFromDatabase ($$$) + +# CheckDatabase checks if the interface matches the table in the given database-handle, Carp::confesses any differences +# Arguments: self, $dbh +sub CheckDatabase ($$) { + my $self = shift; + my $dbh = shift; + if (!defined $dbh) { + Carp::confess "Supplied databasehandle is undefined"; + } + if (ref($dbh) ne 'DBI::db') { + Carp::confess "Supplied databasehandle is not a DBI::db handle"; + } + my $hr_columns = $dbh->selectall_hashref("SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE table_name = '" . $self->name . "'", "COLUMN_NAME") + or Carp::carp("Error fetching column info for table [" . $self->name . "] from database: " . $dbh->errstr); + if (!defined $hr_columns) { return; } + #Data::Dump::dd($hr_columns); + my @columns_not_in_database; + my @columns_not_in_interface; + my $hr_mismatches; + my @fieldids; + my $fieldid = 1; + + for (0 .. $#{$self->columns}) { + my $current_field = $self->columns->[$_]; + if ($self->useintable->[$_] eq 'Y') { + if (!exists $hr_columns->{$current_field}) { push (@columns_not_in_database, $current_field); } + else { + # The column is defined both in the interface and in the database. Let's check all the other fields + # FieldID (We need to use the newly built list of fieldid's that only include fields with useintable=Y + $fieldids[$_] = $fieldid++; + if ($hr_columns->{$current_field}->{ORDINAL_POSITION} != $fieldids[$_]) { #$self->fieldid->[$_]) { + #$hr_mismatches->{fieldid}->{$current_field} = "Interface vs DB: [" . $self->fieldid->[$_] . " vs " . $hr_columns->{$current_field}->{ORDINAL_POSITION} . "]"; + $hr_mismatches->{fieldid}->{$current_field} = "Interface vs DB: [" . $fieldids[$_] . "] vs [" . $hr_columns->{$current_field}->{ORDINAL_POSITION} . "]"; + } + my $columntype; + ($columntype = $hr_columns->{$current_field}->{COLUMN_TYPE}) =~ s/^(.*)[(]([0-9]+),?([0-9]*)[)][ ]?(.*)$/$1,$2,$3,$4/; + my ($dbtype, $dbsize, $dbdecimals, $dbsigned) = split (',', $columntype); + if (!defined $dbsize) { $dbsize = $hr_columns->{$current_field}->{NUMERIC_PRECISION}; } + # print("$current_field: Type,Size,Decimals,Signed: [$dbtype,$dbsize,$dbdecimals,$dbsigned]\n"); + if (lc ($self->datatype->[$_]) ne lc ($dbtype)) { + $hr_mismatches->{type}->{$current_field} = "Interface vs DB: [" . $self->datatype->[$_] . "] vs [$dbtype]"; + } + if ($dbtype !~ /date|time/i and $self->length->[$_] != $dbsize) + # if ($dbtype !~ /date|time|tinyint|smallint|mediumint|int|integer|bigint|float|double|real/i and $self->length->[$_] != $dbsize) + { # MySQL types DATE, TIME and numeric types do not have a size + $hr_mismatches->{size}->{$current_field} = "Interface vs DB: [" . $self->length->[$_] . "] vs [$dbsize]"; + } + if ($dbtype =~ /real|float|double|decimal/i) { + if (!defined $dbdecimals and defined $self->decimals->[$_]) { + $hr_mismatches->{decimals}->{$current_field} = "Interface vs DB: [" . $self->decimals->[$_] . "] vs NULL]"; + } elsif (defined $dbdecimals and !defined $self->decimals->[$_]) { + $hr_mismatches->{decimals}->{$current_field} = "Interface vs DB: [NULL vs [$dbdecimals]"; + } elsif ($self->decimals->[$_] != $dbdecimals) { + $hr_mismatches->{decimals}->{$current_field} = "Interface vs DB: [" . $self->decimals->[$_] . "] vs [$dbdecimals]"; + } + } ## end if ($dbtype =~ /real|float|double|decimal/i) + $dbsigned = ($dbsigned // '') eq '' ? 'Y' : $dbsigned; + # print("dbsigned [$dbsigned], self->signed [" . $self->signed->[$_] . "]\n"); + if ( + $dbtype =~ /TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC/i + and ( ($dbsigned eq 'Y' and $self->signed->[$_] == 0) + or ($dbsigned eq 'unsigned' and $self->signed->[$_] == 1)) + ) + { + $hr_mismatches->{signed}->{$current_field} = "Interface vs DB: [" . $self->signed->[$_] . " vs $dbsigned]"; + } ## end if ($dbtype =~ /TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC/i...) + if (substr ($hr_columns->{$current_field}->{IS_NULLABLE}, 0, 1) ne ($self->allownull->[$_] ? "Y" : "N")) { + $hr_mismatches->{allownull}->{$current_field} = "Interface vs DB: [" . $self->allownull->[$_] . "] vs [$hr_columns->{$current_field}->{IS_NULLABLE}]"; + } + if (defined $self->default->[$_] or defined $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { + if (!defined $self->default->[$_] and defined $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { + $hr_mismatches->{default}->{$current_field} = "Interface vs DB: NULL vs [$hr_columns->{$current_field}->{COLUMN_DEFAULT}]"; + } elsif (defined $self->default->[$_] and !defined $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { + $hr_mismatches->{default}->{$current_field} = "Interface vs DB: [" . $self->default->[$_] . "] vs NULL"; + } elsif ($self->default->[$_] ne $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { + $hr_mismatches->{default}->{$current_field} = "Interface vs DB: [" . $self->default->[$_] . "] vs [$hr_columns->{$current_field}->{COLUMN_DEFAULT}]"; + } + } ## end if (defined $self->default...) + } ## end else [ if (!exists $hr_columns...)] + } ## end if ($self->useintable->...) + } ## end for (0 .. $#{$self->columns...}) + foreach my $dbcolumn (keys (%{$hr_columns})) { + if (!scalar grep { $_ eq $dbcolumn } @{$self->columns}) { + push (@columns_not_in_interface, $dbcolumn); + } + } + + my $ar_indices = $dbh->selectall_arrayref("SHOW INDEX FROM " . $self->name, {Slice => {}}) + or Carp::carp("Error fetching index info for table [" . $self->name . "] from database: " . $dbh->errstr); + # Convert the array of (possibly) multiple rows with the same Key_name (but different Column_name) to a single array of Column_names + my $hr_indices = {}; + my @keys_not_in_database; + my @keys_not_in_interface; + foreach (@{$ar_indices}) { + push (@{$hr_indices->{$_->{Key_name}}->{keyfields}}, $_->{Column_name}); + } + if ($self->has_indices) { + foreach my $current_index (keys (%{$self->indices})) { + if (!exists $hr_indices->{$current_index}) { push (@keys_not_in_database, $current_index); } + else { + my $keyfields = join(',', @{$self->{indices}->{$current_index}}); + if ($keyfields ne join (',', @{$hr_indices->{$current_index}->{keyfields}})) { + $hr_mismatches->{indices}->{$current_index} = "Interface vs DB: [" . $keyfields . " vs " . join (',', @{$hr_indices->{$current_index}->{keyfields}}) . "]"; + } + } ## end else [ if (!exists $hr_indices...)] + } ## end foreach my $current_index (...) + } + foreach my $current_index (keys (%{$hr_indices})) { + if (!defined $self->indices or !exists $self->indices->{$current_index}) { push (@keys_not_in_interface, $current_index); } + } + + if (@columns_not_in_database) { + print ("Columns not in database: " . join (',', @columns_not_in_database) . "\n"); + } + if (@columns_not_in_interface) { + print ("Columns not in interface: " . join (',', @columns_not_in_interface) . "\n"); + } + if (@keys_not_in_database) { + print ("Keys not in database: " . join (',', map { "$_: [" . join (',', @{$hr_indices->{$_}->{keyfields}}) . "]" } @keys_not_in_database) . "\n"); + } + if (@keys_not_in_interface) { + print ("Keys not in interface: " . join (',', map { "$_: [" . join (',', @{$hr_indices->{$_}->{keyfields}}) . "]" } @keys_not_in_interface) . "\n"); + } + if (scalar keys (%{$hr_mismatches})) { + Data::Dump::dd($hr_mismatches); + Carp::confess("There were mismatches"); + } +} ## end sub CheckDatabase ($$) + +# CreateInsertQuery Returns an SQL statement inserting fields @ with value ? into $self->{name} +# Arguments: self, $ar_fieldnames +sub CreateInsertQuery ($$) { + my $self = shift; + my $ar_columns = shift; + if (ref($ar_columns) ne 'ARRAY') { + Carp::confess "1st argument is not an arrayref"; + } + if (!$self->has_name) { + Carp::confess "Cannot create INSERT query for object without (table)name"; + } + return "INSERT INTO " . $self->name . "(" . join (",", @{$ar_columns}) . ") VALUES (" . join (",", map ("?", @{$ar_columns})) . ") "; +} ## end sub CreateInsertQuery ($$) + +# CreateUpdateQuery Returns an SQL statement updating table $self->{name} setting fields @ to ? +# Arguments: self, $ar_fieldnames +sub CreateUpdateQuery ($$) { + my $self = shift; + my $ar_columns = shift; + if (ref($ar_columns) ne 'ARRAY') { + Carp::confess "1st argument is not an arrayref"; + } + return "UPDATE " . $self->{name} . " SET " . join (",", map ($_ . "=?", @{$ar_columns})) . " "; +} + +# CreateInsertUpdateQuery returns an SQL statement inserting fields @{$_[1]} with value ? into table $_[0] +# On duplicate key values, all non-key values are updated with ? +sub CreateInsertUpdateQuery ($$) { + my $self = shift; + my $ar_columns = shift; + if (ref($ar_columns) ne 'ARRAY') { + Carp::confess "1st argument is not an arrayref"; + } + my $ar_keycolumns = $self->indices->{PRIMARY}; + if ($#$ar_keycolumns == -1) { Carp::confess("No primary key configured, CreateInsertUpdateQuery not possible"); } + # Escape keycolumnnames to allow columns named with reserved words + @{$ar_keycolumns} = map { !/^[`].*[`]$/ ? "`$_`" : $_; } @{$ar_keycolumns}; + my @nonkeyfields = SleLib::Difference($ar_columns, $ar_keycolumns); + return $self->CreateInsertQuery($ar_columns) . " ON DUPLICATE KEY UPDATE " . join (",", map ("$_=Values($_)", @nonkeyfields)) . " "; +} ## end sub CreateInsertUpdateQuery ($$) + +# CreateSelectQuery Returns an SQL statement selecting fields @ from table $ +# Arguments: TableName, @fieldnames, %modifications +# %modifications consists of key-value pairs as follows: "FieldName" => "WhatEverYouWant" +# This will change "FieldName" into "WhatEverYouWant AS FieldName" +sub CreateSelectQuery { + my $self = shift; + my $ar_columns = shift; + if (ref($ar_columns) ne 'ARRAY') { + Carp::confess "1st argument is not an arrayref"; + } + my $hr_modifications = shift; + if (ref($hr_modifications) ne 'HASH') { + Carp::confess "1st argument is not a hashref"; + } + my @Columns = map { $hr_modifications->{$_} ? "$hr_modifications->{$_} AS $_" : $_; } @{$ar_columns}; + return "SELECT " . join (",", @Columns) . " FROM " . $self->{name}; +} ## end sub CreateSelectQuery ($$$) + +# TableDiff returns records uit Source that differ in values from non-keyfields compared to Target +# Source and Target tables need to be compatible with this interface (naturally) +# Arguments: dbh, Source_Tablename, Target_Tablename, ar_Fields_to_compare (these need to contain all the primary keyfields) +# Options consist of: +# mode = array | hash # Defaults to array. Indicates the use of selectall_arrayref or selectall_hashref. Using mode=hash requires the option "keys" to be specified too +# keys = [columns] # Arrayref of one or more keys used with mode=hash +# debug = 1 # Enable debug-mode +# null_for_match # Selects NULL for each column that matches and only shows the value of target.column if it differs +method TableDiff ($dbh !, Str $source_tablename !, Str $target_tablename !, ArrayRef $ar_fields_to_compare !, HashRef $hr_options ?) { + my $ar_keycolumns = $self->indices->{PRIMARY}; + if ($#$ar_keycolumns == -1) { Carp::confess("No primary key configured, TableDiff not possible"); } + my $ar_nonkeyfields = [ grep { !($_ ~~ $ar_keycolumns); } @{$ar_fields_to_compare} ]; # preserve order + # Escape fields + @{$ar_keycolumns} = map { !/^[`].*[`]$/ ? "`$_`" : $_; } @{$ar_keycolumns}; + @{$ar_nonkeyfields} = map { !/^[`].*[`]$/ ? "`$_`" : $_; } @{$ar_nonkeyfields}; + my $query; + if ($hr_options->{null_for_match}) { + $query = "SELECT " . join(",\n", @{$ar_keycolumns}) . ",\n" . join(",\n", map { "NULLIF(target.${_}, source.${_}) AS $_"; } @{$ar_nonkeyfields} ); + } else { + $query = "SELECT target.* "; + } + $query .= " + FROM $source_tablename AS source + LEFT JOIN $target_tablename AS target USING (" . join(',', @{$ar_keycolumns}) . ") + WHERE NOT ISNULL(COALESCE( + " . join(',', map { "NULLIF(target.${_}, source.${_})"; } @{$ar_nonkeyfields} ) . + "))"; + $hr_options->{query} = $query . ' ' . ($hr_options->{suffix} // ''); + return ReadData($self, $dbh, $hr_options); +} + +# CreateTable +# Returns a string containing the CREATE TABLE statement +sub CreateTable { + my $self = shift; + my $returnstring = "CREATE TABLE "; + my @columnnames; + $returnstring .= "`" . $self->name . "` (\n"; + @columnnames = map { "`$_`"; } @{$self->columns}; + foreach (0 .. $#{$self->columns}) { + $returnstring .= " $columnnames[$_] " . $self->datatype->[$_]; + if ($self->datatype->[$_] !~ /^(DATE|TIME|DATETIME|TEXT|MONEY|BIT)$/i) { + $returnstring .= sprintf ("(%s", $self->length->[$_]); + if (($self->decimals->[$_] // 0) > 0) { + $returnstring .= sprintf (",%s", $self->{decimals}[$_]); + } + $returnstring .= ")"; + } + if (($self->datatype->[$_] =~ /^(TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC)$/i) and (($self->signed->[$_] // 1) == 0)) { + $returnstring .= " UNSIGNED"; + } + if ($self->allownull->[$_] eq 'N') { + $returnstring .= " NOT NULL"; + } + if (defined $self->default->[$_]) { + if ($self->datatype->[$_] =~ /(VARCHAR|CHAR|DATE|TIME|DATETIME)/i) { + $returnstring .= sprintf (" DEFAULT '%s'", $self->default->[$_]); + } else { + $returnstring .= sprintf (" DEFAULT %s", $self->default->[$_]); + } + } ## end if (defined $self->default...) + if ($self->autoincrement->[$_]) { + $returnstring .= " AUTO_INCREMENT"; + } + if ($_ < $#{$self->columns}) { + $returnstring .= ",\n"; + } + } ## end foreach (0 .. $#{$self->columns...}) + # Index opbouwen + if ($self->has_indices) { + foreach (keys (%{$self->indices})) { + if (/PRIMARY/) { + $returnstring .= sprintf (",\n $_ KEY (%s) ", join (',', map { "`$_`"; } @{$self->indices->{$_}})); + } else { + $returnstring .= sprintf (",\n KEY $_ (%s) ", $self->indices->{$_}); + } + } ## end foreach (keys (%{$self->indices...})) + } ## end if ($self->has_indices) + $returnstring .= "\n)"; + $returnstring .= " ENGINE=InnoDB;\n"; + Data::Dump::dd($returnstring) if $Interfaces::Interface::DEBUGMODE; + return $returnstring; +} ## end sub CreateTable + +# WriteData ($dbhandle, $ar_data, $hr_options) +# Options consist of: Columns = [columns..] # Insert only these columns +# Update = 0|1 # use "INSERT...ON DUPLICATE KEY UPDATE"-statements +# Ignore = 0|1 # Use INSERT IGNORE, cannot be used together update +# Naturally, columns must have the useintable-attribute set to 'Y' +sub WriteData { + my ($self, $dbh, $ar_data, $hr_options) = @_; + if (!defined $dbh) { + Carp::confess "Database-handle is undefined"; + } + if (ref($dbh) ne 'DBI::db') { + Carp::confess "Supplied databasehandle is not a DBI::db handle"; + } + if (!defined $ar_data) { return; } + if (ref($ar_data) ne 'ARRAY') { + Carp::confess "1st argument is not an arrayref"; + } + my $returnvalue = 0; + my $ar_Insert_Columns = (defined $hr_options->{Columns}) ? $hr_options->{Columns} : $self->columns; + my $ar_Insert_Columns_Escaped; + my @a_insert_columns; # SELF + my $hr_column_id_translation = {}; # From SELF to QUERY + foreach my $ColumnName (@{$ar_Insert_Columns}) { + my $ColumnIndex = SleLib::IndexOf($ColumnName, @{$self->columns}); + if ($self->useintable->[$ColumnIndex] eq 'Y' or $self->useintable->[$ColumnIndex] eq '1') { + push (@a_insert_columns, $ColumnIndex); + $hr_column_id_translation->{$ColumnIndex} = $#a_insert_columns; + } else { + if ($hr_options->{debug}) { Carp::carp("Specified column [$ColumnName] is has useintable=N, skipping"); } + } + } + $ar_Insert_Columns = [ map { $self->{columns}->[$_]; } @a_insert_columns ]; + my $Query_Insert; + # Escape columnnames to allow columns named with reserved words + @{$ar_Insert_Columns_Escaped} = map {"`$_`"} @{$ar_Insert_Columns}; + if ($hr_options->{Update}) { + $Query_Insert = $self->CreateInsertUpdateQuery($ar_Insert_Columns_Escaped); + } else { + $Query_Insert = $self->CreateInsertQuery($ar_Insert_Columns_Escaped); + if ($hr_options->{Ignore}) { + $Query_Insert =~ s/INSERT/INSERT IGNORE/; + } + } ## end else [ if ($hr_options->{Update...})] + $Query_Insert = $dbh->prepare($Query_Insert) or Carp::confess("Error preparing Insert-query: " . $dbh->errstr); + if (!defined $Query_Insert) { return; } + foreach my $hr_record (@{$ar_data}) { ### Writing [===[%] ] + my @a_values = SleLib::GetHashValues($ar_Insert_Columns, $hr_record); + if (defined $hr_options->{debug}) { + Data::Dump::dd($hr_record); + } + foreach (@a_insert_columns) { + if (!defined $a_values[$hr_column_id_translation->{$_}] and defined $self->{default}->[$_]) { + $a_values[$hr_column_id_translation->{$_}] = $self->{default}->[$_]; + } + } + if (defined $hr_options->{debug}) { + print("Values:\n"); + Data::Dump::dd(@a_values); + } + my $query_result = $Query_Insert->execute(@a_values); + if (!defined $query_result) { + Data::Dump::dd($Query_Insert->{Statement}); + Data::Dump::dd($hr_record); + Carp::confess("Error inserting values into " . $self->name . ": " . $dbh->errstr); + } else { + $returnvalue += $query_result; + } + } ## end foreach my $hr_record (@{$ar_data...}) + return $returnvalue; +} ## end sub WriteData + +# ReadData ($dbhandle, $hr_options) +# Options consist of: columns = [ columns.. ] # Select only these columns +# modifications = { column => function, .. } # Like CreateSelectQuery +# suffix = " WHERE ..." # Gets appended to the query returned by CreateSelectQuery +# parameters = [ parameter1, parameter2, ..] # Array of parameters to be supplied to the query +# query = "SELECT..." # Overrides everything (except parameters) and uses this query instead of creating one. +# mode = array | hash # Defaults to array. Indicates the use of selectall_arrayref or selectall_hashref. Using mode=hash requires the option "keys" to be specified too +# keys = [columns] # Arrayref of one or more keys used with mode=hash +# debug = 1 # Enable debug-mode +sub ReadData ($$$) { + my ($self, $dbh, $hr_options) = @_; + if (!defined $dbh) { + Carp::confess("Database-handle is undefined"); + } + if (ref($dbh) ne 'DBI::db') { + Carp::confess "Supplied databasehandle is not a DBI::db handle"; + } + if (ref($hr_options // {}) ne 'HASH') { + Carp::confess "2nd argument is not a hashref"; + } + if (!exists $hr_options->{mode}) { + $hr_options->{mode} = "array"; + } + my $ar_Select_Columns; + if (!exists $hr_options->{query}) { + #Make a shallow copy, otherwise splicing ignored columns tampers with the object's columns-attribute + my $ar_Select_Columns = [@{(defined $hr_options->{columns}) ? $hr_options->{columns} : $self->columns}]; + my @Ignore_Columns; + foreach my $ColumnName (@{$ar_Select_Columns}) { + if ($hr_options->{debug}) { print("Processing [$ColumnName]\n"); } + my $ColumnIndex = SleLib::IndexOf($ColumnName, @{$self->columns}); + if ($ColumnIndex == -1 or $self->useintable->[$ColumnIndex] eq 'N') { + if ($hr_options->{debug}) { Data::Dump::dd($self); } + Carp::confess("Specified column [$ColumnName] at index [$ColumnIndex] does not exist or has useintable=N, skipping"); + push (@Ignore_Columns, $ColumnIndex); # Queue for deletion from $ar_Insert_Columns + } + } ## end foreach my $ColumnName (@{$ar_Select_Columns...}) + foreach (0 .. $#Ignore_Columns) { splice (@{$ar_Select_Columns}, $Ignore_Columns[$_] - $_, 1); } # Delete from $ar_Insert_Columns + + if ($hr_options->{debug}) { Data::Dump::dd($ar_Select_Columns); } + + # Escape columnnames to allow columns named with reserved words + @{$ar_Select_Columns} = map {"`$_`"} @{$ar_Select_Columns}; + # Escape columnname-keys in $hr_options->{modifications} + foreach (keys (%{$hr_options->{modifications}})) { + $hr_options->{modifications}->{"`$_`"} = $hr_options->{modifications}->{$_}; + delete $hr_options->{modifications}->{$_}; + } + $hr_options->{query} = $self->CreateSelectQuery($ar_Select_Columns, $hr_options->{modifications}) . " " . ($hr_options->{suffix} // ""); + if ($hr_options->{debug}) { Data::Dump::dd($hr_options->{query}); } + } ## end if (!exists $hr_options...) + + #Data::Dump::dd($hr_options); + my $r_data; + # can be either hr or ar + if ($hr_options->{mode} eq "array") { + if (exists $hr_options->{parameters} and scalar @{$hr_options->{parameters}} > 0) { + $r_data = $dbh->selectall_arrayref($hr_options->{query}, {Slice => {}}, @{$hr_options->{parameters}}) + or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); + } else { + $r_data = $dbh->selectall_arrayref($hr_options->{query}, {Slice => {}}) + or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); + } + # Trim alle textfields, delete all empty fields to save memory + foreach my $hr_record (@{$r_data}) { + my @delete_these_columns = (); + foreach my $column (keys %{$hr_record}) { + if (!defined $hr_record->{$column}) { + push(@delete_these_columns, $column); + next; + } + my $ColumnIndex = SleLib::IndexOf($column, @{$self->columns}); + if ($self->datatype->[$ColumnIndex] =~ /^(CHAR|VARCHAR|TEXT)$/) { + $hr_record->{$column} =~ s/^([ ]*)(.*?)([ ]*)$/$2/; # Trim + if ($hr_record->{$column} eq '') { + push(@delete_these_columns, $column); + } + } + } + foreach my $column (@delete_these_columns) { + delete $hr_record->{$column}; + } + } + } elsif ($hr_options->{mode} eq "hash") { + if (!exists $hr_options->{keys}) { + Carp::confess("No keys given for hash-mode query"); + } + if (exists $hr_options->{parameters} and scalar @{$hr_options->{parameters}} > 0) { + $r_data = $dbh->selectall_hashref($hr_options->{query}, $hr_options->{keys}, undef, @{$hr_options->{parameters}}) + or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); + } else { + $r_data = $dbh->selectall_hashref($hr_options->{query}, $hr_options->{keys}) + or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); + } + # TODO: Trim all textfields + } else { + Carp::confess("Unknown mode [$hr_options->{mode}] given for DataTableRead"); + } + + # Fix double/floats to not be returned as PV '0.00', but as NV + if (!defined $hr_options->{query} and $hr_options->{mode} eq "array") { + foreach my $hr_record (@{$r_data}) { + foreach my $ColumnIndex (0 .. $#{$self->columns}) { + my $ColumnName = $self->columns->[$ColumnIndex]; + if (defined $hr_record->{$ColumnName} and $self->datatype->[$ColumnIndex] =~ /^(?:FLOAT|DOUBLE|DECIMAL|NUMERIC|DEC|FIXED)$/) { + my $oldvalue = $hr_record->{$ColumnName}; + delete $hr_record->{$ColumnName}; + $hr_record->{$ColumnName} = 0 + $oldvalue; + } + } + } + } + + #print("Returning size: [" . Devel::Size::total_size($r_data) . "]\n"); + return $r_data; +} ## end sub ReadData ($$$) + +1; + +=head1 NAME + +Interfaces::DataTable - MySQL database extension to Interfaces::Interface + +=head1 VERSION + +This document refers to Interfaces::DataTable version 1.0.0. + +=head1 SYNOPSIS + + use Interfaces::Interface; + my $interface = Interfaces::Interface->new(); + $interface->ReConfigureFromHash($hr_config); + my $ar_data = $interface->DataTable_ReadData($dbh); + $interface->DataTable_WriteData($dbh, $ar_data); + +=head1 DESCRIPTION + +This module extends the Interfaces::Interface with the capabilities to read from - and +write to MySQL tables. + +=head2 Attributes for C + +=over 4 + +=item * C + +=item * C + +=item * C + +=back + +=head2 Methods for C + +=over 4 + +=item * C<$interface-EReConfigureFromDatabase($dbh, $tablename);> + +Configures the Interface-object from an existing table in the database instead of a supplied $hr_config. + +=item * C<$interface-ECheckDatabase($dbh);> + +Checks if the table with $self->tablename exists in the database and has a configuration compatible to the +configuration of the interface-object. Calls Carp::confess if discrepancies are found (after printing those +discrepancies to stdout). + +=item * C<$interface-ECreateInsertQuery($ar_columnnames);> + +Returns a string with an INSERT-query created for $self->tablename and the supplied $ar_columnnames. + +=item * C<$interface-ECreateUpdateQuery($ar_columnnames);> + +Returns a string with an UPDATE-query created for $self->tablename and the supplied $ar_columnnames. + +=item * C<$interface-ECreateInsertUpdateQuery($ar_columnnames);> + +Returns a string with an INSERT ON DUPLICATE KEY UPDATE-query created for $self->tablename and the supplied +$ar_columnnames. + +=item * C<$interface-ECreateSelectQuery($ar_columnnames, $hr_modifications);> + +Returns a string with a SELECT-query created for $self->tablename and the supplied $ar_columnnames. For each +columnname that is listed as a key in $hr_modifications, the accompagning value in $hr_modifications is used +instead. For example: + +$interface->CreateSelectQuery(['foo'], { foo => 'bar(foo)' }) +will result in: 'SELECT foo FROM tablename' + +$interface->CreateSelectQuery(['foo'], { foo => 'bar(foo)' }) +will result in: 'SELECT bar(foo) AS foo FROM tablename' + +=item * C<$interface-ECreateTable();> + +Returns a string with a CREATE TABLE-query that creates a table with a configuration equivalent with the +configuration of the interface-object. + +=item * C<$interface-EReadData($dbh, $hr_options);> + +Options consist of: columns = [columns..] # Select only these columns + modifications = { column => replacement, ..} # Like CreateSelectQuery + suffix = " WHERE ..." # Gets appended to the query returned by CreateSelectQuery + parameters = [parameter1, parameter2, ..] # Arrayref of parameters to be supplied to the query + query = "SELECT..." # Overrides everything (except parameters) and uses this query instead of creating one. + mode = array | hash # Defaults to array. Indicates the use of selectall_arrayref or selectall_hashref. Using mode=hash requires the option "keys" to be specified too + keys = [columns] # Arrayref of one or more keys used with mode=hash + +Reads data from $self->tablename in $dbh and the supplied (optional) options. Returns an arrayref with a +hashref per record. + +=item * C<$interface-EWriteData($dbh, $ar_data, $hr_options);> + +Options consist of: Columns = [columns..] # Insert only these columns + Update = 0|1 # use "INSERT...ON DUPLICATE KEY UPDATE"-statements + Ignore = 0|1 # Use INSERT IGNORE, cannot be used together with Update + +Only writes columns with attribute useintable[n] ne 'N'. + +=back + +=head1 DEPENDENCIES + +L, L, L and a (DBI::db) MySQL database. + +=head1 AUTHOR + +The original author is Herbert Buurman + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. See L. + +=cut + diff --git a/Interfaces/DataTable/MySQL.pm b/Interfaces/DataTable/MySQL.pm deleted file mode 100644 index 3aed2e6..0000000 --- a/Interfaces/DataTable/MySQL.pm +++ /dev/null @@ -1,474 +0,0 @@ -package Interfaces::DataTable::MySQL; - -#use Devel::Size; -use Moose::Role; -use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater -use Devel::Peek; -use MooseX::Method::Signatures; - -BEGIN { - @Interfaces::DataTable::MySQL::methods = qw(ReadData WriteData ReConfigureFromDatabase CreateInsertQuery CreateSelectQuery CreateUpdateQuery CreateTable); -} - -# Scan for roles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own methods as aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; -} - -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } -} - -use strict; - -#requires qw(columns name displayname datatype length decimals signed allownull default fieldid autoincrement indices useintable); - -# ReConfigureFromDatabase configures self using a specified table in a specified databasehandle. -# Configures self for datatable-interfacing only, all values pertaining to other interfaces are left undefined -method ReConfigureFromDatabase ($dbh !, Str $tablename !) { - if (!defined $dbh) { - Carp::confess "Supplied databasehandle is undefined"; - } - my $meta = $self->meta; - # Clear attributes - foreach ($meta->get_attribute_list) { eval "$self->clear_" . "$_"; } - # Get columns-list from database - my $ar_ColumnInfo = $dbh->selectall_arrayref("SHOW COLUMNS FROM `$tablename`", {Slice => {}}) - or Carp::confess("Error getting column-info for [$tablename]: " . $dbh->errstr); - if (!@{$ar_ColumnInfo}) { return; } # No query results -> nothing to do - my $ar_IndexInfo = $dbh->selectall_arrayref("SHOW INDEX FROM `$tablename`", {Slice => {}}) - or Carp::confess("Error getting index-info for [$tablename]: " . $dbh->errstr); - # Start setting attributes - $self->name("$tablename"); - # Interface.pm supplies these column-attributes: - # columns, datatype, length, decimals, signed, allownull, default, fieldid - # if ($_->type_constraint->name =~ /^ArrayRef/) { - # push (@{$self->$attributename}, $hr_config->{$Column}->{$attributename}); - my $hr_indices; - foreach my $fieldid (0 .. $#$ar_ColumnInfo) { - my $column = $ar_ColumnInfo->[$fieldid]; - my $columntype; - ($columntype = $column->{Type}) =~ s/^(.*)[(]([0-9]+(?:,[0-9]+)?)[)][ ]?(.*)$/$1;$2;$3/; - my ($dbtype, $dbsize, $dbsigned) = split (';', $columntype); - my $decimals; - ($dbsize, $decimals) = split (',', ($dbsize // "0,0")); - - push (@{$self->{columns}}, $column->{Field}); - push (@{$self->{displayname}}, $column->{Field}); - push (@{$self->{datatype}}, uc $dbtype); - push (@{$self->{length}}, $dbsize); - if ($dbtype =~ /real|float|double|decimal/i) { - push (@{$self->{decimals}}, $decimals); - } - if ($dbtype =~ /(TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC)/i) { - push (@{$self->{signed}}, ($dbsigned eq "unsigned") ? "0" : "1"); - } - push (@{$self->{allownull}}, ($column->{Null} eq "YES") ? "1" : "0"); - push (@{$self->{default}}, $column->{Default}); - push (@{$self->{fieldid}}, $fieldid + 1); # FieldID is 1-based - push (@{$self->{useintable}}, "Y"); # Fields from a table are automatically used in a table :) - push (@{$self->{autoincrement}}, ($column->{Extra} =~ /auto_increment/i) ? 1 : 0); - } ## end foreach my $fieldid (0 .. $#$ar_ColumnInfo) - foreach (@{$ar_IndexInfo}) { - push (@{$hr_indices->{$_->{Key_name}}}, $_->{Column_name}); - } - print ("DEBUG KEYBUILD\n"); - Data::Dump::dd($hr_indices); - foreach (keys (%{$hr_indices})) { - $self->{config}->{Indices}->{$_} = [@{$hr_indices->{$_}}]; - } - $self->MakeNewConfig(); -} ## end sub ReConfigureFromDatabase ($$$) - -# CheckDatabase checks if the interface matches the table in the given database-handle, Carp::confesses any differences -# Arguments: self, $dbh -method CheckDatabase ($dbh !) { - if (!defined $dbh) { - Carp::confess "Supplied databasehandle is undefined"; - } - my $hr_columns = $dbh->selectall_hashref("SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE table_name = '" . $self->name . "'", "COLUMN_NAME") - or Carp::carp("Error fetching column info for table [" . $self->name . "] from database: " . $dbh->errstr); - if (!defined $hr_columns) { return; } - #Data::Dump::dd($hr_columns); - my @columns_not_in_database; - my @columns_not_in_interface; - my $hr_mismatches; - my @fieldids; - my $fieldid = 1; - - for (0 .. $#{$self->columns}) { - my $current_field = $self->columns->[$_]; - if ($self->useintable->[$_] eq 'Y') { - if (!exists $hr_columns->{$current_field}) { push (@columns_not_in_database, $current_field); } - else { - # The column is defined both in the interface and in the database. Let's check all the other fields - # FieldID (We need to use the newly built list of fieldid's that only include fields with useintable=Y - $fieldids[$_] = $fieldid++; - if ($hr_columns->{$current_field}->{ORDINAL_POSITION} != $fieldids[$_]) { #$self->fieldid->[$_]) { - #$hr_mismatches->{fieldid}->{$current_field} = "Interface vs DB: [" . $self->fieldid->[$_] . " vs " . $hr_columns->{$current_field}->{ORDINAL_POSITION} . "]"; - $hr_mismatches->{fieldid}->{$current_field} = "Interface vs DB: [" . $fieldids[$_] . "] vs [" . $hr_columns->{$current_field}->{ORDINAL_POSITION} . "]"; - } - my $columntype; - ($columntype = $hr_columns->{$current_field}->{COLUMN_TYPE}) =~ s/^(.*)[(]([0-9]+),?([0-9]*)[)][ ]?(.*)$/$1,$2,$3,$4/; - my ($dbtype, $dbsize, $dbdecimals, $dbsigned) = split (',', $columntype); - if (!defined $dbsize) { $dbsize = $hr_columns->{$current_field}->{NUMERIC_PRECISION}; } - # print("$current_field: Type,Size,Decimals,Signed: [$dbtype,$dbsize,$dbdecimals,$dbsigned]\n"); - if (lc ($self->datatype->[$_]) ne lc ($dbtype)) { - $hr_mismatches->{type}->{$current_field} = "Interface vs DB: [" . $self->datatype->[$_] . "] vs [$dbtype]"; - } - if ($dbtype !~ /date|time/i and $self->length->[$_] != $dbsize) - # if ($dbtype !~ /date|time|tinyint|smallint|mediumint|int|integer|bigint|float|double|real/i and $self->length->[$_] != $dbsize) - { # MySQL types DATE, TIME and numeric types do not have a size - $hr_mismatches->{size}->{$current_field} = "Interface vs DB: [" . $self->length->[$_] . "] vs [$dbsize]"; - } - if ($dbtype =~ /real|float|double|decimal/i) { - if (!defined $dbdecimals and defined $self->decimals->[$_]) { - $hr_mismatches->{decimals}->{$current_field} = "Interface vs DB: [" . $self->decimals->[$_] . "] vs NULL]"; - } elsif (defined $dbdecimals and !defined $self->decimals->[$_]) { - $hr_mismatches->{decimals}->{$current_field} = "Interface vs DB: [NULL vs [$dbdecimals]"; - } elsif ($self->decimals->[$_] != $dbdecimals) { - $hr_mismatches->{decimals}->{$current_field} = "Interface vs DB: [" . $self->decimals->[$_] . "] vs [$dbdecimals]"; - } - } ## end if ($dbtype =~ /real|float|double|decimal/i) - $dbsigned = ($dbsigned // '') eq '' ? 'Y' : $dbsigned; - # print("dbsigned [$dbsigned], self->signed [" . $self->signed->[$_] . "]\n"); - if ( - $dbtype =~ /TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC/i - and ( ($dbsigned eq 'Y' and $self->signed->[$_] == 0) - or ($dbsigned eq 'unsigned' and $self->signed->[$_] == 1)) - ) - { - $hr_mismatches->{signed}->{$current_field} = "Interface vs DB: [" . $self->signed->[$_] . " vs $dbsigned]"; - } ## end if ($dbtype =~ /TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC/i...) - if (substr ($hr_columns->{$current_field}->{IS_NULLABLE}, 0, 1) ne ($self->allownull->[$_] ? "Y" : "N")) { - $hr_mismatches->{allownull}->{$current_field} = "Interface vs DB: [" . $self->allownull->[$_] . "] vs [$hr_columns->{$current_field}->{IS_NULLABLE}]"; - } - if (defined $self->default->[$_] or defined $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { - if (!defined $self->default->[$_] and defined $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { - $hr_mismatches->{default}->{$current_field} = "Interface vs DB: NULL vs [$hr_columns->{$current_field}->{COLUMN_DEFAULT}]"; - } elsif (defined $self->default->[$_] and !defined $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { - $hr_mismatches->{default}->{$current_field} = "Interface vs DB: [" . $self->default->[$_] . "] vs NULL"; - } elsif ($self->default->[$_] ne $hr_columns->{$current_field}->{COLUMN_DEFAULT}) { - $hr_mismatches->{default}->{$current_field} = "Interface vs DB: [" . $self->default->[$_] . "] vs [$hr_columns->{$current_field}->{COLUMN_DEFAULT}]"; - } - } ## end if (defined $self->default...) - } ## end else [ if (!exists $hr_columns...)] - } ## end if ($self->useintable->...) - } ## end for (0 .. $#{$self->columns...}) - foreach my $dbcolumn (keys (%{$hr_columns})) { - if (!scalar grep { $_ eq $dbcolumn } @{$self->columns}) { - push (@columns_not_in_interface, $dbcolumn); - } - } - - my $ar_indices = $dbh->selectall_arrayref("SHOW INDEX FROM " . $self->name, {Slice => {}}) - or Carp::carp("Error fetching index info for table [" . $self->name . "] from database: " . $dbh->errstr); - # Convert the array of (possibly) multiple rows with the same Key_name (but different Column_name) to a single array of Column_names - my $hr_indices = {}; - my @keys_not_in_database; - my @keys_not_in_interface; - foreach (@{$ar_indices}) { - push (@{$hr_indices->{$_->{Key_name}}->{keyfields}}, $_->{Column_name}); - } - if ($self->has_indices) { - foreach my $current_index (keys (%{$self->indices})) { - if (!exists $hr_indices->{$current_index}) { push (@keys_not_in_database, $current_index); } - else { - my $keyfields = $self->{indices}->{$current_index}->{keyfields}; - $keyfields =~ s/ //g; - if ($keyfields ne join (',', @{$hr_indices->{$current_index}->{keyfields}})) { - $hr_mismatches->{indices}->{$current_index} = "Interface vs DB: [" . $keyfields . " vs " . join (',', @{$hr_indices->{$current_index}->{keyfields}}) . "]"; - } - } ## end else [ if (!exists $hr_indices...)] - } ## end foreach my $current_index (...) - } - foreach my $current_index (keys (%{$hr_indices})) { - if (!exists $self->indices->{$current_index}) { push (@keys_not_in_interface, $current_index); } - } - - if (@columns_not_in_database) { - print ("Columns not in database: " . join (',', @columns_not_in_database) . "\n"); - } - if (@columns_not_in_interface) { - print ("Columns not in interface: " . join (',', @columns_not_in_interface) . "\n"); - } - if (@keys_not_in_database) { - print ("Keys not in database: " . join (',', map { "$_: [" . join (',', @{$hr_indices->{$_}->{keyfields}}) . "]" } @keys_not_in_database) . "\n"); - } - if (@keys_not_in_interface) { - print ("Keys not in interface: " . join (',', map { "$_: [" . join (',', @{$hr_indices->{$_}->{keyfields}}) . "]" } @keys_not_in_interface) . "\n"); - } - if (scalar keys (%{$hr_mismatches})) { - Data::Dump::dd($hr_mismatches); - Carp::confess("There were mismatches"); - } -} ## end sub CheckDatabase ($$) - -# CreateInsertQuery Returns an SQL statement inserting fields @ with value ? into $self->{name} -# Arguments: self, $ar_fieldnames -method CreateInsertQuery (ArrayRef $ar_columns !) { - if (!$self->has_name) { - Carp::confess "Cannot create INSERT query for object without (table)name"; - } - return "INSERT INTO " . $self->name . "(" . join (",", @{$ar_columns}) . ") VALUES (" . join (",", map ("?", @{$ar_columns})) . ") "; -} ## end sub CreateInsertQuery ($$) - -# CreateUpdateQuery Returns an SQL statement updating table $self->{name} setting fields @ to ? -# Arguments: self, $ar_fieldnames -method CreateUpdateQuery (ArrayRef $ar_columns !) { - return "UPDATE " . $self->{name} . " SET " . join (",", map ($_ . "=?", @{$ar_columns})) . " "; -} - -# CreateInsertUpdateQuery returns an SQL statement inserting fields @{$_[1]} with value ? into table $_[0] -# On duplicate key values, all non-key values are updated with ? -method CreateInsertUpdateQuery (ArrayRef $ar_columns !) { - my $ar_keycolumns = [split (',', $self->indices->{PRIMARY}->{keyfields})]; - if ($#$ar_keycolumns == -1) { Carp::confess("No primary key configured, CreateInsertUpdateQuery not possible"); } - # Escape keycolumnnames to allow columns named with reserved words - @{$ar_keycolumns} = map {"`$_`"} @{$ar_keycolumns}; - my @nonkeyfields = SleLib::Difference($ar_columns, $ar_keycolumns); - return $self->CreateInsertQuery($ar_columns) . " ON DUPLICATE KEY UPDATE " . join (",", map ("$_=Values($_)", @nonkeyfields)) . " "; -} ## end sub CreateInsertUpdateQuery ($$) - -# CreateSelectQuery Returns an SQL statement selecting fields @ from table $ -# Arguments: TableName, @fieldnames, %modifications -# %modifications consists of key-value pairs as follows: "FieldName" => "FunctionName" -# This will change "FieldName" into "FunctionName(FieldName) AS FieldName" -method CreateSelectQuery (ArrayRef $ar_columns !, HashRef $hr_modifications !) { - my @Columns = map { $hr_modifications->{$_} ? "$hr_modifications->{$_} AS $_" : $_; } @{$ar_columns}; - return "SELECT " . join (",", @Columns) . " FROM " . $self->{name}; -} ## end sub CreateSelectQuery ($$$) - -# CreateTable -# Returns a string containing the CREATE TABLE statement -method CreateTable { - my $returnstring = "CREATE TABLE "; - my @columnnames; - $returnstring .= "`" . $self->name . "` (\n"; - @columnnames = map { "`$_`"; } @{$self->columns}; - foreach (0 .. $#{$self->columns}) { - $returnstring .= " $columnnames[$_] " . $self->datatype->[$_]; - if ($self->datatype->[$_] !~ /^(DATE|TIME|DATETIME|TEXT|MONEY|BIT)$/i) { - $returnstring .= sprintf ("(%s", $self->length->[$_]); - if (($self->decimals->[$_] // 0) > 0) { - $returnstring .= sprintf (",%s", $self->{decimals}[$_]); - } - $returnstring .= ")"; - } - if (($self->datatype->[$_] =~ /^(TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC)$/i) and (($self->signed->[$_] // 1) == 0)) { - $returnstring .= " UNSIGNED"; - } - if ($self->allownull->[$_] == 0) { - $returnstring .= " NOT NULL"; - } - if (defined $self->default->[$_]) { - if ($self->datatype->[$_] =~ /(VARCHAR|CHAR|DATE|TIME|DATETIME)/i) { - $returnstring .= sprintf (" DEFAULT '%s'", $self->default->[$_]); - } else { - $returnstring .= sprintf (" DEFAULT %s", $self->default->[$_]); - } - } ## end if (defined $self->default...) - if ($self->autoincrement->[$_]) { - $returnstring .= " AUTO_INCREMENT"; - } - if ($_ < $#{$self->columns}) { - $returnstring .= ",\n"; - } - } ## end foreach (0 .. $#{$self->columns...}) - # Index opbouwen - if ($self->has_indices) { - foreach (keys (%{$self->indices})) { - if (/PRIMARY/) { - $returnstring .= sprintf (",\n $_ KEY (%s) ", join (',', map { "`$_`"; } @{$self->indices->{$_}})); - } else { - $returnstring .= sprintf (",\n KEY $_ (%s) ", $self->indices->{$_}); - } - } ## end foreach (keys (%{$self->indices...})) - } ## end if ($self->has_indices) - $returnstring .= "\n)"; - $returnstring .= " ENGINE=MyISAM;\n"; - return $returnstring; -} ## end sub CreateTable - -# WriteData ($dbhandle, $ar_data, $hr_options) -# Options consist of: Columns = [columns..] # Insert only these columns -# Update = 0|1 # use "INSERT...ON DUPLICATE KEY UPDATE"-statements -# Ignore = 0|1 # Use INSERT IGNORE, cannot be used together update -# Naturally, columns must have the useintable-attribute set to 'Y' -method WriteData ($dbh !, ArrayRef $ar_data !, HashRef $hr_options ?) { - if (!defined $dbh) { - Carp::confess "Database-handle is undefined"; - } - if (ref($dbh) ne 'DBI::db') { - Carp::confess "Supplied databasehandle is not a DBI::db handle"; - } - if (!defined $ar_data) { return undef; } - my $returnvalue = 0; - my $ar_Insert_Columns = (defined $hr_options->{Columns}) ? $hr_options->{Columns} : $self->columns; - my $ar_Insert_Columns_Escaped; - my @a_insert_columns; - foreach my $ColumnName (@{$ar_Insert_Columns}) { - my $ColumnIndex = SleLib::IndexOf($ColumnName, @{$self->columns}); - if ($self->useintable->[$ColumnIndex] eq 'Y') { - push (@a_insert_columns, $ColumnIndex); - } else { - Carp::carp("Specified column [$ColumnName] is has useintable=N, skipping"); - } - } ## end foreach my $ColumnName (@{$ar_Insert_Columns...}) - $ar_Insert_Columns = [ map { $self->{columns}->[$_]; } @a_insert_columns ]; - my $Query_Insert; - # Escape columnnames to allow columns named with reserved words - @{$ar_Insert_Columns_Escaped} = map {"`$_`"} @{$ar_Insert_Columns}; - if ($hr_options->{Update}) { - $Query_Insert = $self->CreateInsertUpdateQuery($ar_Insert_Columns_Escaped); - } else { - $Query_Insert = $self->CreateInsertQuery($ar_Insert_Columns_Escaped); - if ($hr_options->{Ignore}) { - $Query_Insert =~ s/INSERT/INSERT IGNORE/; - } - } ## end else [ if ($hr_options->{Update...})] - $Query_Insert = $dbh->prepare($Query_Insert) or Carp::confess("Error preparing Insert-query: " . $dbh->errstr); - if (!defined $Query_Insert) { return undef; } - foreach my $hr_record (@{$ar_data}) { - my @a_values = SleLib::GetHashValues($ar_Insert_Columns, $hr_record); - foreach (0 .. $#a_values) { - if (!defined $a_values[$_] and defined $self->default->[$_]) { $a_values[$_] = $self->default->[$_]; } - } - my $query_result = $Query_Insert->execute(@a_values); - if (!defined $query_result) { - Data::Dump::dd($Query_Insert->{Statement}); - Data::Dump::dd($hr_record); - Carp::confess("Error inserting values into " . $self->name . ": " . $dbh->errstr); - } else { - $returnvalue += $query_result; - } - } ## end foreach my $hr_record (@{$ar_data...}) - return $returnvalue; -} ## end sub WriteData - -# ReadData ($dbhandle, $hr_options) -# Options consist of: columns = [ columns.. ] # Select only these columns -# modifications = { column => function, .. } # Like CreateSelectQuery -# suffix = " WHERE ..." # Gets appended to the query returned by CreateSelectQuery -# parameters = [ parameter1, parameter2, ..] # Array of parameters to be supplied to the query -# query = "SELECT..." # Overrides everything (except parameters) and uses this query instead of creating one. -# mode = array | hash # Defaults to array. Indicates the use of selectall_arrayref or selectall_hashref. Using mode=hash requires the option "keys" to be specified too -# keys = [columns] # Arrayref of one or more keys used with mode=hash -method ReadData ($dbh !, HashRef $hr_options ?) { - if (!defined $dbh) { - Carp::carp("Database-handle is undefined"); - return undef; - } - if (!exists $hr_options->{mode}) { - $hr_options->{mode} = "array"; - } - my $ar_Select_Columns; - if (!exists $hr_options->{query}) { - $ar_Select_Columns = (exists $hr_options->{columns}) ? $hr_options->{columns} : [ $self->columns ]; - #Make a shallow copy, otherwise splicing ignored columns tampers with the object's columns-attribute - # $ar_Select_Columns - my @Ignore_Columns; - foreach my $ColumnName (@{$ar_Select_Columns}) { - # print("Processing [$ColumnName]\n"); - my $ColumnIndex = SleLib::IndexOf($ColumnName, @{$self->columns}); - if ($ColumnIndex == -1 or $self->useintable->[$ColumnIndex] ne 'Y') { - Carp::carp("Specified column [$ColumnName] does not exist or has useintable=N, skipping"); - push (@Ignore_Columns, $ColumnIndex); # Queue for deletion from $ar_Insert_Columns - } - } ## end foreach my $ColumnName (@{$ar_Select_Columns...}) - foreach (0 .. $#Ignore_Columns) { splice (@{$ar_Select_Columns}, $Ignore_Columns[$_] - $_, 1); } # Delete from $ar_Insert_Columns - # Escape columnnames to allow columns named with reserved words - @{$ar_Select_Columns} = map {"`$_`"} @{$ar_Select_Columns}; - # Escape columnname-keys in $hr_options->{modifications} - foreach (keys (%{$hr_options->{modifications}})) { - $hr_options->{modifications}->{"`$_`"} = $hr_options->{modifications}->{$_}; - delete $hr_options->{modifications}->{$_}; - } - $hr_options->{query} = $self->CreateSelectQuery($ar_Select_Columns, $hr_options->{modifications}) . " " . ($hr_options->{suffix} // ""); - } ## end if (!exists $hr_options...) - - #Data::Dump::dd($hr_options); - my $r_data; # can be either hr or ar - if ($hr_options->{mode} eq "array") { - if (exists $hr_options->{parameters} and scalar @{$hr_options->{parameters}} > 0) { - $r_data = $dbh->selectall_arrayref($hr_options->{query}, {Slice => {}}, @{$hr_options->{parameters}}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } else { - $r_data = $dbh->selectall_arrayref($hr_options->{query}, {Slice => {}}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } - } elsif ($hr_options->{mode} eq "hash") { - if (!exists $hr_options->{keys}) { - Carp::confess("No keys given for hash-mode query"); - } - if (exists $hr_options->{parameters} and scalar @{$hr_options->{parameters}} > 0) { - $r_data = $dbh->selectall_hashref($hr_options->{query}, $hr_options->{keys}, undef, @{$hr_options->{parameters}}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } else { - $r_data = $dbh->selectall_hashref($hr_options->{query}, $hr_options->{keys}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } - } else { - Carp::confess("Unknown mode [$hr_options->{mode}] given for DataTableRead"); - } - - # Fix double/floats to not be returned as PV '0.00', but as NV - if ($hr_options->{mode} eq "array") { - foreach my $hr_record (@{$r_data}) { - # TODO - } - } - - #print("Returning size: [" . Devel::Size::total_size($r_data) . "]\n"); - return $r_data; -} ## end sub ReadData ($$$) - -# TableDiff returns records uit Source that differ in values from non-keyfields compared to Target -# Source and Target tables need to be compatible with this interface (naturally) -# Arguments: dbh, Source_Tablename, Target_Tablename, ar_Fields_to_compare (these need to contain all the primary keyfields), hr_options -# Options will be passed to ReadData. -method TableDiff ($dbh !, Str $source_tablename !, Str $target_tablename !, ArrayRef(Str) $ar_fields_to_compare !, HashRef $hr_options ?) { - my $ar_keycolumns = $self->indices->{PRIMARY}; - if ($#$ar_keycolumns == -1) { Carp::confess("No primary key configured, TableDiff not possible"); } - my $ar_nonkeyfields = [ grep { !($_ ~~ $ar_keycolumns); } @{$ar_fields_to_compare} ]; # preserve order - # Escape fields - @{$ar_keycolumns} = map { !/^[`].*[`]$/ ? "`$_`" : $_; } @{$ar_keycolumns}; - @{$ar_nonkeyfields} = map { !/^[`].*[`]$/ ? "`$_`" : $_; } @{$ar_nonkeyfields}; - my $query = " - SELECT target.* - FROM $source_tablename AS source - LEFT JOIN $target_tablename AS target USING (" . join(',', @{$ar_keycolumns}) . ") - WHERE NOT ISNULL(COALESCE( - " . join(',', map { "NULLIF(target.${_}, source.${_})"; } @{$ar_nonkeyfields} ) . - "))"; - $hr_options->{query} = $query; - return $self->ReadData($dbh, $hr_options); -} - -1; # so the require or use succeeds diff --git a/Interfaces/DataTable/SQLServer.pm b/Interfaces/DataTable/SQLServer.pm deleted file mode 100644 index fc402ff..0000000 --- a/Interfaces/DataTable/SQLServer.pm +++ /dev/null @@ -1,322 +0,0 @@ -package Interfaces::DataTable::SQLServer; - -#use Devel::Size; -use Moose::Role; -use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater -use Devel::Peek; -use MooseX::Method::Signatures; - -BEGIN { - @Interfaces::DataTable::SQLServer::methods = qw(ReadData WriteData ReConfigureFromDatabase CreateInsertQuery CreateSelectQuery CreateUpdateQuery CreateTable); -} - -# Scan for roles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own methods as aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; -} - -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } -} - -use strict; - -#requires qw(columns displayname datatype length decimals signed allownull default fieldid indices useintable autoincrement); - -# ReConfigureFromDatabase configures self using a specified table in a specified databasehandle. -# Configures self for datatable-interfacing only, all values pertaining to other interfaces are left undefined -method ReConfigureFromDatabase ($dbh !, Str $tablename !) { - if (!defined $dbh) { - Carp::confess "Supplied databasehandle is undefined"; - } - my $meta = $self->meta; - # Clear attributes - foreach ($meta->get_attribute_list) { eval "$self->clear_" . "$_"; } - # Get columns-list from database - my $ar_ColumnInfo = $dbh->selectall_arrayref(" - SELECT - *, - columnproperty(object_id(TABLE_NAME), column_name,'IsIdentity') AS [Identity] - FROM INFORMATION_SCHEMA.COLUMNS - WHERE TABLE_NAME = ?", {Slice => {}}, $tablename) - or Carp::confess("Error getting column-info for [$tablename]: " . $dbh->errstr); - if (!@{$ar_ColumnInfo}) { return; } # No query results -> nothing to do - my $ar_IndexInfo = $dbh->selectall_arrayref(" - SELECT CONSTRAINT_TYPE, COLUMN_NAME, ORDINAL_POSITION - FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc - JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE ccu ON - tc.TABLE_CATALOG = ccu.TABLE_CATALOG AND - tc.TABLE_SCHEMA = ccu.TABLE_SCHEMA AND - tc.CONSTRAINT_NAME = ccu.CONSTRAINT_NAME - WHERE tc.TABLE_NAME = ? - ORDER BY ORDINAL_POSITION - ", {Slice => {}}, $tablename) - or Carp::confess("Error getting index-info for [$tablename]: " . $dbh->errstr); - # Start setting attributes - # Interface.pm supplies these column-attributes: - # columns, datatype, length, decimals, signed, allownull, default, fieldid - # if ($_->type_constraint->name =~ /^ArrayRef/) { - # push (@{$self->$attributename}, $hr_config->{$Column}->{$attributename}); - my $hr_indices; - foreach my $fieldid (0 .. $#$ar_ColumnInfo) { - my $column = $ar_ColumnInfo->[$fieldid]; - my $dbtype = uc $column->{DATA_TYPE}; - push (@{$self->{columns}}, $column->{COLUMN_NAME}); - push (@{$self->{displayname}}, $column->{COLUMN_NAME}); - push (@{$self->{datatype}}, $column->{DATA_TYPE}); - if ($dbtype =~ /REAL|FLOAT|DOUBLE|DECIMAL|NUMERIC|MONEY/) { - push (@{$self->{decimals}}, $column->{NUMERIC_SCALE}); - } else { - push (@{$self->{decimals}}, undef); - } - if ($dbtype =~ /(TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|REAL|DECIMAL|NUMERIC|NUMERIC)/) { - push (@{$self->{length}}, $column->{NUMERIC_PRECISION}); - push (@{$self->{signed}}, "1"); # SQL Server Integer types are always signed - } elsif ($dbtype =~ /CHAR|VARCHAR|TEXT/) { - push (@{$self->{length}}, $column->{CHARACTER_MAXIMUM_LENGTH}); - push (@{$self->{signed}}, undef); - } else { - push (@{$self->{signed}}, undef); - push (@{$self->{length}}, undef); - } - push (@{$self->{allownull}}, ($column->{IS_NULLABLE} eq "YES") ? "1" : "0"); - push (@{$self->{default}}, map { s/[()]//g; $_; } $column->{COLUMN_DEFAULT}) if (defined $column->{COLUMN_DEFAULT}); - push (@{$self->{default}}, undef) if (!defined $column->{COLUMN_DEFAULT}); - push (@{$self->{fieldid}}, $fieldid + 1); # FieldID is 1-based - push (@{$self->{useintable}}, "Y"); # Fields from a table are automatically used in a table :) - push (@{$self->{autoincrement}}, $column->{Identity}); - } ## end foreach my $fieldid (0 .. $#$ar_ColumnInfo) - foreach (@{$ar_IndexInfo}) { - if ($_->{CONSTRAINT_TYPE} eq 'PRIMARY KEY') { $_->{CONSTRAINT_TYPE} = 'PRIMARY'; } - push (@{$hr_indices->{$_->{CONSTRAINT_TYPE}}}, $_->{COLUMN_NAME}); - } - foreach (keys (%{$hr_indices})) { - $self->{indices}->{$_} = [@{$hr_indices->{$_}}]; - } - $self->MakeNewConfig(); - $self->ReConfigureFromHash($self->config); - $self->name($tablename); -} ## end sub ReConfigureFromDatabase ($$$) - -# CreateInsertQuery Returns an SQL statement inserting fields @ with value ? into $self->{name} -# Arguments: self, $ar_fieldnames -method CreateInsertQuery (ArrayRef $ar_columns !) { - if (!$self->has_name) { - Carp::confess "Cannot create INSERT query for object without (table)name"; - } - return "INSERT INTO " . $self->name . "(" . join (",", @{$ar_columns}) . ") VALUES (" . join (",", map ("?", @{$ar_columns})) . ") "; -} ## end sub CreateInsertQuery ($$) - -# CreateUpdateQuery Returns an SQL statement updating table $self->{name} setting fields @ to ? -# Arguments: self, $ar_fieldnames -method CreateUpdateQuery (ArrayRef $ar_columns !) { - return "UPDATE " . $self->{name} . " SET " . join (",", map ($_ . "=?", @{$ar_columns})) . " "; -} - -# CreateSelectQuery Returns an SQL statement selecting fields @ from table $ -# Arguments: TableName, @fieldnames, %modifications -# %modifications consists of key-value pairs as follows: "FieldName" => "FunctionName" -# This will change "FieldName" into "FunctionName(FieldName) AS FieldName" -method CreateSelectQuery (ArrayRef $ar_columns !, HashRef $hr_modifications !) { - my @Columns = map { $hr_modifications->{$_} ? "$hr_modifications->{$_} AS $_" : $_; } @{$ar_columns}; - return "SELECT " . join (",", @Columns) . " FROM " . $self->{name}; -} ## end sub CreateSelectQuery ($$$) - -# CreateTable ($language) -# Returns a string containing the CREATE TABLE statement for the given language -method CreateTable { - my $returnstring = "CREATE TABLE "; - my @columnnames; - $returnstring .= "[" . $self->name . "] (\n"; - @columnnames = map { "[$_]"; } @{$self->columns}; - foreach (0 .. $#{$self->columns}) { - $returnstring .= " $columnnames[$_] " . $self->datatype->[$_]; - if ($self->datatype->[$_] =~ /^(NUMERIC|CHAR|VARCHAR|NVARCHAR)$/i) { - $returnstring .= sprintf ("(%s", $self->length->[$_]); - if (($self->decimals->[$_] // 0) > 0) { - $returnstring .= sprintf (",%s", $self->{decimals}[$_]); - } - $returnstring .= ")"; - } - if ($self->allownull->[$_] != 0) { - $returnstring .= " NULL"; - } - if (defined $self->default->[$_]) { - if ($self->datatype->[$_] =~ /(VARCHAR|CHAR|DATE|TIME|DATETIME)/i) { - $returnstring .= sprintf (" DEFAULT '%s'", $self->default->[$_]); - } else { - $returnstring .= sprintf (" DEFAULT %s", $self->default->[$_]); - } - } ## end if (defined $self->default...) - if ($self->autoincrement->[$_]) { - $returnstring .= " IDENTITY(1,1)"; - } - if ($_ < $#{$self->columns}) { - $returnstring .= ",\n"; - } - } ## end foreach (0 .. $#{$self->columns...}) - # Index opbouwen - if ($self->has_indices) { - foreach (keys (%{$self->indices})) { - if (/PRIMARY/) { - $returnstring .= sprintf (",\n $_ KEY CLUSTERED (%s) ", join (',', map { "[$_]"; } @{$self->indices->{$_}})); - } else { - $returnstring .= sprintf (",\n KEY $_ (%s) ", $self->indices->{$_}); - } - } ## end foreach (keys (%{$self->indices...})) - } ## end if ($self->has_indices) - $returnstring .= "\n)"; - return $returnstring; -} ## end sub CreateTable - -# WriteData ($dbhandle, $ar_data, $hr_options) -# Options consist of: Columns = [columns..] # Insert only these columns -# Naturally, columns must have the useintable-attribute set to 'Y' -method WriteData ($dbh !, ArrayRef $ar_data !, HashRef $hr_options ?) { - if (!defined $dbh) { - Carp::carp("Database-handle is undefined"); - return undef; - } - if (!defined $ar_data) { return undef; } - my $returnvalue = 0; - my $ar_Insert_Columns = - (exists $hr_options->{Columns}) ? $hr_options->{Columns} : [ $self->columns ] - ; #Make a shallow copy, otherwise splicing ignored columns tampers with the object's columns-attribute - my $ar_Insert_Columns_Escaped; - my @Ignore_Columns; - foreach my $ColumnName (@{$ar_Insert_Columns}) { - # print("Processing [$ColumnName]\n"); - my $ColumnIndex = SleLib::IndexOf($ColumnName, @{$self->columns}); - if ($self->useintable->[$ColumnIndex] eq 'N') { - Carp::carp("Specified column [$ColumnName] is has useintable=N, skipping"); - push (@Ignore_Columns, $ColumnIndex); # Queue for deletion from $ar_Insert_Columns - } - } ## end foreach my $ColumnName (@{$ar_Insert_Columns...}) - foreach (0 .. $#Ignore_Columns) { splice (@{$ar_Insert_Columns}, $Ignore_Columns[$_] - $_, 1); } # Delete from $ar_Insert_Columns - my $Query_Insert; - # Escape columnnames to allow columns named with reserved words - @{$ar_Insert_Columns_Escaped} = map {"`$_`"} @{$ar_Insert_Columns}; - $Query_Insert = $self->CreateInsertQuery($ar_Insert_Columns_Escaped); - $Query_Insert = $dbh->prepare($Query_Insert) or Carp::confess("Error preparing Insert-query: " . $dbh->errstr); - if (!defined $Query_Insert) { return undef; } - foreach my $hr_record (@{$ar_data}) { - my @a_values = SleLib::GetHashValues($ar_Insert_Columns, $hr_record); - foreach (0 .. $#a_values) { - if (!defined $a_values[$_] and defined $self->default->[$_]) { $a_values[$_] = $self->default->[$_]; } - } - my $query_result = $Query_Insert->execute(@a_values); - if (!defined $query_result) { - Data::Dump::dd($Query_Insert->{Statement}); - Data::Dump::dd($hr_record); - Carp::confess("Error inserting values into " . $self->name . ": " . $dbh->errstr); - } else { - $returnvalue += $query_result; - } - } ## end foreach my $hr_record (@{$ar_data...}) - return $returnvalue; -} ## end sub WriteData - -# ReadData ($dbhandle, $hr_options) -# Options consist of: columns = [ columns.. ] # Select only these columns -# modifications = { column => function, .. } # Like CreateSelectQuery -# suffix = " WHERE ..." # Gets appended to the query returned by CreateSelectQuery -# parameters = [ parameter1, parameter2, ..] # Array of parameters to be supplied to the query -# query = "SELECT..." # Overrides everything (except parameters) and uses this query instead of creating one. -# mode = array | hash # Defaults to array. Indicates the use of selectall_arrayref or selectall_hashref. Using mode=hash requires the option "keys" to be specified too -# keys = [columns] # Arrayref of one or more keys used with mode=hash -method ReadData ($dbh !, HashRef $hr_options ?) { - if (!defined $dbh) { - Carp::carp("Database-handle is undefined"); - return undef; - } - if (!exists $hr_options->{mode}) { - $hr_options->{mode} = "array"; - } - my $ar_Select_Columns; - if (!exists $hr_options->{query}) { - $ar_Select_Columns = (exists $hr_options->{columns}) ? $hr_options->{columns} : [ $self->columns ]; - #Make a shallow copy, otherwise splicing ignored columns tampers with the object's columns-attribute - # $ar_Select_Columns - my @Ignore_Columns; - foreach my $ColumnName (@{$ar_Select_Columns}) { - # print("Processing [$ColumnName]\n"); - my $ColumnIndex = SleLib::IndexOf($ColumnName, @{$self->columns}); - if ($ColumnIndex == -1 or $self->useintable->[$ColumnIndex] ne 'Y') { - Carp::carp("Specified column [$ColumnName] does not exist or has useintable=N, skipping"); - push (@Ignore_Columns, $ColumnIndex); # Queue for deletion from $ar_Insert_Columns - } - } ## end foreach my $ColumnName (@{$ar_Select_Columns...}) - foreach (0 .. $#Ignore_Columns) { splice (@{$ar_Select_Columns}, $Ignore_Columns[$_] - $_, 1); } # Delete from $ar_Insert_Columns - # Escape columnnames to allow columns named with reserved words - @{$ar_Select_Columns} = map {"`$_`"} @{$ar_Select_Columns}; - # Escape columnname-keys in $hr_options->{modifications} - foreach (keys (%{$hr_options->{modifications}})) { - $hr_options->{modifications}->{"`$_`"} = $hr_options->{modifications}->{$_}; - delete $hr_options->{modifications}->{$_}; - } - $hr_options->{query} = $self->CreateSelectQuery($ar_Select_Columns, $hr_options->{modifications}) . " " . ($hr_options->{suffix} // ""); - } ## end if (!exists $hr_options...) - - #Data::Dump::dd($hr_options); - my $r_data; # can be either hr or ar - if ($hr_options->{mode} eq "array") { - if (exists $hr_options->{parameters} and scalar @{$hr_options->{parameters}} > 0) { - $r_data = $dbh->selectall_arrayref($hr_options->{query}, {Slice => {}}, @{$hr_options->{parameters}}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } else { - $r_data = $dbh->selectall_arrayref($hr_options->{query}, {Slice => {}}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } - } elsif ($hr_options->{mode} eq "hash") { - if (!exists $hr_options->{keys}) { - Carp::confess("No keys given for hash-mode query"); - } - if (exists $hr_options->{parameters} and scalar @{$hr_options->{parameters}} > 0) { - $r_data = $dbh->selectall_hashref($hr_options->{query}, $hr_options->{keys}, undef, @{$hr_options->{parameters}}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } else { - $r_data = $dbh->selectall_hashref($hr_options->{query}, $hr_options->{keys}) - or Carp::confess("Error retrieving data from [" . $self->name . "]: " . $dbh->errstr); - } - } else { - Carp::confess("Unknown mode [$hr_options->{mode}] given for DataTableRead"); - } - - # Fix double/floats to not be returned as PV '0.00', but as NV - if ($hr_options->{mode} eq "array") { - foreach my $hr_record (@{$r_data}) { - # TODO - } - } - - #print("Returning size: [" . Devel::Size::total_size($r_data) . "]\n"); - return $r_data; -} ## end sub ReadData ($$$) - -1; # so the require or use succeeds diff --git a/Interfaces/DelimitedFile.pm b/Interfaces/DelimitedFile.pm old mode 100644 new mode 100755 index ac9b445..56711dd --- a/Interfaces/DelimitedFile.pm +++ b/Interfaces/DelimitedFile.pm @@ -1,263 +1,317 @@ package Interfaces::DelimitedFile; # RFC 4180-compliant. +use v5.10; +use Smart::Comments; use Moose::Role; # automatically turns on strict and warnings -use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater -#use Devel::Size; use MooseX::Method::Signatures; +no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater BEGIN { - @Interfaces::DelimitedFile::methods = qw(ReadRecord WriteRecord ReadData WriteData ConfigureUseInFile); -} - -has 'field_delimiter' => (is => 'rw', isa => 'Str', lazy_build => 1,); -has 'record_delimiter' => (is => 'rw', isa => 'Str', lazy_build => 1,); -has 'DelimitedFile_ar_useinfile' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 0,); -has 'DelimitedFile_hr_fileindex' => (is => 'rw', isa => 'HashRef[Int]', lazy_build => 0,); -has 'DelimitedFile_ar_writemask' => (is => 'rw', isa => 'Str', lazy_build => 0,); - -# Scan for roles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; -} - -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } + $Interfaces::DelimitedFile::VERSION = '2.0.0'; # 18-11-2013 } -use strict; +requires qw(columns displayname datatype decimals signed allownull default decimalseparator thousandseparator); -#requires qw(columns displayname datatype decimals signed allownull default decimalseparator thousandseparator); - -# TODO: -# Implement allownull when reading (!allownull -> requires default) +has 'field_delimiter' => (is => 'rw', isa => 'Str', lazy_build => 1, trigger => \&_field_delimiter_set); +has 'record_delimiter' => (is => 'rw', isa => 'Str', lazy_build => 1,); +has 'delimited_mask' => (is => 'rw', isa => 'Str', lazy_build => 1,); +has 'delimited_columns' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); +has 'DelimitedFile_ar_useinfile' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 0,); +has 'DelimitedFile_hr_fileindex' => (is => 'rw', isa => 'HashRef[Int]', lazy_build => 0, clearer => 'clear_DelimitedFile_hr_fileindex'); +has 'DelimitedFile_ar_writemask' => (is => 'rw', isa => 'Str', lazy_build => 0, clearer => 'clear_DelimitedFile_ar_writemask'); +has 'delimiter' => (is => 'rw', isa => 'Str', lazy_build => 1, trigger => \&_field_delimiter_set); # backwards compatibility for v1.0.0 +has 'escapechar' => (is => 'rw', isa => 'Str', lazy_build => 1, trigger => \&_escapechar_set); after 'BUILD' => sub { my $self = shift; # Initialize our own attributes with default values and set all columns with a displayname to be used - $self->field_delimiter(','); + my ($field_delimiter, $escapechar) = (',', '"'); + $self->field_delimiter($field_delimiter); $self->record_delimiter("\r\n"); + $self->escapechar($escapechar); $self->DelimitedFile_ConfigureUseInFile($self->displayname()); + $self->{ESCAPEFIELD_ESCAPECHAR_INPUT1} = qr/^"(([^${escapechar}]|${escapechar}{2})*)"(?:[$field_delimiter]|$)/p; + $self->{ESCAPEFIELD_NONESCAPE_INPUT1} = qr/^"(.*)"(?:[$field_delimiter]|$)/p; + $self->{NONESCAPE_ESCAPECHAR_INPUT1} = qr/^([^${field_delimiter}${escapechar}]*)(?:[$field_delimiter]|$)/p; + $self->{NONESCAPE_NONESCAPE_INPUT1} = qr/^([^${field_delimiter}]*)(?:[${field_delimiter}]|$)/p; }; after 'Check' => sub { my $self = shift; - print ("Checking DelimitedFile constraints..."); + print ("Checking DelimitedFile constraints...") if defined $Interfaces::Interface::DEBUGMODE; # Check if all fields that are marked with "useinfile" have a displayname for (0 .. $#{$self->columns}) { - if ($self->{ar_useinfile}->[$_] and !($self->displayname->[$_] // "")) { - Carp::confess("DelimitedFile field [" . $self->columns->[$_] . "] is configured to be used, but has no displayname"); + if ($self->{DelimitedFile_ar_useinfile}->[$_] && !($self->displayname->[$_] // "")) { + Interfaces::Interface::Crash("DelimitedFile field [" . $self->columns->[$_] . "] is configured to be used, but has no displayname"); } } # Check if the delimiter is set - if (!$self->has_field_delimiter or $self->field_delimiter eq '') { - Carp::confess("Field delimiter not set"); + if (!$self->has_field_delimiter || $self->field_delimiter eq '') { + Interfaces::Interface::Crash("Field delimiter not set"); } - if (!$self->has_record_delimiter or $self->record_delimiter eq '') { - Carp::confess("Record delimiter not set"); + if (!$self->has_record_delimiter || $self->record_delimiter eq '') { + Interfaces::Interface::Crash("Record delimiter not set"); } - print("[OK]\n"); + print("[OK]\n") if defined $Interfaces::Interface::DEBUGMODE; + 1; }; after 'ReConfigureFromHash' => sub { my $self = shift; - $self->{DelimitedFile_ar_writemask} = undef; + $self->clear_delimited_mask; + $self->clear_DelimitedFile_hr_fileindex; + $self->clear_DelimitedFile_ar_writemask; + $self->clear_delimiter; + # Initialize default values + my ($field_delimiter, $escapechar) = (',', '"'); + $self->field_delimiter($field_delimiter); + $self->record_delimiter("\r\n"); + $self->escapechar($escapechar); + $self->DelimitedFile_ConfigureUseInFile($self->displayname()); + $self->{ESCAPEFIELD_ESCAPECHAR_INPUT1} = qr/^"(([^${escapechar}]|${escapechar}{2})*)"(?:[$field_delimiter]|$)/p; + $self->{ESCAPEFIELD_NONESCAPE_INPUT1} = qr/^"(.*)"(?:[$field_delimiter]|$)/p; + $self->{NONESCAPE_ESCAPECHAR_INPUT1} = qr/^([^${field_delimiter}${escapechar}]*)(?:[$field_delimiter]|$)/p; + $self->{NONESCAPE_NONESCAPE_INPUT1} = qr/^([^${field_delimiter}]*)(?:[${field_delimiter}]|$)/p; +}; + +after 'AddField' => sub { + my ($self, $hr_config) = @_; }; -method DelimitedHeader { +method _escapechar_set(Str $value !, Str $old_value ?) { + my $delimiter = $self->field_delimiter; + my $string; + if ($value ne '') { + $string = '^"(([^' . $value . ']|' . $value . '{2})*)"(?:[' . $delimiter . ']|$)'; + } else { + $string = '^([^' . $delimiter . ']*)(?:[' . $delimiter . ']|$)'; + } + $self->{ESCAPEFIELD_ESCAPECHAR_INPUT1} = qr/$string/p; + $string = '^([^' . $delimiter . $value . ']*)(?:[' . $delimiter . ']|$)'; + $self->{NONESCAPE_ESCAPECHAR_INPUT1} = qr/$string/p; +} + +method _field_delimiter_set(Str $value !, Str $old_value ?) { + my $string = '^([^' . $value . ']*)(?:[' . $value . ']|$)'; + $self->{NONESCAPE_NONESCAPE_INPUT1} = qr/$string/p; + $string = '^\"(.*)\"(?:[' . $value . ']|$)'; + $self->{ESCAPEFIELD_NONESCAPE_INPUT1} = qr/$string/p; + my $escapechar = $self->escapechar; + if ($self->escapechar ne '') { + $string = '^\"(([^' . $escapechar . ']|' . $escapechar . '{2})*)"(?:[' . $value . ']|$)'; + $self->{ESCAPEFIELD_ESCAPECHAR_INPUT1} = qr/$string/p; + $string = '^([^' . $value . $escapechar . ']*)(?:[' . $value . ']|$)'; + $self->{NONESCAPE_ESCAPECHAR_INPUT1} = qr/$string/p; + } else { + $self->{ESCAPEFIELD_ESCAPECHAR_INPUT1} = $self->{ESCAPEFIELD_NONESCAPE_INPUT1}; + $self->{NONESCAPE_ESCAPECHAR_INPUT1} = $self->{NONESCAPE_NONESCAPE_INPUT1}; + } +} + +method DelimitedHeader() { if (!$self->has_field_delimiter) { - Carp::confess("Field delimiter is not set"); + Interfaces::Interface::Crash("Field delimiter is not set"); } # Returned alleen die displaynames waarvan useinfile op 1 staat. - return join ($self->{field_delimiter}, map { $self->{displayname}->[$_]; } grep { $self->{ar_useinfile}->[$_]; } (0 .. $#{$self->{columns}})); + return join ($self->{field_delimiter}, map { $self->{displayname}->[$_]; } grep { $self->{DelimitedFile_ar_useinfile}->[$_]; } (0 .. $#{$self->{columns}})); } ## end sub DelimitedHeader ($) # WriteRecord ($hr_data) returns string -method WriteRecord (HashRef $hr_data !) { +method WriteRecord(HashRef $hr_data !) { my $mask = ""; my @data; - if (!$self->has_field_delimiter or !$self->has_record_delimiter) { - Carp::confess("Field- or Record-delimiter is not set"); + if (!$self->has_field_delimiter || !$self->has_record_delimiter) { + Interfaces::Interface::Crash("Field- or Record-delimiter is not set"); } my $field_delimiter = $self->field_delimiter; # Filter kolomindices die geen DelimitedFile_ar_useinfile hebben my @process_these_columns = grep { $self->{DelimitedFile_ar_useinfile}->[$_]; } (0 .. $#{$self->{columns}}); - my %columnnames = map { $_ => $self->{columns}->[$_]; } @process_these_columns; # Maak printf-masks - for my $index (@process_these_columns) { - if (!defined $self->{DelimitedFile_ar_writemask}->[$index]) { - $self->{DelimitedFile_ar_writemask}->[$index] = "%"; - given ($self->{internal_datatype}->[$index]->{type}) { - when (Interfaces::DATATYPE_TEXT) { - $self->{DelimitedFile_ar_writemask}->[$index] .= "s"; - } - when (Interfaces::DATATYPE_NUMERIC) { - $self->{DelimitedFile_ar_writemask}->[$index] .= $self->{signed}->[$index] eq 'Y' ? "d" : "u"; - } - when ([ Interfaces::DATATYPE_FLOATINGPOINT, Interfaces::DATATYPE_FIXEDPOINT ]) { - $self->{DelimitedFile_ar_writemask}->[$index] .= "." . $self->{decimals}->[$index] . "f"; - } - when (Interfaces::DATATYPE_DATETIME) { - $self->{DelimitedFile_ar_writemask}->[$index] .= "s"; - } - default { - $self->{DelimitedFile_ar_writemask}->[$index] .= "s"; - } - } ## end given - } ## end if (!defined $Interfaces::DelimitedFile::hr_writemask...) - } ## end for my $index (0 .. $#{...}) - if (!defined $self->{DelimitedFile_ar_writemask}) { - Carp::confess("No columns were identified as being used in file (have you forgot to use ConfigureUseInFile?)."); + if (!$self->has_delimited_mask) { + for my $index (@process_these_columns) { + if (!defined $self->{DelimitedFile_ar_writemask}->[$index]) { + $self->{DelimitedFile_ar_writemask}->[$index] = "%"; + given ($self->{internal_datatype}->[$index]) { + when ($Interfaces::Interface::DATATYPE_TEXT) { + $self->{DelimitedFile_ar_writemask}->[$index] .= "s"; + } + when ($Interfaces::Interface::DATATYPE_NUMERIC) { + $self->{DelimitedFile_ar_writemask}->[$index] .= $self->{signed}->[$index] == 1 ? "d" : "u"; + } + when ($_ > $Interfaces::Interface::DATATYPE_NUMERIC) { + $self->{DelimitedFile_ar_writemask}->[$index] .= "." . $self->{decimals}->[$index] . "f"; + } + default { + $self->{DelimitedFile_ar_writemask}->[$index] .= "s"; + } + } ## end given + } ## end if (!defined $Interfaces::DelimitedFile::hr_writemask...) + $self->{delimited_mask} .= $self->{DelimitedFile_ar_writemask}->[$index] . $field_delimiter; + } ## end for my $index (0 .. $#{...}) + substr($self->{delimited_mask}, -length($field_delimiter)) = ''; # Remove trailing field delimiter + if (!defined $self->{DelimitedFile_ar_writemask}) { + Interfaces::Interface::Crash("No columns were identified as being used in file (have you forgot to use ConfigureUseInFile?)."); + } } my $evalstring; foreach my $index (@process_these_columns) { if (!defined $self->{DelimitedFile_ar_writemask}->[$index]) { - $data[$index] = 'ERROR_NO_WRITE_MASK'; + push(@data, 'ERROR_NO_WRITE_MASK'); next; - } else { - Carp::carp("Delmitedfile_ar_writemask [" . $self->{DelimitedFile_ar_writemask}->[$index] . "]") if ($Interfaces::DEBUGMODE); } - my $columnname = $columnnames{$index}; - my $field_value = (defined $hr_data->{$columnname}) ? $hr_data->{$columnname} : $self->{default}->[$index]; - - if (defined $field_value) { - if ($self->{internal_datatype}->[$index]->{type} >= Interfaces::DATATYPE_NUMERIC) { # Numeric with or without decimals - # MinMax boundary check and fix -#print("Pre-minmax [$field_value]\n"); - $field_value = $self->minmax($index, $field_value); -#print("Post-minmax [$field_value]\n"); - } - # Escape "'s in character-data with another " RFC 4180 2.7 - if (index($field_value, '"') + 1) { # 7772520 6.33s - $field_value =~ s/"/""/g; - $field_value = "\"$field_value\""; - } elsif (index($field_value, $field_delimiter) + 1 or index($field_value, $self->{record_delimiter}) + 1) { - $field_value = "\"$field_value\""; - } + my $CurrentColumnDecimals = $self->{decimals}->[$index]; + my $field_value = $hr_data->{$self->{columns}->[$index]} // ($self->write_defaultvalues ? $self->{default}->[$index] : undef); + + if (!$self->{speedy} && $self->{internal_datatype}->[$index] >= $Interfaces::Interface::DATATYPE_NUMERIC) { + $field_value = defined $field_value ? $self->minmax($index, $field_value) : 0; } else { - $field_value = ''; + if (defined $field_value) { + if (index($field_value, $self->{escapechar}) + 1) { # 7772520 6.33s + $field_value =~ s/"/""/g; + $field_value = "\"$field_value\""; + } elsif (index($field_value, $field_delimiter) + 1 || index($field_value, $self->{record_delimiter}) + 1) { + $field_value = "\"$field_value\""; + } + } else { + $field_value //= ''; + } } - $data[$index] = $field_value; - } ## end foreach (0 .. $#{$self->columns...}) - return join ($field_delimiter, map { sprintf ($self->{DelimitedFile_ar_writemask}->[$_], $data[$_]); } @process_these_columns); + push(@data, $field_value); + } + return sprintf($self->{delimited_mask}, @data); } ## end sub WriteRecord # WriteData ($filename, $ar_data, $hr_options) # Options consist of: header = 0 | 1 # Write a header to the file (default = 1) # append = 0 | 1 # Append to file (default = 0) -method WriteData (Str $filename !, ArrayRef $ar_data !, HashRef $hr_options ?){ - if (!$self->has_field_delimiter or !$self->has_record_delimiter) { - Carp::confess("Field- or Record-delimiter is not set"); +# encoding = # ascii, iso-8859-1, utf8 or any other encoding supported by Encode (default = utf8) +method WriteData(Str $filename !, ArrayRef $ar_data !, HashRef $hr_options ?) { + if (!$self->has_field_delimiter || !$self->has_record_delimiter) { + Interfaces::Interface::Crash("Field- or Record-delimiter is not set"); } + my $filemode = '>'; $hr_options->{header} //= 1; $hr_options->{append} //= 0; $hr_options->{encoding} //= 'utf8'; if ($hr_options->{append}) { - open (DELIMFILE, '>>:' . $hr_options->{encoding}, $filename) or (Carp::confess("Error opening outputfile [$filename]: $!") and return); - } else { - open (DELIMFILE, '>:' . $hr_options->{encoding}, $filename) or (Carp::confess("Error opening outputfile [$filename]: $!") and return); + $filemode .= '>'; } + $filemode .= ':' . $hr_options->{encoding}; + open (my $filehandle, $filemode, $filename) or Interfaces::Interface::Crash("Error opening outputfile [$filename]: $!"); if ($hr_options->{header}) { - print DELIMFILE __PACKAGE__::DelimitedHeader($self) . $self->record_delimiter; + print $filehandle Interfaces::DelimitedFile::DelimitedHeader($self) . $self->record_delimiter; } - foreach my $hr_data (@{$ar_data}) { - print DELIMFILE __PACKAGE__::WriteRecord($self, $hr_data) . $self->record_delimiter; + foreach my $hr_data (@{$ar_data}) { ### Writing [===[%] ] + print $filehandle Interfaces::DelimitedFile::WriteRecord($self, $hr_data) . $self->record_delimiter; } - close (DELIMFILE); + close ($filehandle); } ## end sub WriteData ($$$) -# ReadRecord ($data) returns $hr_record -method ReadRecord (Str $inputstring !) { +# ReadRecord ($inputstring) returns $hr_record +method ReadRecord(Str $inputstring !, HashRef $hr_options ?) { + # Default options + $hr_options->{trim} //= 1; + if (!$self->has_field_delimiter) { - Carp::confess("Field-delimiter is not set"); + Interfaces::Interface::Crash("Field-delimiter is not set"); } - # Use all columns specified in useinfile + my $original_input = $inputstring; # Backup for debug dumps my $hr_returnvalue = {}; my $input_column_index = 0; + my $max_input_columns = List::Util::max(keys %{$self->{DelimitedFile_hr_fileindex}}); my $output_column_index = -1; my $field_value; - my $delimiter = $self->field_delimiter; - my $thousandseparator = $self->thousandseparator; - my $decimalseparator = $self->decimalseparator; - my ($CurrentColumnDecimals, $CurrentColumnDatatype); - while ($inputstring) { + my $delimiter = $self->{field_delimiter}; + my $escapechar = $self->{escapechar}; + my $thousandseparator = $self->{thousandseparator}; + my $decimalseparator = $self->{decimalseparator}; + my ($CurrentColumnDecimals, $CurrentColumnDatatype, $current_field_default); + while ($inputstring ne '' or $input_column_index <= $max_input_columns) { undef $field_value; $output_column_index = $self->{DelimitedFile_hr_fileindex}->{$input_column_index}; if (!defined $output_column_index) { Carp::carp("Line read: [$inputstring]"); - Carp::confess("Column index [$input_column_index] not found in DelimitedFile_hr_fileindex. Have you used ConfigureUseInFile or ParseHeaders? (Or are there more fields in the file than you defined)"); + Interfaces::Interface::Crash("Column index [$input_column_index] not found in DelimitedFile_hr_fileindex. Have you used ConfigureUseInFile or ParseHeaders? (Or are there more fields in the file than you defined)"); } $CurrentColumnDecimals = $self->{decimals}->[$output_column_index]; $CurrentColumnDatatype = $self->{datatype}->[$output_column_index]; + $current_field_default = $self->{default}->[$output_column_index]; if (substr($inputstring,0,1) eq '"') { # 7707749 6.07s $field_value = $inputstring; - if ($inputstring =~ /^"(([^"]|"")+)"(?:[$delimiter]|$)/p) { + my $qr_match = $escapechar ne '' ? $self->{ESCAPEFIELD_ESCAPECHAR_INPUT1} : $self->{ESCAPEFIELD_NONESCAPE_INPUT1}; + if ($inputstring =~ /$qr_match/p) { ($field_value, $inputstring) = ($1, ${^POSTMATCH}); # Unescape escaped quotes $field_value =~ s/""/"/g; } else { - Carp::confess("Parsing error with data [$inputstring], current index [$input_column_index]"); + Interfaces::Interface::Crash("Parsing error with data [$inputstring], current index [$input_column_index]"); } } else { $field_value = $inputstring; - if ($inputstring =~ /^([^$delimiter"]*)(?:[$delimiter]|$)/p) { + my $qr_match = $escapechar ne '' ? $self->{NONESCAPE_ESCAPECHAR_INPUT1} : $self->{NONESCAPE_NONESCAPE_INPUT1}; + if ($inputstring =~ /$qr_match/p) { ($field_value, $inputstring) = ($1, ${^POSTMATCH}); } } ## end else [ if ($inputstring =~ /^"/)] + if ($Interfaces::Interface::DEBUGMODE) { + Carp::carp("Field [$self->{columns}->[$output_column_index]] read with value [$field_value]"); + } if ($output_column_index >= 0) { - if ($self->{internal_datatype}->[$output_column_index]->{type} >= Interfaces::DATATYPE_NUMERIC) { - if ($field_value eq '') { - $field_value = '0'; - } elsif ($thousandseparator) { - # Remove thousandseparator, if present - while (my $ts_loc = index($field_value, $thousandseparator) + 1) { - substr($field_value, $ts_loc - 1, 1) = ''; + # Trim field + if ($hr_options->{trim}) { + $field_value =~ s/^\s+//; + $field_value =~ s/\s+$//; + } + if ($field_value eq '') { + undef $field_value; + } + if (!defined $field_value && !$self->{allownull}->[$output_column_index] && !$self->{read_defaultvalues}) { + + Data::Dump::dd($original_input); + Interfaces::Interface::Crash('Input Field [' . $input_column_index . '], output [' . $output_column_index . '].[' . $self->{columns}->[$output_column_index] . '] requires a value, but has none, and no default value either'); + } + if ($self->{internal_datatype}->[$output_column_index] >= $Interfaces::Interface::DATATYPE_NUMERIC) { + if (!defined $field_value) { + if (!$self->{allownull}->[$output_column_index]) { + if (defined $current_field_default) { + if ($self->{read_defaultvalues}) { + $field_value = 0 + $current_field_default; + } + } + } else { + $input_column_index++; + next; } - } - # MinMax boundary check and fix - $field_value = $self->minmax($output_column_index, $field_value); - if ($CurrentColumnDecimals and $self->{internal_datatype}->[$output_column_index]->{type} > Interfaces::DATATYPE_NUMERIC) { # Field is a type that has decimals (FLOAT, NUMERIC etc) - # Compensate for decimalseparators other than period, change them to . - if (not $field_value =~ s/\Q${decimalseparator}\E/\./ and not index($field_value, '.') + 1) { - # There were no $decimalseparators present and there is no period present in $field_value - $field_value .= '.'; + } else { + $field_value = 0 + $field_value; + if ($self->{speedy} && $field_value == ($current_field_default // 0) && $self->{allownull}->[$output_column_index] && !$self->{read_defaultvalues}) { + # Skip numeric fields that equal (default value // 0) + $input_column_index++; + next; + } + if (!$self->{speedy}) { + # Check if there are trailing negators, and fix it to be a heading negator + if (substr($field_value, -1) eq '-') { + #$field_value =~ s/^(.*)-$/-$1/; # 11.2s, 2.67s + $field_value = '-' . substr($field_value, 0, -1); + } + if (defined $thousandseparator and $thousandseparator ne '') { + # Remove thousandseparator, if present + while (my $ts_loc = index($field_value, $thousandseparator) + 1) { + substr($field_value, $ts_loc - 1, 1) = ''; + } + } + # Range check + $field_value = $self->minmax($output_column_index, $field_value); } - $field_value = "0$field_value" if substr($field_value, 0, 1) eq '.'; # 971565 1.45s - $field_value .= '0' x $CurrentColumnDecimals; # 971565 725ms - $field_value =~ s/(\.[0-9]{$CurrentColumnDecimals}).+/$1/; # Trim trailing digits to max $CurrentColumnDecimals # 971565 9.83s 3886260 3.86s } - $hr_returnvalue->{$self->{columns}->[$output_column_index]} = 0 + $field_value; - } else { - if ($field_value eq '') { - # Store default value or undef (if no default value exists) - if (defined $self->{default}->[$output_column_index]) { - $hr_returnvalue->{$self->{columns}->[$output_column_index]} = $self->{default}->[$output_column_index]; + $hr_returnvalue->{$self->{columns}->[$output_column_index]} = $field_value; + } else { # Not DATATYPE_NUMERIC + if (!defined $field_value) { + if (!$self->allownull->[$output_column_index] && $self->{read_defaultvalues} && defined $current_field_default) { + # If NULL values are not allowed, store default value or undef (if no default value exists) + $hr_returnvalue->{$self->{columns}->[$output_column_index]} = $current_field_default; } # else don't store the value at all..saves a key-value pair } else { @@ -273,9 +327,9 @@ method ReadRecord (Str $inputstring !) { # ParseHeaders ($headerstring) # Matches headers in string with @self->displayname and sets useinfile=1 for the matching headers # Also sets the matching header's fileindex to the columnnumber (0-based) where the header matched in the string. -method ParseHeaders (Str $inputstring !) { - if (!$self->has_field_delimiter or !$self->has_record_delimiter) { - Carp::confess("Field- or Record-delimiter is not set"); +method ParseHeaders(Str $inputstring !) { + if (!$self->has_field_delimiter || !$self->has_record_delimiter) { + Interfaces::Interface::Crash("Field- or Record-delimiter is not set"); } # Zero all useinfiles and fileindex for (0 .. $#{$self->columns}) { @@ -284,7 +338,7 @@ method ParseHeaders (Str $inputstring !) { } my $num_file_index = 0; my $delimiter = $self->field_delimiter; - while ($inputstring) { + while ($inputstring ne '') { my $header = $inputstring; if ($inputstring =~ /^"(([^"]|"")*)"(?:[$delimiter]|$)/) { ($header, $inputstring) = ($1, ${^POSTMATCH}); @@ -302,10 +356,105 @@ method ParseHeaders (Str $inputstring !) { } ## end while ($inputstring) } ## end sub ParseHeaders ($$) +# reconfigure_and_read(filename) +# Creates columns "Column_nn" for each column detected in inputstring with type "VARCHAR(max detected length * 2)" +# returns data read +method reconfigure_and_read(Str $filename !, HashRef $hr_options ?) { + if (!$self->has_field_delimiter || !$self->has_record_delimiter) { + Interfaces::Interface::Crash("Field- or Record-delimiter is not set"); + } + $hr_options->{no_header} = $hr_options->{no_header} // 0; + $hr_options->{skip_header} = $hr_options->{skip_header} // 0; + if ($hr_options->{no_header}) { + $hr_options->{skip_header} = 0; + } + my ($field_delimiter, $record_delimiter, $escapechar) = ($self->field_delimiter, $self->record_delimiter, $self->escapechar); + my $ar_returnvalue = []; + my $record; + my $ar_maxlen = []; + my $ar_allownull = []; + my $old_INPUT_RECORD_SEPARATOR = $/; + local $/ = $record_delimiter; + open (my $filehandle, '<', $filename) or Interfaces::Interface::Crash("Cannot open file [$filename]: $!"); + + while (<$filehandle>) { ### Reading [===[%] ] + chomp; + $record = $_; + # If a line contains an odd amount of doublequotes ("), then we'll need to continue reading until we find another line that contains an odd amount of doublequotes. + # This is in order to catch fields that contain recordseparators (but are encased in ""'s). + if (($escapechar // '' ) ne '' and grep { $_ eq $escapechar; } split ('', $_) % 2 == 1) { # 64771 8.75s + # Keep reading data and appending to $record until we find another line with an odd number of doublequotes. + while (<$filehandle>) { + $record .= $_; + if (grep { $_ eq $escapechar; } split ('', $_) % 2 == 1) { last; } + } + } ## end if (grep ($_ eq '"', split...)) + # Read line + $hr_options->{trim} //= 1; + my $input_column_index = 0; + my $hr_record = {}; + while ($record ne '') { + $ar_allownull->[$input_column_index] //= 0; + $ar_maxlen->[$input_column_index] //= 0; + my $field_value; + if (substr($record,0,1) eq $escapechar) { # 7707749 6.07s + $field_value = $record; + my $qr_match = $escapechar ne '' ? $self->{ESCAPEFIELD_ESCAPECHAR_INPUT1} : $self->{ESCAPEFIELD_NONESCAPE_INPUT1}; + if ($record =~ /$qr_match/p) { + ($field_value, $record) = ($1, ${^POSTMATCH}); + # Unescape escaped quotes + $field_value =~ s/""/"/g; + } else { + Interfaces::Interface::Crash("Parsing error with data [$record], current index [$input_column_index]"); + } + } else { + $field_value = $record; + my $qr_match = $escapechar ne '' ? $self->{NONESCAPE_ESCAPECHAR_INPUT1} : $self->{NONESCAPE_NONESCAPE_INPUT1}; + if ($record =~ /$qr_match/p) { + ($field_value, $record) = ($1, ${^POSTMATCH}); + } + } ## end else [ if ($record =~ /^"/)] + if ($Interfaces::Interface::DEBUGMODE >= 2) { + Carp::carp("Field [$input_column_index] read with value [$field_value]"); + } + # Since we're assuming all fields as VARCHAR, we don't have to perform any of the numerical checks/fixes + # Trim field + if ($hr_options->{trim}) { + $field_value =~ s/^\s*(.*?)\s*$/$1/; + } + if (length($field_value) > $ar_maxlen->[$input_column_index]) { + $ar_maxlen->[$input_column_index] = length($field_value); + } + if ($field_value eq '') { + $field_value = undef; + $ar_allownull->[$input_column_index] |= 1; + } + $hr_record->{'Column_' . $input_column_index} = $field_value; + $input_column_index++; + } + push (@{$ar_returnvalue}, $hr_record); + } ## end while () + close ($filehandle); + # Configure interface + $self->ClearConfig(); # Scary + $self->name($hr_options->{name} // ('Generated' . time)); + $self->field_delimiter($field_delimiter); + $self->record_delimiter($record_delimiter); + $self->escapechar($escapechar); + foreach my $index (0 .. $#$ar_maxlen) { + if ($ar_maxlen->[$index] == 0) { $ar_maxlen->[$index]++; } # Avoid VARCHAR(0) + $self->AddField({ fieldname => 'Column_' . $index, displayname => 'Column ' . $index, allownull => $ar_allownull->[$index], datatype => 'VARCHAR', length => 2 * $ar_maxlen->[$index], }); + $self->{DelimitedFile_ar_useinfile}->[$index] = 1; + $self->{DelimitedFile_hr_fileindex}->{$index} = $index; + } + $self->Check(); + return $ar_returnvalue; +} + # ConfigureUseInFile ($ar_headers) # Matches headers in $ar_headers with @self->displayname and sets useinfile=1 for the matching headers # Also sets the matching header's fileindex to the columnnumber (0-based) where the header matched in the arrayref. -method ConfigureUseInFile (ArrayRef $ar_headers !) { +method ConfigureUseInFile(ArrayRef $ar_headers !) { # Zero all useinfiles and fileindex for (0 .. $#{$self->columns}) { $self->{DelimitedFile_ar_useinfile}->[$_] = 0; @@ -329,54 +478,48 @@ method ConfigureUseInFile (ArrayRef $ar_headers !) { # ReadFile ($filename, [$hr_options]) returns \@data with \%records # Options consist of: skip_header = 0 | 1 # Skip the header in the file (default = 0) # no_header = 0 | 1 # There is no header in the file (default = 0) (implies skip_header=0) -method ReadData (Str $filename !, HashRef $hr_options ?) { - if (ref($filename) ne '') { - Carp::confess "1st Argument passed is a reference (expected text)"; - } - if (!$self->has_field_delimiter or !$self->has_record_delimiter) { - Carp::confess("Field- or Record-delimiter is not set"); +method ReadData(Str $filename !, HashRef $hr_options ?) { + if (!$self->has_field_delimiter || !$self->has_record_delimiter) { + Interfaces::Interface::Crash("Field- or Record-delimiter is not set"); } - no strict qw(refs); $hr_options->{no_header} = $hr_options->{no_header} // 0; $hr_options->{skip_header} = $hr_options->{skip_header} // 0; if ($hr_options->{no_header}) { $hr_options->{skip_header} = 0; } my $ar_returnvalue = []; + my $record; my $old_INPUT_RECORD_SEPARATOR = $/; - $/ = $self->record_delimiter; - open (DELIMFILE, '<', $filename) or Carp::confess("Cannot open file [$filename]: $!"); + local $/ = $self->record_delimiter; + open (my $filehandle, '<', $filename) or Interfaces::Interface::Crash("Cannot open file [$filename]: $!"); if (!$hr_options->{no_header}) { # There is a header - my $Headers = ; + my $Headers = <$filehandle>; chomp($Headers); if ($hr_options->{skip_header}) { if (scalar keys (%{$self->{DelimitedFile_hr_fileindex}}) == 0) { - Carp::confess("ReadData called but no fields have been configured to use and the option to skip the header was given (which means no fields will be autoconfigured for use either)."); + Interfaces::Interface::Crash("ReadData called but no fields have been configured to use and the option to skip the header was given (which means no fields will be autoconfigured for use either)."); } } else { - &{__PACKAGE__ . '::ParseHeaders'}($self, $Headers); + Interfaces::DelimitedFile::ParseHeaders($self, $Headers); } } - - my $record; - while () { + while (<$filehandle>) { ### Reading [===[%] ] chomp; $record = $_; # If a line contains an odd amount of doublequotes ("), then we'll need to continue reading until we find another line that contains an odd amount of doublequotes. # This is in order to catch fields that contain recordseparators (but are encased in ""'s). - if (grep ($_ eq '"', split ('', $_)) % 2 == 1) { # 64771 8.75s + if (grep { $_ eq '"'; } split ('', $_) % 2 == 1) { # 64771 8.75s # Keep reading data and appending to $record until we find another line with an odd number of doublequotes. - while () { + while (<$filehandle>) { $record .= $_; - if (grep ($_ eq '"', split ('', $_)) % 2 == 1) { last; } + if (grep { $_ eq '"'; } split ('', $_) % 2 == 1) { last; } } } ## end if (grep ($_ eq '"', split...)) - push (@{$ar_returnvalue}, &{__PACKAGE__ . '::ReadRecord'}($self, $record)); + push (@{$ar_returnvalue}, Interfaces::DelimitedFile::ReadRecord($self, $record)); } ## end while () - close (DELIMFILE); - $/ = $old_INPUT_RECORD_SEPARATOR; - use strict qw(refs); + close ($filehandle); + #print("Returning size: [" . Devel::Size::total_size($ar_returnvalue) . "]\n"); return $ar_returnvalue; } ## end sub ReadData ($$) @@ -384,41 +527,34 @@ method ReadData (Str $filename !, HashRef $hr_options ?) { =head1 NAME -Interfaces::DelimitedFile - DelimitedFile format extension to Interfaces::Interface +Interfaces::DelimitedFile - Delimited file format extension to Interfaces::Interface =head1 VERSION -This document refers to Interfaces::Interface version 0.10. +This document refers to Interfaces::DelimitedFile version 2.0.0. =head1 SYNOPSIS use Interfaces::Interface; my $interface = Interfaces::Interface->new(); $interface->ReConfigureFromHash($hr_config); - $interface->Delimiter(','); - my $ar_data = $interface->ReadData("foobar.csv"); - $interface->WriteData("foobar.csv", $ar_data); + my $ar_data = $interface->DelimitedFile_ReadData("foobar.csv"); + $interface->DelimitedFile_WriteData("foobar.csv", $ar_data); =head1 DESCRIPTION This module extends the Interfaces::Interface with the capabilities to read from - and -write to files in a character-delimited layout. +write to files in a character or string-delimited file. =head2 Attributes for C =over 4 -=item * C -Contains delimiter character used to seperate fields in a record. - -=item * C -Contains a boolean value to indicate whether the values need to be read in Microsoft Excel. This saves values as ="value" instead of just the value. +=item * C +Contains the field-delimiter character (or string). This is ',' by default. -=item * C -Contains the character used as separator for numeric values between the whole part and the fractional part. - -=item * C -Contains the character used as a separator of thousands, e.g.: 1,000,000. +=item * C +Contains the record-delimiter character (or string). This is "\r\n" by default. =back @@ -426,34 +562,53 @@ Contains the character used as a separator of thousands, e.g.: 1,000,000. =over 4 -=item * C<$interface-EReadRecord($line_of_text);> +=item * C<$interface-EDelimitedHeader();> -Parses the supplied line of text as a character-delimited record. Returns a hashref with the data with the columnnames as key. +Returns a string containing all headers specified to be used in file separated by the field_delimiter. +The record_separator is not appended to the resulting string. -=item * C<$interface-EWriteRecord($hr_data);> +=item * C<$interface-EConfigureUseInFile($ar_headers);> -Converts the supplied hashref datarecord to a line of text. Returns a string of text containing the character-delimited data. +Supplied an arrayref of strings, matches those with $self->displayname to determine which columns in +the file are to be linked with which columns of the interface. -=item * C<$interface-EReadData($fullpath_to_file);> +=item * C<$interface-EParseHeaders($headerstring);> -Reads the given file, decodes it and returns its data as an arrayref with a hashref per datarecord. -As per RFC 4180, records are terminated by a CRLF. Fields can contain CRLF as data, but need to be escaped using "". +Performs an identical function to ConfigureUseInFile, except this takes a string from which it extracts +the headers. -=item * C<$interface-EWriteData($fullpath_to_file, $ar_data);> +=item * C<$interface-EReadRecord($string);> -Writes the supplied data in character-delimited format to the given file. If the file already existed, it is overwritten, otherwise it is created. +Parses the supplied line of text as a character/string-delimited record. Returns an hashref with the data +with the columnnames as key. Only reads the columns configured by ConfigureUseInFile or ParseHeaders. +If $self->thousandseparator is configured, it is removed from the data read. +If $self->decimalseparator is configured, it is replaced in the data by a period (thus enabling the value to +be properly parsed). -=item * C<$interface-EConfigureUseInFile($ar_headers);> +=item * C<$interface-EWriteRecord($hr_data);> + +Converts the supplied hashref datarecord to a line of text. Returns a string of text containing the +character/string-delimeted data. The record_separator is not appended to the resulting string. + +=item * C<$interface-EReadData($fullpath_to_file, $hr_options);> + +Options consist of: skip_header = 0 | 1 # Skip the header in the file (default = 0) + no_header = 0 | 1 # There is no header in the file (default = 0) (implies skip_header=0) + +Reads the given file and returns its data as an arrayref with a hashref per datarecord. +If the header is to be parsed (skip_header == 0 and no_header == 0), it is read and parsed with ParseHeaders. -Matches headers in $ar_headers with @self->displayname and sets useinfile=1 for the matching headers. -Also sets the matching header's fileindex to the columnnumber (0-based) where the header matched in the arrayref. -Used to match the index of the various columns in the data with the index of the matching columns in the interface +=item * C<$interface-EWriteData($fullpath_to_file, $ar_data, $hr_options);> +Writes the given data to the file specified by $fullpath_to_file. +Options consist of: header = 0 | 1 # Write a header to the file (default = 1) + append = 0 | 1 # Append to file (default = 0) + =back =head1 DEPENDENCIES -L, L, L and L +L, L and L. =head1 AUTHOR diff --git a/Interfaces/ExcelBinary.pm b/Interfaces/ExcelBinary.pm old mode 100644 new mode 100755 index 8f5666e..91479f7 --- a/Interfaces/ExcelBinary.pm +++ b/Interfaces/ExcelBinary.pm @@ -1,84 +1,37 @@ package Interfaces::ExcelBinary; +# Version 0.11 30-08-2012 +# Copyright (C) OGD 2011-2012 + # Interfaces with the BIFF-excel format (.xls) +use v5.10; +use Smart::Comments; use Moose::Role; # automatically turns on strict and warnings -use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater -use MooseX::Method::Signatures; -use Spreadsheet::ParseExcel; +use Spreadsheet::ParseExcel::Stream; use Spreadsheet::WriteExcel; use List::Util; +use MooseX::Method::Signatures; +no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater # Private attributes has 'ExcelBinary_ar_useinfile' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 0,); has 'ExcelBinary_ar_fileindex' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 0,); has 'ExcelBinary_hr_reversefileindex' => (is => 'rw', isa => 'HashRef[Int]', lazy_build => 0,); -has 'ExcelBinary_datatypes' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 0,); - -BEGIN { - @Interfaces::ExcelBinary::methods = qw(ReadRecord WriteRecord ReadData WriteData ConfigureUseInFile); -} - -# Scan for roles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; -} - -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } -} - -use strict; after 'Check' => sub { my $self = shift; - print ("Checking ExcelBinary constraints..."); # Check if all fields that are marked with "useinfile" have a displayname for (0 .. $#{$self->columns}) { - if ($self->{ExcelBinary_ar_useinfile}->[$_] and !($self->displayname->[$_] // "")) { - Carp::confess("ExcelBinary field [" . $self->columns->[$_] . "] is configured to be used, but has no displayname"); + if ($self->{ExcelBinary_ar_useinfile}->[$_] && !($self->displayname->[$_] // "")) { + Interfaces::Interface::Crash("ExcelBinary field [" . $self->columns->[$_] . "] is configured to be used, but has no displayname"); } } - # Init datatypes for speed (saves having to do regexes for each ReadRecord call) - foreach my $index (0 .. $#{$self->columns}) { - given ($self->datatype->[$index]) { - when (/^(CHAR|VARCHAR|DATE|TIME|DATETIME)$/) { $self->{ExcelBinary_datatypes}->[$index] = Interfaces::DATATYPE_TEXT; } - when (/^(TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT|FLOAT|DOUBLE|DECIMAL|NUMERIC)$/) { $self->{ExcelBinary_datatypes}->[$index] = Interfaces::DATATYPE_NUMERIC; } - default { $self->{ExcelBinary_datatypes}->[$index] = 0; } - } - } - print("[OK]\n"); }; # ConfigureUseInFile ($ar_headers) # Matches headers in $ar_headers with @self->displayname and sets useinfile=1 for the matching headers # Also sets the matching header's fileindex to the columnnumber (0-based) where the header matched in the arrayref. -method ConfigureUseInFile (ArrayRef $ar_headers !) { +method ConfigureUseInFile(ArrayRef $ar_headers !) { # Zero all useinfiles and fileindex for (0 .. $#{$self->columns}) { $self->{ExcelBinary_ar_useinfile}->[$_] = 0; @@ -87,11 +40,15 @@ method ConfigureUseInFile (ArrayRef $ar_headers !) { $self->{ExcelBinary_hr_reversefileindex} = {}; my $num_file_index = 0; foreach my $header (@{$ar_headers}) { - my $HeaderIndex = SleLib::IndexOf($header, @{$self->displayname}); - if ($HeaderIndex >= 0) { - $self->{ExcelBinary_ar_useinfile}->[$HeaderIndex] = 1; - $self->{ExcelBinary_ar_fileindex}->[$HeaderIndex] = $num_file_index; - $self->{ExcelBinary_hr_reversefileindex}->{$num_file_index} = $HeaderIndex; + my $header_index = -1; + foreach (@{$self->displayname}) { + $header_index++; + last if $header eq $_ && !defined $self->{ExcelBinary_ar_fileindex}->[$header_index]; + } + if ($header_index >= 0) { + $self->{ExcelBinary_ar_useinfile}->[$header_index] = 1; + $self->{ExcelBinary_ar_fileindex}->[$header_index] = $num_file_index; + $self->{ExcelBinary_hr_reversefileindex}->{$num_file_index} = $header_index; } else { Carp::carp("Header [$header] not found\n"); } @@ -101,40 +58,37 @@ method ConfigureUseInFile (ArrayRef $ar_headers !) { # ReadRecord (Worksheet, Row) returns $hr_data # Reads a row of data from an opened SpreadSheet::Worksheet-object -method ReadRecord ($WorkSheet !, Int $CurrentRow !) { - if (List::Util::sum($self->{ExcelBinary_ar_fileindex}) == 0) { Carp::confess("Error: No headers have been identified or ConfigureUseInFile never used."); } +method ReadRecord($WorkSheet, $CurrentRow) { + if (List::Util::sum($self->{ExcelBinary_ar_fileindex}) == 0) { Interfaces::Interface::Crash("Error: No headers have been identified or ConfigureUseInFile never used."); } my ($MinCol, $MaxCol) = $WorkSheet->col_range(); - if ($MaxCol < $MinCol) { Carp::confess("Error: The worksheet [" . $WorkSheet->get_name() . "] has no data (cols)"); } + if ($MaxCol < $MinCol) { Interfaces::Interface::Crash("Error: The worksheet [" . $WorkSheet->get_name() . "] has no data (cols)"); } my $hr_data = {}; for (my $CurrentCol = $MinCol ; $CurrentCol < $MaxCol ; $CurrentCol++) { +#print("Reading from [$CurrentRow, CurrentCol]: " . $WorkSheet->get_cell($CurrentRow, $CurrentCol)->value . "\n"); $hr_data->{$self->columns->[$self->{ExcelBinary_hr_reversefileindex}->{$CurrentCol}]} = $WorkSheet->get_cell($CurrentRow, $CurrentCol)->value; } - print ("Returning record with size [" . Devel::Size::total_size($hr_data) . "]\n"); + #print ("Returning record with size [" . Devel::Size::total_size($hr_data) . "]\n"); return $hr_data; } ## end sub ReadRecord ($$$) # WriteRecord ($WorkSheet, $CurrentRow, $hr_data) # Writes data in $hr_data to $CurrentRow in $WorkSheet -method WriteRecord ($WorkSheet !, Int $CurrentRow !, HashRef $hr_data !) { +method WriteRecord($WorkSheet, $CurrentRow, HashRef $hr_data !) { for my $column (0 .. $#{$self->columns}) { - # if (!$self->useinfile->[$column]) { next; } if (!$self->{ExcelBinary_ar_useinfile}->[$column]) { next; } - if (!defined $hr_data->{$self->columns->[$column]}) { + if (!defined $hr_data->{$self->{columns}->[$column]}) { #$WorkSheet->write_blank($CurrentRow, $self->fileindex->[$column]); # This is stupid, let's not write anything here at all :) next; } - given ($self->datatype->[$column]) { - when (/CHAR|VARCHAR|TEXT/i) { - # $WorkSheet->write_string($CurrentRow, $self->fileindex->[$column], $hr_data->{$self->columns->[$column]}); - $WorkSheet->write_string($CurrentRow, $self->{ExcelBinary_ar_fileindex}->[$column], $hr_data->{$self->columns->[$column]}); + given ($self->{internal_datatype}->[$column]) { + when ($Interfaces::Interface::DATATYPE_TEXT) { + $WorkSheet->write_string($CurrentRow, $self->{ExcelBinary_ar_fileindex}->[$column], $hr_data->{$self->{columns}->[$column]}); } - when (/FLOAT|DOUBLE|TINYINT|SMALLINT|MEDIUMINT|INT|BIGINT|INTEGER/i) { - # $WorkSheet->write_number($CurrentRow, $self->fileindex->[$column], $hr_data->{$self->columns->[$column]}); - $WorkSheet->write_number($CurrentRow, $self->{ExcelBinary_ar_fileindex}->[$column], $hr_data->{$self->columns->[$column]}); + when ($_ >= $Interfaces::Interface::DATATYPE_NUMERIC) { + $WorkSheet->write_number($CurrentRow, $self->{ExcelBinary_ar_fileindex}->[$column], $hr_data->{$self->{columns}->[$column]}); } default { - # $WorkSheet->write($CurrentRow, $self->fileindex->[$column], $hr_data->{$self->columns->[$column]}); - $WorkSheet->write($CurrentRow, $self->{ExcelBinary_ar_fileindex}->[$column], $hr_data->{$self->columns->[$column]}); + $WorkSheet->write($CurrentRow, $self->{ExcelBinary_ar_fileindex}->[$column], $hr_data->{$self->{columns}->[$column]}); } } ## end given } ## end for my $column (0 .. $#...) @@ -144,57 +98,37 @@ method WriteRecord ($WorkSheet !, Int $CurrentRow !, HashRef $hr_data !) { # Writes headers (displaynames of columns with useinfile == 1) to row 0 in $WorkSheet method WriteHeaders ($WorkSheet !) { my $ColumnID = 0; - # foreach my $Header (map { $self->{displayname}->[$_]; } grep { $self->{useinfile}->[$_]; } (0 .. $#{$self->{columns}})) { foreach my $Header (map { $self->{displayname}->[$_]; } grep { $self->{ExcelBinary_ar_useinfile}->[$_]; } (0 .. $#{$self->{columns}})) { $WorkSheet->write(0, $ColumnID++, $Header); } } ## end sub WriteHeaders # ReadData (Filename, { options }) returns $ar_data -# Reads data from the given file (which should be a BIFF-formatted .xls-file) and the given worksheet (by name or number (0-based)). -# If the supplied worksheetID is a number, a negative number -n will refer to the n-to-last worksheet. +# Reads data from the given file (which should be a BIFF-formatted .xls-file) and the given worksheet (by number (0-based)). # Options consist of: -# WorksheetID | Name or Number of target worksheet +# WorksheetID | Number of target worksheet (base 0) # skip_header = 0 | 1 # Skip the header in the file (default = 0) # no_header = 0 | 1 # There is no header in the target file/worksheet (default = 0) (implies skip_header=0) method ReadData (Str $FileName !, HashRef $hr_options ?) { - if (defined $hr_options and ref($hr_options) ne 'HASH') { Carp::confess "Options-argument is not a hashref"; } - if (!defined $FileName or !-e $FileName) { Carp::confess("File [$FileName] does not exist."); } - $hr_options->{no_header} = $hr_options->{no_header} // 0; - $hr_options->{skip_header} = $hr_options->{skip_header} // 0; + if (!-e $FileName) { Carp::confess("File [$FileName] does not exist."); } + $hr_options->{no_header} //= 0; + $hr_options->{skip_header} //= 0; + $hr_options->{trim} //= 1; if ($hr_options->{no_header}) { $hr_options->{skip_header} = 0; } -# $Interface::ExcelBinary::myself = $self; - my $ExcelParser = Spreadsheet::ParseExcel->new( - # CellHandler => \&cell_handler, - # NotSetCell => 1, - ); - my $WorkBook = $ExcelParser->parse($FileName); - - if (!defined $WorkBook) { Carp::confess("Error parsing [$FileName]: " . $ExcelParser->error()); } + + my $ExcelParser = Spreadsheet::ParseExcel::Stream->new($FileName); $hr_options->{worksheet_id} //= 0; # Default to 0 (the first sheet) if not supplied - my $WorkSheet; - if ($hr_options->{worksheet_id} < 0) { - my @WorkSheets = $WorkBook->worksheets(); - $WorkSheet = $WorkSheets[$hr_options->{worksheet_id}]; # Allow for a fetch-n-before-last - } else { - $WorkSheet = $WorkBook->worksheet($hr_options->{worksheet_id}); # Allow for a fetch-by-name + my $WorkSheet = $ExcelParser->sheet(); + while ($hr_options->{worksheet_id}--) { + $WorkSheet = $ExcelParser->sheet(); } if (!defined $WorkSheet) { Carp::confess("Error: The requested worksheet [$hr_options->{worksheet_id}] does not exist in [$FileName]"); } - my ($MinCol, $MaxCol) = $WorkSheet->col_range(); - my ($MinRow, $MaxRow) = $WorkSheet->row_range(); - if (!$hr_options->{no_header} and !$hr_options->{skip_header}) { + if (!$hr_options->{no_header} && !$hr_options->{skip_header}) { # Read headers - if ($MaxCol < $MinCol) { Carp::confess("Error: The worksheet [$hr_options->{worksheet_id}] has no data (cols)"); } - if ($MaxRow < $MinRow) { Carp::confess("Error: The worksheet [$hr_options->{worksheet_id}] has no data (rows)"); } - my @ExcelHeaders; - for (my $CurrentCol = $MinCol ; $CurrentCol <= $MaxCol ; $CurrentCol++) { - push (@ExcelHeaders, $WorkSheet->get_cell($MinRow, $CurrentCol)->value); - } - Interfaces::ExcelBinary::ConfigureUseInFile($self, \@ExcelHeaders); - $MinRow++; + Interfaces::ExcelBinary::ConfigureUseInFile($self, $WorkSheet->unformatted()); } if (List::Util::sum($self->{ExcelBinary_ar_fileindex}) == 0) { @@ -206,38 +140,72 @@ method ReadData (Str $FileName !, HashRef $hr_options ?) { Carp::confess("Error: The worksheet [$hr_options->{worksheet_id}] does not contain any identifiable headers"); } } - $MinRow++; # Read data my $ar_data = []; my $Current_Cell = undef; - my ($CurrentColumnIndex, $CurrentColumnDecimals); - for (my $CurrentRow = $MinRow ; $CurrentRow <= $MaxRow ; $CurrentRow++) { + my $row_nr = 0; + my ($CurrentColumnIndex, $CurrentColumnDecimals, $current_field_default, $field_value); + while (my $row = $WorkSheet->unformatted()) { ### Reading [===[%] ] + $row_nr++; +#Data::Dump::dd($row); my $hr_data = {}; - for (my $CurrentCol = $MinCol ; $CurrentCol <= $MaxCol ; $CurrentCol++) { - $Current_Cell = $WorkSheet->get_cell($CurrentRow, $CurrentCol); - $CurrentColumnIndex = $Interfaces::ExcelBinary::hr_reversefileindex->{$CurrentCol}; - my $CurrentColumn = undef; - my $CurrentColumnValue; - if (defined $Current_Cell) { - $CurrentColumnDecimals = $self->decimals->[$CurrentColumnIndex]; - if ($self->datatype->[$CurrentColumnIndex] =~ /^(?:TINYINT|MEDIUMINT|SMALLINT|INT|INTEGER|BIGINT)$/) { - $CurrentColumn->{$CurrentColumnIndex} = 0 + $Current_Cell->value; # create a numeric value. - } elsif ($self->datatype->[$CurrentColumnIndex] =~ /^(?:FLOAT|DOUBLE)$/ and $CurrentColumnDecimals > 0) { - $CurrentColumn->{$CurrentColumnIndex} = "" . $Current_Cell->value; - if ($CurrentColumn->{$CurrentColumnIndex} !~ /\./p) { - # Add period and trailing zeroes if required (and not present) - $CurrentColumn->{$CurrentColumnIndex} .= '.' . '0' x $CurrentColumnDecimals; - } elsif (length ${^POSTMATCH} < $CurrentColumnDecimals) { - $CurrentColumn->{$CurrentColumnIndex} .= '0' x ($CurrentColumnDecimals - length (${^POSTMATCH})); + foreach my $CurrentColumnIndex (0 .. $#{$row}) { + $Current_Cell = $row->[$CurrentColumnIndex]; + $CurrentColumnIndex = $self->{ExcelBinary_hr_reversefileindex}->{$CurrentColumnIndex}; + if (!defined $CurrentColumnIndex) { next; } + $current_field_default = $self->{default}->[$CurrentColumnIndex]; + $field_value = undef; + if ($self->{internal_datatype}->[$CurrentColumnIndex] >= $Interfaces::Interface::DATATYPE_NUMERIC) { + $CurrentColumnDecimals = $self->{decimals}->[$CurrentColumnIndex]; + if (!defined $Current_Cell) { + print ('Row [' . $row_nr . '], field [' . $self->{columns}->[$CurrentColumnIndex] . '] has no value' . "\n"); + if (!$self->allownull->[$CurrentColumnIndex]) { + if (defined $current_field_default) { + if ($self->{read_defaultvalues}) { + $field_value = $current_field_default; + } + } else { + Interfaces::Interface::Crash('Field [' . $self->{columns}->[$CurrentColumnIndex] . '] requires a value, but has none, and no default value either'); + } + } else { + next; } } else { - $CurrentColumn->{$CurrentColumnIndex} = $Current_Cell->value; + $field_value = 0 + $Current_Cell; # create a numeric value. + if ($self->{speedy} && $field_value == ($current_field_default // 0) && $self->{allownull}->[$CurrentColumnIndex] && !$self->{read_defaultvalues}) { next; } # Skip numeric fields that equal (default value // 0) + if (!$self->{speedy}) { + $field_value = $self->minmax($CurrentColumnIndex, $field_value); + } } - $hr_data->{$self->columns->[$CurrentColumnIndex]} = $CurrentColumn->{$CurrentColumnIndex}; } else { - $hr_data->{$self->columns->[$CurrentColumnIndex]} = undef; + if (defined $Current_Cell) { + if ($hr_options->{trim}) { + $Current_Cell =~ s/^\s+//; # 6592014 18.8s 6592014 6.05s + $Current_Cell =~ s/\s+$//; # 6592014 12.8s 6592014 2.71s + if ($Current_Cell eq '') { + next; + } else { + $field_value = $Current_Cell; + } + } + } else { + if (!$self->allownull->[$CurrentColumnIndex]) { + if (defined $current_field_default) { + # If NULL values are not allowed, store default value or undef (if no default value exists) + if ($self->{read_defaultvalues}) { + $field_value = $current_field_default + } + } else { + Interfaces::Interface::Crash('Field [' . $self->{columns}->[$CurrentColumnIndex] . '] requires a value, but has none, and no default value either'); + } + } else { + next; + } + # else don't store the value at all..saves a key-value pair + } } - } ## end for (my $CurrentCol = $MinCol...) + $hr_data->{$self->{columns}->[$CurrentColumnIndex]} = $field_value; + } push (@{$ar_data}, $hr_data); } ## end for (my $CurrentRow = $MinRow...) return $ar_data; @@ -246,7 +214,7 @@ method ReadData (Str $FileName !, HashRef $hr_options ?) { # WriteData ($FileName, $ar_data, [$WorkSheetID]) # Writes supplied $ar_data to $FileName in $WorkSheetID # If $FileName exists but $WorkSheetID does not, it will be appended. -method WriteData (Str $FileName !, ArrayRef $ar_data !, $WorkSheetID ?) { +method WriteData (Str $FileName !, ArrayRef $ar_data !, Str $WorkSheetID ?) { my $WorkBook = Spreadsheet::WriteExcel->new($FileName); if (!defined $WorkBook) { Carp::confess("Error opening [$FileName]: $!"); } my @WorkSheets = $WorkBook->sheets(); @@ -268,12 +236,12 @@ method WriteData (Str $FileName !, ArrayRef $ar_data !, $WorkSheetID ?) { } # Configure & Write headers my $targetcolumn = 0; - map { $self->{ExcelBinary_ar_fileindex}->[$_] = $targetcolumn++; } grep { $self->{ExcelBinary_ar_useinfile}->[$_]; } (0 .. $#{$self->columns}); - __PACKAGE__::WriteHeaders($self, $WorkSheet); + map { $self->{ExcelBinary_ar_fileindex}->[$_] = $targetcolumn++; } grep { $self->{ExcelBinary_ar_useinfile}->[$_]; } (0 .. $#{$self->{columns}}); + Interfaces::ExcelBinary::WriteHeaders($self, $WorkSheet); # Write data my $CurrentRow = 1; - foreach my $hr_data (@{$ar_data}) { - __PACKAGE__::WriteRecord($self, $WorkSheet, $CurrentRow++, $hr_data); + foreach my $hr_data (@{$ar_data}) { ### Writing [===[%] ] + Interfaces::ExcelBinary::WriteRecord($self, $WorkSheet, $CurrentRow++, $hr_data); } } ## end sub WriteData @@ -285,7 +253,7 @@ Interfaces::ExcelBinary - Excel BIFF format extension to Interfaces::Interface =head1 VERSION -This document refers to Interfaces::ExcelBinary version 0.10. +This document refers to Interfaces::ExcelBinary version 2.0.0 =head1 SYNOPSIS diff --git a/Interfaces/ExcelX.pm b/Interfaces/ExcelX.pm old mode 100644 new mode 100755 index 7de1601..9798efa --- a/Interfaces/ExcelX.pm +++ b/Interfaces/ExcelX.pm @@ -1,14 +1,14 @@ package Interfaces::ExcelX; # Interfaces with the new excel format (.xlsx) -use Moose::Role; # automatically turns on strict and warnings -use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater +use v5.10; use Smart::Comments; +use Moose::Role; # automatically turns on strict and warnings use Spreadsheet::XLSX; use Excel::Writer::XLSX; use List::Util; use MooseX::Method::Signatures; +no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater BEGIN { $Interfaces::ExcelX::VERSION = '1.0.0'; # 03-01-2012 diff --git a/Interfaces/FlatFile.pm b/Interfaces/FlatFile.pm old mode 100644 new mode 100755 index 315f1a3..3f47f25 --- a/Interfaces/FlatFile.pm +++ b/Interfaces/FlatFile.pm @@ -1,351 +1,297 @@ package Interfaces::FlatFile; +use Smart::Comments; use Moose::Role; -use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater use MooseX::Method::Signatures; use Encode; +use v5.10; +no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater BEGIN { - @Interfaces::FlatFile::methods = qw(ReadRecord WriteRecord ReadData WriteData); -} - -has 'flat_mask' => (is => 'rw', isa => 'Str', lazy_build => 1,); -has 'flat_mask_unpack' => (is => 'rw', isa => 'Str', lazy_build => 1,); -has 'flat_columns' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); -has 'flatfield_start' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); -has 'flatfield_length' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); -has 'internal_datatype' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 0,); -has 'FlatFile_recordlength' => (is => 'rw', isa => 'Maybe[Int]', lazy_build => 1,); - -# Scan for roles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; + $Interfaces::FlatFile::VERSION = '1.2.0'; # 6-02-2013 + # 1.1.1 08-03-2012 HB WriteRecord aangepast zodat deze met mask %-x.xs print ipv %-xs (met x = lengte van het veld) + # 1.2.0 06-02-2013 HB Geoptimaliseerd, datatypes, recordlength als attribuut toegevoegd. } -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } -} +has 'flat_mask' => (is => 'rw', isa => 'Str', lazy_build => 1,); +has 'flat_columns' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); +has 'flatfield_start' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); +has 'flatfield_length' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); +has 'FlatFile_recordlength' => (is => 'rw', isa => 'Maybe[Int]', lazy_build => 1,); +has 'explicit_numeric_separators' => (is => 'rw', isa => 'Bool', lazy_build => 1,); -use strict; +after 'BUILD' => sub { + my $self = shift; + $self->explicit_numeric_separators(0); +}; -#requires qw(columns datatype decimals signed allownull default decimalseparator thousandseparator); +after 'ReConfigureFromHash' => sub { + my $self = shift; + $self->explicit_numeric_separators(0); + $self->clear_flat_mask; +}; -after 'BUILD' => sub { - my $self = shift; - my $hr_args = shift; - # Initialize default values if not better left at undef +after 'AddField' => sub { + my $self = shift; + my ($hr_config) = @_; + $self->clear_flat_mask; }; + after 'Check' => sub { my $self = shift; - print ("Checking Flatfile constraints [" . $self->name . "]..."); - - my $previousfield; - # Search first flatfield - for (0 .. $#{$self->columns}) { + my $previousfield = undef; + # Order the flatfields by flatfield_start + my @fields_ordered = sort { $self->flatfield_start->[$a] <=> $self->flatfield_start->[$b] } grep { defined $self->flatfield_start->[$_] && defined $self->flatfield_length->[$_]; } (0 .. $#{$self->columns}); + for (@fields_ordered) { if (defined $self->flatfield_start->[$_]) { $previousfield = $_; last; } } if (!defined $previousfield) { return; } # Interface does not contain flatfields - for (1 .. $#{$self->columns}) { + for (@fields_ordered) { # Skip check for fields we're not going to use due to not being (fully) configured. - if (!(defined $self->flatfield_start->[$_] and defined $self->flatfield_length->[$_])) { + if (!(defined $self->flatfield_start->[$_] && defined $self->flatfield_length->[$_])) { next; } - if ($self->flatfield_start->[$_] <= $self->flatfield_start->[$previousfield]) { - Carp::confess("Flatfield_start is not always increasing: Column [" . $self->columns->[$_] . "] doesn't start after [" . $self->columns->[$previousfield] . "]"); - } - if ($self->flatfield_start->[$_] < $self->flatfield_start->[$previousfield] + $self->flatfield_length->[$previousfield]) { - Carp::confess("Flatfields [" . $self->columns->[$previousfield] . "] and [" . $self->columns->[$_] . "] overlap"); + if (defined $previousfield && $previousfield != $_) { + if ($self->flatfield_start->[$_] <= $self->flatfield_start->[$previousfield]) { + Interfaces::Interface::Crash("Flatfield_start is not always increasing: Column [" . $self->columns->[$_] . "] doesn't start after [" . $self->columns->[$previousfield] . "]"); + } + if ($self->flatfield_start->[$_] < $self->flatfield_start->[$previousfield] + $self->flatfield_length->[$previousfield]) { + Interfaces::Interface::Crash('Interface [' . $self->name . ']: ' . + 'Flatfields [' . $self->columns->[$previousfield] . '] (' . $self->flatfield_start->[$previousfield] . '/' . $self->flatfield_length->[$previousfield] . ') ' . + 'and [' . $self->columns->[$_] . '] (' . $self->flatfield_start->[$_] . ') overlap'); + } } $previousfield = $_; - } - print ("[OK]\n"); + } ## end for (1 .. $#{$self->columns... + 1; }; -after 'ReConfigureFromHash' => sub { - my $self = shift; - $self->clear_flat_mask; -}; +method generate_flat_mask() { + $self->clear_flat_columns; + my $ar_flat_columns = []; + my $flatline_counter = 0; + my $mask = ""; + foreach my $index (0 .. $#{$self->{columns}}) { + if (!(defined $self->{flatfield_start}->[$index] && defined $self->{flatfield_length}->[$index])) { + # Field is missing interface_start, interface_length or both, skip it. + next; + } + if ($flatline_counter > $self->{flatfield_start}->[$index]) { + Interfaces::Interface::Crash( "Error in interface [" + . $self->{tablename} + . "]: field [" + . $self->{columns}->[$index] + . "] starts at position [" + . $self->{flatfield_start}->[$index] + . "] but we have already [$flatline_counter] bytes of data."); + } ## end if ($flatline_counter ... + if ($flatline_counter < $self->{flatfield_start}->[$index]) { + # Defined fields are non-contiguous, inserting filler + $mask .= " " x ($self->{flatfield_start}->[$index] - $flatline_counter); + $flatline_counter = $self->{flatfield_start}->[$index]; + } + $mask .= '%'; + if ($self->{internal_datatype}->[$index] == $Interfaces::Interface::DATATYPE_TEXT) { + $mask .= "-" . $self->{flatfield_length}->[$index] . '.' . $self->{flatfield_length}->[$index] . "s"; + } elsif ($self->{signed}->[$index]) { + $mask .= "0" . $self->{flatfield_length}->[$index] . ($] < 5.012 ? "s" : "d"); + } else { + $mask .= "0" . $self->{flatfield_length}->[$index] . ($] < 5.012 ? "s" : "u"); + } + $flatline_counter += $self->{flatfield_length}->[$index]; + push(@{$ar_flat_columns}, $index); + } ## end for (0 .. $#{$self->columns... + $self->flat_mask($mask); + $self->flat_columns($ar_flat_columns); +} -method WriteRecord (HashRef $hr_data !, HashRef $hr_options ?) { - if (defined $hr_options and defined $hr_options->{encoding_out} and !defined $hr_options->{encoding_in}) { - Carp::confess "encoding_out supplied without encoding_in." +# Options consist of: +# encoding_in => Where is any valid value in http://search.cpan.org/dist/Encode/lib/Encode/Supported.pod. Determines the input encoding, does nothing without encoding_out +# encoding_out => Where is any valid value in http://search.cpan.org/dist/Encode/lib/Encode/Supported.pod. Determines the output encoding, requires encoding_in to be specified as well. +method WriteRecord(HashRef $hr_data !, HashRef $hr_options ?) { + if (defined $hr_options && defined $hr_options->{encoding_out} && !defined $hr_options->{encoding_in}) { + Interfaces::Interface::Crash("encoding_out supplied without encoding_in."); } - my $mask = ""; my @data; - my $flatline_counter = 0; # Maak printf-mask als deze nog niet bestaat if (!$self->has_flat_mask) { - $self->clear_flat_columns; - my $ar_flat_columns = []; - foreach my $index (0 .. $#{$self->columns}) { - if (!(defined $self->flatfield_start->[$index] and defined $self->flatfield_length->[$index])) { - # Field is missing interface_start, interface_length or both, skip it. - next; - } - if ($flatline_counter > $self->flatfield_start->[$index]) { - Carp::confess( "Error in interface [" - . $self->tablename - . "]: field [" - . $self->columns->[$index] - . "] starts at position [" - . $self->flatfield_start->[$index] - . "] but we have already [$flatline_counter] bytes of data."); - } ## end if ($flatline_counter ... - if ($flatline_counter < $self->flatfield_start->[$index]) { - # Defined fields are non-contiguous, inserting filler - $mask .= " " x ($self->flatfield_start->[$index] - $flatline_counter); - $flatline_counter = $self->flatfield_start->[$index]; - } - $mask .= '%'; - if ($self->{internal_datatype}->[$index]->{type} < Interfaces::DATATYPE_NUMERIC) { # Datatypes stored as text - $mask .= "-" . $self->flatfield_length->[$index] . '.' . $self->flatfield_length->[$index] . "s"; - } elsif ($self->signed->[$index] eq 'Y') { - $mask .= "0" . $self->flatfield_length->[$index] . ($] < 5.012 ? "s" : "d"); - } else { - $mask .= "0" . $self->flatfield_length->[$index] . ($] < 5.012 ? "s" : "u"); - } - $flatline_counter += $self->flatfield_length->[$index]; - push(@{$ar_flat_columns}, $index); - } - $self->flat_mask($mask); - $self->flat_columns($ar_flat_columns); - } + $self->generate_flat_mask; + } ## end if (!$self->has_mask) my $evalstring; - foreach my $index (@{$self->flat_columns}) { + foreach my $index (@{$self->{flat_columns}}) { my $datafield; - my $columnname = $self->columns->[$index]; - if ($self->{internal_datatype}->[$index]->{type} < Interfaces::DATATYPE_NUMERIC) { # Datatypes stored as text + my $columnname = $self->{columns}->[$index]; + if ($self->{internal_datatype}->[$index] == $Interfaces::Interface::DATATYPE_TEXT) { # Text - $datafield = $hr_data->{$columnname} // $self->default->[$index] // ''; + $datafield = $hr_data->{$columnname} // ($self->write_defaultvalues ? $self->{default}->[$index] : ''); } else { # Numeric if (($hr_data->{$columnname} // '') eq '') { - $datafield = $self->default->[$index] // 0; + $datafield = ($self->write_defaultvalues ? $self->{default}->[$index] : 0); } else { - if ($hr_data->{$columnname} =~ /[^-.0-9]/) { # Check if field contains characters not supposed to be present in numeric values + if (!$self->{speedy} && $hr_data->{$columnname} =~ /[^-.0-9]/) { Data::Dump::dd($hr_data); print("Column [$index]\n"); - Carp::confess('Interface [' . $self->name . '] datatype [' . $self->{datatype}->[$index] . '] column [' . $columnname . '] error converting data [' . $hr_data->{$columnname} . ']'); + Interfaces::Interface::Crash('Interface [' . $self->name . '] datatype [' . $self->datatype->[$index] . '] column [' . $columnname . '] error converting data [' . $hr_data->{$columnname} . ']'); } else { - # MinMax boundary check and fix - $datafield = 0 + $self->minmax($index, $hr_data->{$columnname}); + $datafield = $hr_data->{$columnname}; } } - given ($self->{internal_datatype}->[$index]->{type}) { - when (Interfaces::DATATYPE_NUMERIC) { - $datafield = int($datafield); # Truncaten...getallen achter de komma kunnen weg. + if (!$self->{speedy} && defined $datafield) { + $datafield = $self->minmax($index, $datafield); + } + if (defined $self->{decimals}->[$index] && $self->{decimals}->[$index] > 0) { + # DOUBLE, FLOAT, DECIMAL + $datafield *= 10**$self->{decimals}->[$index]; + if ($self->{signed}->[$index] and $datafield < 0) { + $datafield -= 10**-($self->{decimals}->[$index]); # For fixing floating-point errors (4.06 -> 4.06) without fear of changing the outcome. + } else { + $datafield += 10**-($self->{decimals}->[$index]); # For fixing floating-point errors (4.06 -> 4.06) without fear of changing the outcome. } - when ([ Interfaces::DATATYPE_FLOATINGPOINT, Interfaces::DATATYPE_FIXEDPOINT ]) { - if (($self->{decimals}->[$index] // 0) > 0) { - $datafield *= 10**$self->{decimals}->[$index]; - # Destroy remaining decimals (not needed, because sprintf("%u" or "%d") doesn't write decimals. - # But only v5.012+ because before that we're using %s to print - if ($] < 5.012) { - $datafield = int($datafield); - } - } + # Destroy remaining decimals (not needed, because sprintf("%u" or "%d") doesn't write decimals. + # But only v5.012+ because before that we're using %s to print + if ($] < 5.012) { + $datafield = int($datafield); } + } else { + # TINYINT, SMALLINT, MEDIUMINT, INT, INTEGER, BIGINT + $datafield = int($datafield); # Truncaten...getallen achter de komma kunnen weg. } } # If output-encoding is supplied, encode it - if (defined $hr_options and defined $hr_options->{encoding_in} and defined $hr_options->{encoding_out}) { + if (defined $hr_options && defined $hr_options->{encoding_in} && defined $hr_options->{encoding_out}) { $datafield = Encode::encode($hr_options->{encoding_out}, Encode::decode($hr_options->{encoding_in}, $datafield)); } # Truncate field to maximum allowed length - $datafield = substr($datafield, 0, $self->flatfield_length->[$index]); + #$datafield = substr($datafield, 0, $self->flatfield_length->[$index]); push(@data, $datafield); - } - return sprintf ($self->flat_mask, @data); -} ## end sub WriteRecord - -# ReadRecordUnpack ($self, $textinput) -# Parses $textinput using unpack and returns $hr_data -method ReadRecordUnpack (Str $textinput) { - my $hr_returnvalue = {}; - my ($CurrentColumnName, $CurrentColumnValue, $CurrentColumnDecimals, $unpack_mask); - if (! $self->has_flat_mask_unpack) { - # Build unpackmask - my $flatline_counter = 0; - for my $index (0 .. $#{$self->columns}) { - if (!(defined $self->flatfield_start->[$index] and defined $self->flatfield_length->[$index])) { - # Field is missing interface_start, interface_length or both, skip it. - next; - } - if ($flatline_counter > $self->flatfield_start->[$index]) { - Carp::confess( "Error in interface [" - . $self->name - . "]: field [" - . $self->columns->[$index] - . "] starts at position [" - . $self->flatfield_start->[$index] - . "] but we have already [$flatline_counter] bytes of data."); - } ## end if ($flatline_counter ...) - if ($flatline_counter < $self->flatfield_start->[$index]) { - # Defined fields are non-contiguous, inserting filler - $unpack_mask .= 'x' . ($self->flatfield_start->[$index] - $flatline_counter); - $flatline_counter = $self->flatfield_start->[$index]; - } - $unpack_mask .= "A" . $self->flatfield_length->[$index]; - $flatline_counter += $self->flatfield_length->[$index]; - } ## end for (0 .. $#{$self->columns...}) - $self->has_flat_mask_unpack($unpack_mask); - } ## end if (!defined $Interfaces::FlatFile::UnpackMask) - my @datalist = unpack ($self->has_flat_mask_unpack, $textinput); - for my $index (0 .. $#{$self->columns}) { - $CurrentColumnName = $self->{columns}->[$index]; - $CurrentColumnDecimals = $self->{decimals}->[$index]; - undef $CurrentColumnValue; - if (!(defined $self->{flatfield_start}->[$index] and defined $self->{flatfield_length}->[$index])) { - # Field is missing interface_start, interface_length or both, skip it. - #Carp::carp("Field [$CurrentColumnName] is missing flatfield_start, flatfield_length or both, skip it."); - next; - } - my $field_value; - if ($self->{internal_datatype}->[$index]->{type} >= Interfaces::DATATYPE_NUMERIC) { - if ($CurrentColumnDecimals == 0) { - if ($datalist[0] eq '') { - shift(@datalist); - $field_value = 0; - } else { - $field_value = 0 + shift(@datalist); - # MinMax boundary check and fix - $field_value = $self->minmax($index, $field_value); - } - } else { - # Remove leading zeroes - $field_value =~ s/^0*//; - # Insert period - if (length ($field_value) <= $CurrentColumnDecimals) { - $field_value = '0.' . '0' x ($CurrentColumnDecimals - length ($field_value)) . $field_value; - } else { - $field_value =~ s/([0-9]{$CurrentColumnDecimals})$/\.$1/; - } - } - } else { - $field_value = shift(@datalist); - s/^(\s*)(.*?)(\s*)$/$2/ for $field_value; # Trim whitespace - # Fill empty fields with that field's default value, if such a value is defined - if ($field_value eq '') { - $field_value = $self->{default}->[$index]; - } - } - $hr_returnvalue->{$CurrentColumnName} = $field_value; - } - return $hr_returnvalue; -} ## end sub ReadRecordUnpack + } ## end for (0 .. $#{$self->columns... + return sprintf ($self->{flat_mask}, @data); +} ## end sub WriteRecord ($$) -method ReadRecord (Str $textinput) { - if (ref($textinput) ne '') { - Carp::confess "1st Argument passed is a reference (expected text)"; - } +method ReadRecord(Str $textinput !, HashRef $hr_options ?) { + # Default settings + $hr_options->{trim} //= 1; +#Data::Dump::dd("Called with [$textinput]\n"); my $hr_returnvalue = {}; my ($current_column_name, $current_field_start, $current_field_length, $current_field_decimals, $current_field_default); - my $decimalseparator; - if ($self->has_decimalseparator) { - $decimalseparator = $self->decimalseparator; - } else { - $decimalseparator = '.'; - } + my $decimalseparator = $self->has_decimalseparator ? $self->decimalseparator : '.'; + my $thousandseparator = $self->has_thousandseparator ? $self->thousandseparator : ''; # Check if textinput is long enough - if (defined $self->{FlatFile_recordlength} and length($textinput) < $self->{FlatFile_recordlength}) { + if (!$self->{speedy} && defined $self->{FlatFile_recordlength} && length($textinput) < $self->{FlatFile_recordlength}) { Data::Dump::dd($textinput); - Carp::confess("field [" . $self->columns->[$_] . "] [" . $self->flatfield_start->[$_] . "," . $self->flatfield_length->[$_] . "] is outside the text inputstring (length [" . length($textinput) . "])"); + Interfaces::Interface::Crash("field [" . $self->columns->[$_] . "] [" . $self->flatfield_start->[$_] . "," . $self->flatfield_length->[$_] . "] is outside the text inputstring (length [" . length($textinput) . "])"); } foreach my $index (0 .. $#{$self->columns}) { my $field_value; - $current_column_name = $self->columns->[$index]; - $current_field_start = $self->flatfield_start->[$index]; - $current_field_length = $self->flatfield_length->[$index]; - $current_field_decimals = $self->decimals->[$index]; - if (!(defined $current_field_start and defined $current_field_length)) { + $current_column_name = $self->{columns}->[$index]; # 15.5s for 6704698 calls with proper accessor + $current_field_start = $self->{flatfield_start}->[$index]; # 14.1s for 6704698 calls with proper accessor + $current_field_length = $self->{flatfield_length}->[$index]; # 15.1s for 6704698 calls with proper accessor +#print("Processing column [$current_column_name], [$current_field_start - $current_field_length]\n"); + if (!(defined $current_field_start && defined $current_field_length)) { # Field is missing interface_start, interface_length or both, skip it. # Carp::carp("Field [$current_column_name] is missing flatfield_start, flatfield_length or both, skip it."); next; } $field_value = substr ($textinput, $current_field_start, $current_field_length); + #$field_value =~ s/^([ ]*)(.*?)([ ]*)$/$2/; # Trim, takes 3.83us/call (38.9s for 23900499 calls) + #$field_value = SleLib::trim($field_value); # Takes 7us/call # The two regexes below took respectively 1us/call and 478ns/call - $field_value =~ s/^\s+//; - $field_value =~ s/\s+$//; - # Controleren of datatypes[] gevuld is. - if (!defined $self->{internal_datatype}->[$index]) { - Carp::confess("Datatypes not defined huh?"); + if ($hr_options->{trim}) { + $field_value =~ s/^\s+//; # 6592014 18.8s 6592014 6.05s + $field_value =~ s/\s+$//; # 6592014 12.8s 6592014 2.71s + #$field_value =~ s/^\s*(.*?)\s*$/$1/; # 6592014 61.9s 19776042 28.7s } - # Lege velden weggooien. - if ($field_value eq '') { $field_value = undef; } $current_field_default = $self->{default}->[$index]; - given ($self->{internal_datatype}->[$index]->{type}) { - when (Interfaces::DATATYPE_TEXT) { - $field_value //= "" . $current_field_default; - } - when (Interfaces::DATATYPE_NUMERIC) { - $field_value = defined $field_value ? 0 + $field_value : 0 + $current_field_default; - $field_value = $self->minmax($index, $field_value); - } - when ([Interfaces::DATATYPE_FLOATINGPOINT, Interfaces::DATATYPE_FIXEDPOINT]) { -#print("Pre-minmax [$field_value] "); - if (!defined $field_value) { - $field_value = $self->minmax($index, 0 + $current_field_default); + # Lege velden weggooien. + if ($field_value eq '') { + undef $field_value; + } + if (!defined $field_value) { + if (!$self->{allownull}->[$index]) { + if (defined $current_field_default) { + if ($self->{read_defaultvalues}) { + given ($self->{internal_datatype}->[$index]) { + when ([$Interfaces::Interface::DATATYPE_TEXT, $Interfaces::Interface::DATATYPE_FIXEDPOINT, $Interfaces::Interface::DATATYPE_FLOATINGPOINT]) { + $field_value = sprintf ("%s", $current_field_default); + } + when ($Interfaces::Interface::DATATYPE_NUMERIC) { + $field_value = 0 + $current_field_default; + } + } + } } else { - $field_value =~ s/[$decimalseparator]/\./g; # Change the decimal-sign to . - $field_value /= 10**$current_field_decimals; -#print("Post decimalfix [$field_value]\n"); - $field_value = $self->minmax($index, 0 + $field_value); -#print("Post [$field_value]\n"); + Data::Dump::dd($textinput); + Interfaces::Interface::Crash('Field [' . $current_column_name . '] requires a value, but has none, and no default value either'); + } + } else { + next; + } + } else { + if ($self->{internal_datatype}->[$index] >= $Interfaces::Interface::DATATYPE_NUMERIC) { + # Niet-leeg numeriek veld + $field_value = 0 + $field_value; + if ($field_value eq ($current_field_default // '0') && $self->{allownull}->[$index] && !$self->{read_defaultvalues}) { next; } # Skip numeric fields that equal (default value // 0) + # Speedy setting implies the data is neat and tidy and doesn't need correcting + if (!$self->{speedy}) { + # Check if there are trailing negators, and fix it to be a heading negator + if (substr($field_value, -1) eq '-') { + #$field_value =~ s/^(.*)-$/-$1/; # 11.2s, 2.67s + $field_value = '-' . substr($field_value, 0, -1); + } + } + if ($self->{internal_datatype}->[$index] > $Interfaces::Interface::DATATYPE_NUMERIC) { + # Decimaal-correctie toepassen + $current_field_decimals = $self->{decimals}->[$index] // 0; # spent 14.0s making 5239806 calls with proper accessor + if ($current_field_decimals > 0) { + $field_value /= 10**$current_field_decimals; + } + } + if (!$self->{speedy} ) { + $field_value = $self->minmax($index, $field_value); } } } $hr_returnvalue->{$current_column_name} = $field_value; } ## end for (0 .. $#{$self->columns... return $hr_returnvalue; -} ## end sub ReadRecord +} ## end sub ReadRecord ($$) # ReadData ($filename) returns ar_data -method ReadData (Str $filename !) { +method ReadData(Str $filename !, HashRef $hr_options ?) { my $ar_returnvalue = []; - open (FLATFILE, '<', $filename) or (Carp::confess("Cannot open file [$filename]: $!") and return); - while () { + $hr_options //= {}; + if (!-e "$filename") { + Carp::carp("File [$filename] does not exist"); + return; + } + # Determine required length of input records + my $lastindex = $#{$self->columns}; + $self->FlatFile_recordlength(List::Util::max(map { ($self->flatfield_start->[$_] // 0) + ($self->flatfield_length->[$_] // 0); } (0 .. $lastindex))); + open (my $filehandle, '<', $filename) or Interfaces::Interface::Crash("Cannot open file [$filename]"); + while (<$filehandle>) { ### Reading [===[%] ] chomp; - push (@{$ar_returnvalue}, __PACKAGE__::ReadRecordUnpack($self, $_)); + push (@{$ar_returnvalue}, Interfaces::FlatFile::ReadRecord($self, $_, $hr_options)); } - close (FLATFILE); + close ($filehandle); return $ar_returnvalue; -} ## end sub ReadData - -# WriteData ($filename, $ar_data) -method WriteData (Str $filename !, ArrayRef $ar_data !) { - open (FLATFILE, '>', $filename) or (Carp::confess("Cannot open file [$filename]: $!") and return); - foreach my $hr_data (@{$ar_data}) { - print FLATFILE __PACKAGE__::WriteRecord($self, $hr_data) . "\r\n"; +} ## end sub ReadData ($$) + +# WriteData ($filename, $ar_data, $hr_options) +# Options consist of: append = 0 | 1 # Append to existing file (default = 0 (overwrite)) +method WriteData(Str $filename !, ArrayRef $ar_data !, HashRef $hr_options ?) { + $hr_options->{append} //= 0; # Default + my $filemode = '>'; + if ($hr_options->{append}) { + $filemode .= '>'; + } + open (my $filehandle, $filemode, $filename) or Interfaces::Interface::Crash("Cannot open file [$filename]"); + foreach my $hr_data (@{$ar_data}) { ### Writing [===[%] ] + print $filehandle Interfaces::FlatFile::WriteRecord($self, $hr_data) . $/; } - close (FLATFILE); -} ## end sub WriteData + close ($filehandle); +} ## end sub WriteData($$$) 1; @@ -355,15 +301,15 @@ Interfaces::FlatFile - FlatFile format extension to Interfaces::Interface =head1 VERSION -This document refers to Interfaces::FlatFile version 0.10. +This document refers to Interfaces::FlatFile version 1.0.0. =head1 SYNOPSIS use Interfaces::Interface; my $interface = Interfaces::Interface->new(); $interface->ReConfigureFromHash($hr_config); - my $ar_data = $interface->ReadData("foobar.txt"); - $interface->WriteData("foobar.txt", $ar_data); + my $ar_data = $interface->FlatFile_ReadData("foobar.txt"); + $interface->FlatFile_WriteData("foobar.txt", $ar_data); =head1 DESCRIPTION @@ -393,14 +339,9 @@ Contains, per column, the length (in bytes) of the data for this column. =item * C<$interface-EReadRecord($line_of_text);> -Parses the supplied line of text as a fixed-length record using substr. Returns a hashref with the data with the +Parses the supplied line of text as a fixed-length record. Returns an hashref with the data with the columnnames as key. -=item * C<$interface-EReadRecordUnpack($line_of_text);> - -Parses the supplied line of text as a fixed-length record using unpack. Returns a hashref with the data -with the columnnames as key. - =item * C<$interface-EWriteRecord($hr_data);> Converts the supplied hashref datarecord to a line of text. Returns a string of text containing the @@ -409,18 +350,19 @@ fixed-length encoded data. =item * C<$interface-EReadData($fullpath_to_file);> Reads the given file, decodes it and returns its data as an arrayref with a hashref per datarecord. -It is assumed that a LF or a CRLF seperates records. +The special variable $/ (or $INPUT_RECORD_SEPARATOR) can be changed to a different input record separator +should that be required. =item * C<$interface-EWriteData($fullpath_to_file, $ar_data);> Writes the supplied data in fixed-length format to the given file. If the file already existed, it is -overwritten, otherwise it is created. +overwritten, otherwise it is created. Each record is appended with $/ when written to file. =back =head1 DEPENDENCIES -L, L and L +L, L, L and L =head1 AUTHOR diff --git a/Interfaces/Interface.html b/Interfaces/Interface.html new file mode 100755 index 0000000..6bd2f2c --- /dev/null +++ b/Interfaces/Interface.html @@ -0,0 +1,162 @@ + + + + +Repository_Moose::Interface - Generic data-interface between file-formats and databases + + + + + + + + + + + +

+

+

NAME

+

Repository_Moose::Interface - Generic data-interface between file-formats and databases

+

+

+
+

VERSION

+

This document refers to Repository_Moose::Interface version 0.08.

+

+

+
+

SYNOPSIS

+
+  use Repository_Moose::Interface;
+  my $interface = Repository_Moose::Interface->new();
+

+

+
+

Repository_Moose MODULES

+

The Repository_Moose hierarchy of modules is an attempt at creating a general +method for transferring data from various file-formats and (MySQL) databases to +other file-formats and (MYSQL) databases. Currently implemented are:

+ +

+

+
+

DESCRIPTION

+

This module is the main module of the Repository_Moose-hierarchy and is the only +one that needs to be instantiated to use. All other modules add Moose::Roles to this +interface to extend funcionality. +The interface can be configured using ReConfigureFromHash with a given hashref filled +with configuration data. The basic data that all interfaces require consists of the +following:

+ +

Modules which add roles can introduce other attributes that need to be supplied in the +configuration data. The DelimitedFile-module needs a delimiter and a displayname (for the +header row), and the FlatFile-module requires flatfield_start and flatfield_length-attributes.

+

+

+

Methods for Repository_Moose::Interface

+
    +
  • my $interface = Repository_Moose::Interface->new(); + +

    Calls Repository_Moose::Interface's new method. Creates an unconfigured interface object.

    +
    • +
  • $interface->ReConfigureFromHash($hr_config); + +

    Configures the interface object with the supplied configuration. Will Carp::confess if some basic +checks pertaining the integrity of the configuration are not met.

    +
    • +
  • $interface->Check(); + +

    Starts a more thorough check on the integrity and correctness of the currently configured interface +object. This method can be augmented (using Moose's "after") for each additional module in the +Repository_Moose-hierarchy.

    +
    • +
+

+

+
+

DEPENDENCIES

+

Moose and Carp

+

+

+
+

AUTHOR

+

The original author is Herbert Buurman

+

+

+
+

LICENSE

+

This module is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. See perlartistic.

+ + + + diff --git a/Interfaces/Interface.pm b/Interfaces/Interface.pm new file mode 100755 index 0000000..3ebaf3c --- /dev/null +++ b/Interfaces/Interface.pm @@ -0,0 +1,775 @@ +package Interfaces::Interface; +# Version 2.0.0 03-01-2012 +# Copyright (C) OGD 2011-2012 + +use Moose; # automatically turns on strict and warnings +use 5.010; +no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater + +#$Interfaces::Interface::DEBUGMODE = 1; +use Smart::Comments; +use Data::Dump; +use Carp; +use Devel::Peek; +use MooseX::Method::Signatures; +use Readonly; + +$Interfaces::Interface::DATATYPE_UNKNOWN = 0; # default +$Interfaces::Interface::DATATYPE_TEXT = 1; +$Interfaces::Interface::DATATYPE_DATETIME = 2; +$Interfaces::Interface::DATATYPE_NUMERIC = 16; +$Interfaces::Interface::DATATYPE_FLOATINGPOINT = 17; +$Interfaces::Interface::DATATYPE_FIXEDPOINT = 18; +$Interfaces::Interface::OVERFLOW_METHOD_ERROR = 0; +$Interfaces::Interface::OVERFLOW_METHOD_TRUNC = 1; +$Interfaces::Interface::OVERFLOW_METHOD_ROUND = 2; + +$Interfaces::Interface::DATATYPES = { + CHAR => {type => $Interfaces::Interface::DATATYPE_TEXT, constraints => { length => { min => 0, }, }, }, + VARCHAR => {type => $Interfaces::Interface::DATATYPE_TEXT, constraints => { length => { min => 0, }, }, }, + TEXT => {type => $Interfaces::Interface::DATATYPE_TEXT}, + DATE => {type => $Interfaces::Interface::DATATYPE_TEXT}, + TIME => {type => $Interfaces::Interface::DATATYPE_TEXT}, + DATETIME => {type => $Interfaces::Interface::DATATYPE_TEXT}, + TIMESTAMP => {type => $Interfaces::Interface::DATATYPE_TEXT}, + BOOLEAN => {type => $Interfaces::Interface::DATATYPE_NUMERIC, + minmax => { min => { 1 => 0, 0 => 0 }, max => { 0 => 1, 1 => 1 }}, + }, + TINYINT => { + type => $Interfaces::Interface::DATATYPE_NUMERIC, + minmax => { min => { 1 => -(2**7), 0 => 0 }, max => { 0 => 2**8 - 1, 1 => 2**7 - 1 }}, + constraints => { signed => { min => 0, max => 1, }, }, + }, + SMALLINT => { + type => $Interfaces::Interface::DATATYPE_NUMERIC, + minmax => { min => {1 => -(2**15), 0 => 0}, max => {0 => 2**16 - 1, 1 => 2**15 - 1 }}, + constraints => { signed => { min => 0, max => 1, }, }, + }, + MEDIUMINT => { + type => $Interfaces::Interface::DATATYPE_NUMERIC, + minmax => {min => {1 => -(2**23), 0 => 0}, max => {0 => 2**24 - 1, 1 => 2**23 - 1}}, + constraints => { signed => { min => 0, max => 1, }, }, + }, + INT => { + type => $Interfaces::Interface::DATATYPE_NUMERIC, + minmax => {min => {1 => -(2**31), 0 => 0}, max => {0 => 2**32 - 1, 1 => 2**31 - 1}}, + constraints => { signed => { min => 0, max => 1, }, }, + }, + INTEGER => {type => + $Interfaces::Interface::DATATYPE_NUMERIC, + minmax => {min => {1 => -(2**31), 0 => 0}, max => {0 => 2**32 - 1, 1 => 2**31 - 1}}, + constraints => { signed => { min => 0, max => 1, }, }, + }, + BIGINT => {type => + $Interfaces::Interface::DATATYPE_NUMERIC, + minmax => {min => {1 => -(2**63), 0 => 0}, max => {0 => 2**64 - 1, 1 => 2**63 - 1}}, + constraints => { signed => { min => 0, max => 1, }, }, + }, + FLOAT => { + type => $Interfaces::Interface::DATATYPE_FLOATINGPOINT, + minmax => {min => {1 => undef, 0 => 0}, max => {0 => undef, 1 => undef}}, + }, + DOUBLE => { + type => $Interfaces::Interface::DATATYPE_FLOATINGPOINT, + minmax => {min => {1 => undef, 0 => 0}, max => {0 => undef, 1 => undef}}, + }, + NUMERIC => { + type => $Interfaces::Interface::DATATYPE_FIXEDPOINT, constraints => { length => { min => 1, max => 65, }, decimals => { min => 0, }, }, + }, + DECIMAL => { + type => $Interfaces::Interface::DATATYPE_FIXEDPOINT, constraints => { length => { min => 1, max => 65, }, decimals => { min => 0, }, }, + }, + }; + +# General info +has 'config' => (is => 'rw', isa => 'HashRef[HashRef[HashRef[Maybe[Value]]]]', lazy_build => 1,); +has 'name' => (is => 'rw', isa => 'Maybe[Str]', lazy_build => 1,); +has 'decimalseparator' => (is => 'rw', isa => 'Str', lazy_build => 1,); +has 'thousandseparator' => (is => 'rw', isa => 'Str', lazy_build => 1,); +has 'speedy' => (is => 'rw', isa => 'Bool', lazy_build => 1,); # Whether or not to do safety checks. This is the "I know what I'm doing, just make it go fast"-option. +# Fields info +has 'columns' => (is => 'rw', isa => 'ArrayRef[Str]', lazy_build => 1,); +has 'displayname' => (is => 'rw', isa => 'ArrayRef[Str]', lazy_build => 1,); +has 'datatype' => (is => 'rw', isa => 'ArrayRef[Str]', lazy_build => 1,); +has 'length' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); +has 'decimals' => (is => 'rw', isa => 'ArrayRef[Maybe[Int]]', lazy_build => 1,); +has 'signed' => (is => 'rw', isa => 'ArrayRef[Maybe[Bool]]', lazy_build => 1,); +has 'allownull' => (is => 'rw', isa => 'ArrayRef[Bool]', lazy_build => 1,); +has 'default' => (is => 'rw', isa => 'ArrayRef[Maybe[Value]]', lazy_build => 1, trigger => \&_default_set); +has 'fieldid' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); +has 'min_value' => (is => 'rw', isa => 'Int', lazy_build => 1,); +has 'max_value' => (is => 'rw', isa => 'Int', lazy_build => 1,); +has 'internal_datatype' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); +has 'overflow_method' => (is => 'rw', isa => 'Int', lazy_build => 1,); +has 'read_defaultvalues' => (is => 'rw', isa => 'Bool', lazy_build => 1,); +has 'write_defaultvalues' => (is => 'rw', isa => 'Bool', lazy_build => 1,); + +sub BUILD { + my $self = shift; + my $hr_args = shift; + # Load configuration from given $dbh for interface with $name + if (exists $hr_args->{dbh} and defined $hr_args->{dbh} and exists $hr_args->{name}) { + # Multiple interfaces can be set up using a single definition. This is done using aliases. + my $hr_aliases = $hr_args->{dbh}->selectall_hashref("SELECT * FROM datarepos_alias", "tablename") + or Crash('Interface: Error fetching table aliases from repository: ' . $hr_args->{dbh}->errstr); + my $repository_tablename = $hr_aliases->{$hr_args->{name}}->{use_tablename} // $hr_args->{name}; + # Fields + $self->{config}->{Fields} = $hr_args->{dbh}->selectall_hashref('SELECT * FROM datarepository WHERE tablename=? ORDER BY fieldid', 'fieldname', undef, $repository_tablename) + or Crash('Interface: Error loading field information from repository: ' . $hr_args->{dbh}->errstr); + # Indices + $self->{config}->{Indices} = $hr_args->{dbh}->selectall_hashref('SELECT * FROM datareposidx WHERE tablename=?', 'keyname', undef, $repository_tablename) + or Crash('Interface: Error loading indices information from repository: ' . $hr_args->{dbh}->errstr); + foreach my $fieldname (keys (%{$self->{config}->{Fields}})) { + $self->{config}->{Fields}->{$fieldname}->{signed} = $self->{config}->{Fields}->{$fieldname}->{signed} eq 'Y' ? 1 : 0; + $self->{config}->{Fields}->{$fieldname}->{allownull} = $self->{config}->{Fields}->{$fieldname}->{allownull} eq 'Y' ? 1 : 0; + } + # Apply retrieved configuration + $self->ReConfigureFromHash($self->config); + } ## end if (exists $hr_args->{...}) + # Initialize non-undef default values for attributes + $self->decimalseparator('.'); + $self->read_defaultvalues(0); + $self->write_defaultvalues(1); + $self->overflow_method($Interfaces::Interface::OVERFLOW_METHOD_ROUND); +} ## end sub BUILD + +method Check() { + # Check if all configuration data is valid (for Interface only) + if (!$self->has_config) { return; } + if (defined $Interfaces::Interface::DEBUGMODE) { + print ("Checking..."); + if ($self->has_name) { + print ($self->name); + } + print ("\n"); + } ## end if (defined $Interfaces::Interface::DEBUGMODE) + my $meta = $self->meta; + # Check if all arrayref attributes contain the same amount of elements, use columns as leading + my $num_arrayref_elements = $#{$self->columns}; + print ("Checking if all arrayref attributes contain the same amount of elements...") if defined $Interfaces::Interface::DEBUGMODE; + foreach my $attribute ($meta->get_all_attributes) { + my $attributename = $attribute->name; + if ($attribute->{lazy_build} == 0) { next; } # Skip attributes die zonder lazy_build zijn gedefinieerd. + if ($attribute->type_constraint->name =~ /^ArrayRef/) { + if ($num_arrayref_elements != $#{$self->$attributename}) { + Crash( "Attribute [" + . $attributename + . "] does not have the same amount of elements as there are columns [" + . $#{$self->$attributename} + . "] vs [$num_arrayref_elements]"); + } ## end if ($num_arrayref_elements...) + } ## end if ($attribute->type_constraint...) + } ## end foreach my $attribute ($meta...) + print ("[OK]\n") if defined $Interfaces::Interface::DEBUGMODE; + # Check if all fields are accounted for ($self->fieldid is continuous) + # $self->fieldid->[0] = 1, $self->fieldid->[n] = $self->fieldid->[n-1] + 1 + print ("Checking if all fields are accounted for...") if defined $Interfaces::Interface::DEBUGMODE; + if ($self->fieldid->[0] != 1) { + Crash("Column [" . $self->columns->[0] . "] has fieldid [" . $self->fieldid->[0] . "], expected [1]. FieldIDs not continous"); + } + foreach (1 .. $num_arrayref_elements) { + if ($self->fieldid->[$_] != $self->fieldid->[$_ - 1] + 1) { + Crash("Column [" . $self->columns->[$_] . "] has fieldid [" . $self->fieldid->[$_] . "], expected [" . $_ + 1 . "]. FieldIDs not continous"); + } + } + print ("[OK]\n") if defined $Interfaces::Interface::DEBUGMODE; + # Check if all columns of type CHAR|VARCHAR|TEXT have a length + # Check if all columns of type NUMERIC|DECIMAL have defined decimals (0 is allowed) + # Check if all columns of type TINYINT|SMALLINT|MEDIUMINT|INT|BIGINT|INTEGER have defined signed + print ("Checking if all columns have their required attributes") if defined $Interfaces::Interface::DEBUGMODE; + foreach my $index (0 .. $num_arrayref_elements) { + my $datatype = $self->datatype->[$index]; + foreach my $constraint ( keys %{$Interfaces::Interface::DATATYPES->{$datatype}->{constraints}}) { + if (!defined $self->{$constraint}->[$index]) { + Crash('Constraint violation: Column [' . $self->columns->[$index] . "] has datatype [$datatype] but $constraint is not defined"); + } + my ($min, $max) = ($Interfaces::Interface::DATATYPES->{$datatype}->{constraints}->{$constraint}->{min}, $Interfaces::Interface::DATATYPES->{$datatype}->{constraints}->{$constraint}->{max}); + if (defined $min && $self->{$constraint}->[$index] < $min) { + Crash('Constraint violation: Column [' . $self->columns->[$index] . "] has datatype [$datatype] but $constraint is below the minimum value [$min]"); + } + if (defined $max && $self->{$constraint}->[$index] > $max) { + Crash('Constraint violation: Column [' . $self->columns->[$index] . "] has datatype [$datatype] but $constraint is above the maximum value [$max]"); + } + } + } + print ("[OK]\n") if defined $Interfaces::Interface::DEBUGMODE; + print ("Checking if numeric-typed columns have numeric defaults: ") if defined $Interfaces::Interface::DEBUGMODE; + foreach (0 .. $num_arrayref_elements) { + # But only if allownull = false + if ( defined $self->default->[$_] + && $self->{internal_datatype}->[$_] >= $Interfaces::Interface::DATATYPE_NUMERIC + && !($self->default->[$_] eq '0' || $self->default->[$_] > 0)) + { + Crash("Column [" . $self->columns->[$_] . "] has datatype [" . $self->datatype->[$_] . "] but non-numeric default [" . $self->default->[$_] . "]"); + } ## end if (defined $self->default...) + } ## end foreach (0 .. $num_arrayref_elements) + print ("[Done]\n") if defined $Interfaces::Interface::DEBUGMODE; + 1; +} ## end sub Check + +method ClearConfig() { + my $meta = $self->meta; + # Clear ArrayRef-type attributes (this clears ALL attributes...including those generated by roles) + foreach ($meta->get_all_attributes) { + if ($_->type_constraint->name =~ /^ArrayRef/) { + $_->clear_value($self); + } + } +} + +method ReConfigureFromHash(HashRef $hr_config !) { + my $meta = $self->meta; + # Clear ArrayRef-type attributes (this clears ALL attributes...including those generated by roles) + $self->ClearConfig(); + if (!defined $hr_config && $self->has_config) { + Crash("Trying to reconfigure Base with empty configdata"); + } + # Reconfigure + $self->config($hr_config); + my @keys = keys (%{$hr_config->{Fields}}); + if (!@keys) { + Crash("Empty config supplied"); + } + # Set the columns + my $ar_Columns; + foreach my $Column (@keys) { + $ar_Columns->[$hr_config->{Fields}->{$Column}->{fieldid} - 1] = $Column; # fieldid starts at 1 + } + $self->columns($ar_Columns); + # Set all other attributes + foreach my $ColumnIndex (0 .. $#{$self->columns}) { + my $Column = $self->columns->[$ColumnIndex]; + if (!defined $Column) { + Crash("Undefined columnname with fieldid [" . ($ColumnIndex + 1) . "]"); + } + foreach ($meta->get_all_attributes) { + my $attributename = $_->name; + if ($_->{lazy_build} == 0) { next; } # Skip attributes die zonder lazy_build zijn gedefinieerd. + if ($attributename eq "columns") { next; } # Skip columns-attribute. We already did that one. + if ($_->type_constraint->name =~ /^ArrayRef/) { + push (@{$self->$attributename}, $hr_config->{Fields}->{$Column}->{$attributename}); + } + } ## end foreach ($meta->get_all_attributes) + # Init datatypes for speed (saves having to do regexes for each Read call) + my $hr_datatype = $Interfaces::Interface::DATATYPES->{$self->datatype->[$ColumnIndex]}; + $self->{internal_datatype}->[$ColumnIndex] = $Interfaces::Interface::DATATYPES->{$self->datatype->[$ColumnIndex]}->{type} or Interfaces::Interface::Crash("Datatype [$self->datatype->[$ColumnIndex]] unknown"); + # Add minmax + if ($self->{internal_datatype}->[$ColumnIndex] >= $Interfaces::Interface::DATATYPE_NUMERIC) { + if ($self->{internal_datatype}->[$ColumnIndex] == $Interfaces::Interface::DATATYPE_FIXEDPOINT) { + my ($length,$decimals) = ($self->{length}->[$ColumnIndex] // 10, $self->{decimals}->[$ColumnIndex] // 0); + $self->{max_value}->[$ColumnIndex] = (10**($length + 1) - 1) / 10**$decimals; + $self->{min_value}->[$ColumnIndex] = -$self->{max_value}->[$ColumnIndex]; + } else { + $self->{min_value}->[$ColumnIndex] = $hr_datatype->{min_value}->{$self->{signed}->[$ColumnIndex]}; + $self->{max_value}->[$ColumnIndex] = $hr_datatype->{max_value}->{$self->{signed}->[$ColumnIndex]}; + } + } + } ## end foreach my $ColumnIndex (0 ...) + 1; +} ## end sub ReConfigureFromHash + +method AddField(HashRef $hr_config !) { + Data::Dump::dd($hr_config) if $Interfaces::Interface::DEBUGMODE; + # Pre-add check + $hr_config->{fieldid} = ($self->fieldid->[-1] // 0) + 1; + my $hr_datatype = $Interfaces::Interface::DATATYPES->{$hr_config->{datatype}}; + Interfaces::Interface::Crash("Datatype [$hr_config->{datatype}] unknown") if !defined $hr_datatype->{type}; + $hr_config->{internal_datatype} = $hr_datatype->{type}; + # Check if column of type CHAR|VARCHAR|TEXT have a length + # Check if column of type NUMERIC|DECIMAL have defined decimals (0 is allowed) + # Check if column of type TINYINT|SMALLINT|MEDIUMINT|INT|BIGINT|INTEGER have defined signed + given ($hr_datatype->{type}) { + when ($Interfaces::Interface::DATATYPE_TEXT) { + if (($hr_config->{length} // 0) <= 0) { + Crash("Column [" . $hr_config->{fieldname} . "] has datatype [" . $hr_config->{datatype} . "] but length [" . $hr_config->{length} . "]"); + } + } + when ($_ > $Interfaces::Interface::DATATYPE_NUMERIC) { + if (!defined $hr_config->{decimals} || (($hr_config->{length} // 0) <= 0)) { + Crash( "Column [" + . $hr_config->{fieldname} + . "] has datatype [" + . $hr_config->{datatype} + . "] but decimals,length has not been defined properly [" + . $hr_config->{decimals} . ',' + . $hr_config->{length} + . ']'); + } ## end if (!defined $hr_config...) + } ## end when (/^(DECIMAL|FLOAT|DOUBLE)$/) + when ($Interfaces::Interface::DATATYPE_NUMERIC) { + if (!defined $hr_config->{signed}) { + Crash("Column [" . $hr_config->{fieldname} . "] has datatype [" . $hr_config->{datatype} . "] but signed has not been defined"); + } + } + } ## end given + # Check if datatype is numeric but the default exists and is not numeric + if (defined $hr_config->{default} && $hr_config->{internal_datatype} >= $Interfaces::Interface::DATATYPE_NUMERIC) { + if (!($hr_config->{default} eq '0' || $hr_config->{default} > 0)) { + Crash("Column [" . $hr_config->{fieldname} . "] has datatype [" . $hr_config->{datatype} . "] but non-numeric default [" . $hr_config->{default} . "]"); + } else { + # Check if numerical defaults fall within minmax range + if ($hr_config->{default} != $self->minmax_manual($hr_datatype, $self->{overflow_method} // $Interfaces::Interface::OVERFLOW_METHOD_ERROR, $hr_config->{default}, $hr_config->{signed}, $hr_config->{length}, $hr_config->{decimals}, $self->{decimalseparator} // '.')) { + Crash('Column [' . $hr_config->{fieldname} . '] has default [' . $hr_config->{default} . '] but default lies outside constrained values.'); + } + } + } + + # All ok, proceed with adding the field to the interface + # Generate field_id based on last used fieldid + $hr_config->{fieldid} = ($self->fieldid->[-1] // 0) + 1; + push (@{$self->columns}, $hr_config->{fieldname}); + my $meta = $self->meta; + foreach ($meta->get_all_attributes) { + my $attributename = $_->name; + if ($_->{lazy_build} == 0) { next; } # Skip attributes die zonder lazy_build zijn gedefinieerd. + if ($attributename eq "columns") { next; } # Skip columns-attribute. We already did that one. + if ($_->type_constraint->name =~ /^ArrayRef/) { + push (@{$self->$attributename}, $hr_config->{$attributename}); + } + } ## end foreach ($meta->get_all_attributes) + $self->{config} //= {Fields => {}}; + #Data::Dump::dd($hr_config); + #$self->{config}->{Fields}->{$attributename} = $hr_config; +} + +method MakeNewConfig() { + my $meta = $self->meta; + # Clear current config + delete $self->{config}; + my @attributes = $meta->get_all_attributes; + my @attributes_ArrayRef; + my @attributes_HashRef; + my @attributes_Scalar; + foreach my $attribute (@attributes) { + if ($attribute->name eq "columns") { next; } + given ($attribute->type_constraint->name) { + when (/^ArrayRef/) { push (@attributes_ArrayRef, $attribute); } + when (/^HashRef/) { push (@attributes_HashRef, $attribute); } + push (@attributes_Scalar, $attribute); + } + } ## end foreach my $attribute (@attributes) + foreach (@attributes_ArrayRef) { + my $attributename = $_->name; + foreach my $ColumnIndex (0 .. $#{$self->columns}) { + my $Column = $self->columns->[$ColumnIndex]; + $self->{config}->{Fields}->{$Column}->{$attributename} = $self->$attributename->[$ColumnIndex]; + } + } ## end foreach (@attributes_ArrayRef) +} ## end sub MakeNewConfig ($) + +# Reduces length of $value until it fits $length,decimals, truncates from left to right (so only gets the LSB) +method fix_runlength(Int $fieldid !, $value !) { + my ($internal_datatype, $signed, $length, $decimals) = ($self->{internal_datatype}->[$fieldid], $self->{signed}->[$fieldid], $self->{length}->[$fieldid], $self->{decimals}->[$fieldid]); + my $source_signed = $value < 0 ? 1 : 0; + # Split the value in an integer and fractional part + my $current_num_decimals = 0; + if (index ($value, $self->decimalseparator) >= 0) { + $current_num_decimals = length ($value) - index ($value, $self->decimalseparator) - $source_signed; + } + my ($fraction, $integer) = POSIX::modf($value); + $fraction = sprintf ("%.0${current_num_decimals}f", $fraction); # Fix floating point errors from POSIX::modf + # Truncate + $integer = reverse (substr (reverse ($integer), 0, List::Util::min($length - $decimals, length ($integer) - $source_signed))) if $integer; + $fraction = substr ($fraction, $source_signed + 2, List::Util::min($decimals, $current_num_decimals)) if length ($fraction) > 2; + $value = ($source_signed ? -1 : 1) * ($integer + "0.$fraction"); + # Add trailing significant decimals + if ($decimals > 0) { + $value =~ s/\.([0-9]*)/'.' . substr($1, 0, $decimals)/e; + } + return $value; +} + +method fix_runlength_manual(HashRef $hr_internal_datatype !, Int $overflow_method !, Num $value, Bool $signed ?, Int $length ?, Int $decimals ?, Str $decimalseparator ?) { + my $source_signed = $value < 0 ? 1 : 0; + # Split the value in an integer and fractional part + my $current_num_decimals = 0; + if (index ($value, $decimalseparator) >= 0) { + $current_num_decimals = length ($value) - index ($value, $decimalseparator) - $source_signed; + } + my ($fraction, $integer) = POSIX::modf($value); + $fraction = sprintf ("%.0${current_num_decimals}f", $fraction); # Fix floating point errors from POSIX::modf + # Truncate + $integer = reverse (substr (reverse ($integer), 0, List::Util::min($length - $decimals, length ($integer) - $source_signed))) if $integer; + $fraction = substr ($fraction, $source_signed + 2, List::Util::min($decimals, $current_num_decimals)) if length ($fraction) > 2; + $value = ($source_signed ? -1 : 1) * ($integer + "0.$fraction"); + # Add trailing significant decimals + if ($decimals > 0) { + $value =~ s/\.([0-9]*)/'.' . substr($1, 0, $decimals)/e; + } + return $value; +} + +method fix_typesize(Int $fieldid !, $value !) { + my ($internal_datatype, $signed, $length, $decimals) = ($Interfaces::Interface::DATATYPES->{$self->{datatype}->[$fieldid]}, $self->{signed}->[$fieldid], $self->{length}->[$fieldid], $self->{decimals}->[$fieldid] // 0); + my ($minvalue, $maxvalue); + my ($minvalue_round, $maxvalue_round); + if (defined $length and defined $decimals) { + ($minvalue_round, $maxvalue_round) = (-(10**($length - $decimals)) + (10**(-$decimals)), (10**($length - $decimals)) - (10**(-$decimals))); + } + # Translate signed = 'Y'/'N' to 1/0 + $signed = $signed eq 'Y' ? 1 : 0 if $signed ~~ ['Y','N']; + if ($internal_datatype->{type} == $Interfaces::Interface::DATATYPE_NUMERIC) { + if ($signed) { + $minvalue = $internal_datatype->{minmax}->{min}->{$signed}; + $maxvalue = -$minvalue - 1; + } else { + $minvalue = 0; + $maxvalue = $internal_datatype->{minmax}->{max}->{$signed}; + } + if (defined $minvalue_round and defined $maxvalue_round) { + # If the minimum or maximum value doesn't fit in $length, get the largest number that does fit in $length + if ($minvalue < $minvalue_round) { $minvalue = $minvalue_round; } + if ($maxvalue > $maxvalue_round) { $maxvalue = $maxvalue_round; } + } + } elsif ($internal_datatype->{type} > $Interfaces::Interface::DATATYPE_NUMERIC) { + $maxvalue = $maxvalue_round; + if ($signed) { + $minvalue = $minvalue_round; + } else { + $minvalue = 0; + } + } ## end elsif ($internal_datatype...) + #print("Min [$minvalue] max [$maxvalue]\n"); + if (defined $minvalue and $value < $minvalue) { $value = $minvalue; } + elsif (defined $maxvalue and $value > $maxvalue) { $value = $maxvalue; } + return $value; +} + +method fix_typesize_manual(HashRef $hr_internal_datatype !, Int $overflow_method !, Num $value, Bool $signed ?, Int $length ?, Int $decimals ?, Str $decimalseparator ?) { + my ($minvalue, $maxvalue); + my ($minvalue_round, $maxvalue_round); + if (defined $length and defined $decimals) { + ($minvalue_round, $maxvalue_round) = (-(10**($length - $decimals)) + (10**(-$decimals)), (10**($length - $decimals)) - (10**(-$decimals))); + } + # Translate signed = 'Y'/'N' to 1/0 + $signed = $signed eq 'Y' ? 1 : 0 if $signed ~~ ['Y','N']; + if ($hr_internal_datatype->{type} == $Interfaces::Interface::DATATYPE_NUMERIC) { + if ($signed) { + $minvalue = $hr_internal_datatype->{minmax}->{min}->{$signed}; + $maxvalue = -$minvalue - 1; + } else { + $minvalue = 0; + $maxvalue = $hr_internal_datatype->{minmax}->{max}->{$signed}; + } + if (defined $minvalue_round and defined $maxvalue_round) { + # If the minimum or maximum value doesn't fit in $length, get the largest number that does fit in $length + if ($minvalue < $minvalue_round) { $minvalue = $minvalue_round; } + if ($maxvalue > $maxvalue_round) { $maxvalue = $maxvalue_round; } + } + } elsif ($hr_internal_datatype->{type} > $Interfaces::Interface::DATATYPE_NUMERIC) { + $maxvalue = $maxvalue_round; + if ($signed) { + $minvalue = $minvalue_round; + } else { + $minvalue = 0; + } + } ## end elsif ($internal_datatype...) + #print("Min [$minvalue] max [$maxvalue]\n"); + if ($value < $minvalue) { $value = $minvalue; } + elsif ($value > $maxvalue) { $value = $maxvalue; } + return $value; +} + +method minmax(Int $fieldid !, $value !) { + # For OVERFLOW_METHOD_ROUND, read the value as-is, then round to within respectively $datatype_size and $length,decimals + # For OVERFLOW_METHOD_TRUNC, read the value as-is, then truncate the value within respectively $length,decimals and $datatype_size + my ($internal_datatype, $signed, $length, $decimals) = ($self->{internal_datatype}->[$fieldid], $self->{signed}->[$fieldid], $self->{length}->[$fieldid], $self->{decimals}->[$fieldid] // 0); + if ($internal_datatype < $Interfaces::Interface::DATATYPE_NUMERIC) { return $value; } + if ($internal_datatype == $Interfaces::Interface::DATATYPE_NUMERIC) { + # Translate signed = 'Y'/'N' to 1/0 + if (!defined $signed) { Crash("Not signed?!"); } + $signed = $signed eq 'Y' ? 1 : 0; + } + if ($self->{overflow_method} == $Interfaces::Interface::OVERFLOW_METHOD_ERROR) { + if ($signed and $value < 0) { Crash('Value [' . $value . '] below minimum [0]'); } + my $copy_of_value = $value; + $copy_of_value =~ s/$self->{decimalseparator}//; + if (length ($copy_of_value) > $length) { Crash('value [' . $value . '] too large to fit in [' . $length . '] figures'); } + } elsif ($self->{overflow_method} == $Interfaces::Interface::OVERFLOW_METHOD_TRUNC) { + if (!$decimals) { + # Truncate to no decimals + $value = int ($value); + } elsif ($decimals == $length) { + # Special case, truncate to only decimals + $value = POSIX::fmod($value, 1); + } + $value = $self->fix_runlength($fieldid, $value); + $value = $self->fix_typesize($fieldid, $value); + } elsif ($self->{overflow_method} == $Interfaces::Interface::OVERFLOW_METHOD_ROUND) { + # First round to proper amount of decimals + $value = sprintf ("%.${decimals}f", $value); + $value = $self->fix_typesize($fieldid, $value); + } else { + Crash("Unknown overflow method selected [" . $self->{overflow_method}); + } + return $value; +} + +method minmax_manual(HashRef $hr_internal_datatype !, Int $overflow_method !, Num $value, Bool $signed ?, Int $length ?, Int $decimals ?, Str $decimalseparator ?) { + # Version that doesn't rely on a configured interface (called from $self->AddField for runtime checks) + # For OVERFLOW_METHOD_ROUND, read the value as-is, then round to within respectively $datatype_size and $length,decimals + # For OVERFLOW_METHOD_TRUNC, read the value as-is, then truncate the value within respectively $length,decimals and $datatype_size + if ($hr_internal_datatype->{type} == $Interfaces::Interface::DATATYPE_NUMERIC) { + if (!defined $signed) { Crash("Not signed?!"); } + } + if ($overflow_method == $Interfaces::Interface::OVERFLOW_METHOD_ERROR) { + if ($signed and $value < 0) { Crash('Value [' . $value . '] below minimum [0]'); } + my $copy_of_value = $value; + $copy_of_value =~ s/\Q$decimalseparator\E//; + if (length ($copy_of_value) > $length) { Crash('value [' . $value . '] too large to fit in [' . $length . '] figures'); } + } elsif ($overflow_method == $Interfaces::Interface::OVERFLOW_METHOD_TRUNC) { + if (!$decimals) { + # Truncate to no decimals + $value = int ($value); + } elsif ($decimals == $length) { + # Special case, truncate to only decimals + $value = POSIX::fmod($value, 1); + } + $value = $self->fix_runlength_manual($hr_internal_datatype, $value, $signed, $length, $decimals, $decimalseparator); + $value = $self->fix_typesize_manual($hr_internal_datatype, $value, $signed, $length, $decimals, $decimalseparator); + } elsif ($overflow_method == $Interfaces::Interface::OVERFLOW_METHOD_ROUND) { + # First round to proper amount of decimals + $value = sprintf ("%.${decimals}f", $value); + $value = $self->fix_typesize($hr_internal_datatype, $value, $signed, $length, $decimals, $decimalseparator); + } else { + Crash("Unknown overflow method selected [" . $overflow_method); + } + return $value; +} + +method tablename(Str $newvalue) { + $newvalue ? $self->name($newvalue) : $self->name(); +} + +method Crash() { + defined $Interfaces::Interface::DEBUGMODE ? Carp::confess(@_) : die (@_); +} + +sub DESTROY { + my $self = shift; + # Carp::carp("Destroying interface for [" . $self->tablename . "]\n"); +} + +with + 'Interfaces::FlatFile' => { + alias => {ReadRecord => 'FlatFile_ReadRecord', WriteRecord => 'FlatFile_WriteRecord', ReadData => 'FlatFile_ReadData', WriteData => 'FlatFile_WriteData',}, + excludes => ['ReadRecord', 'WriteRecord', 'ReadData', 'WriteData',], + }, + 'Interfaces::DelimitedFile' => { + alias => { + ReadRecord => 'DelimitedFile_ReadRecord', + WriteRecord => 'DelimitedFile_WriteRecord', + ReadData => 'DelimitedFile_ReadData', + WriteData => 'DelimitedFile_WriteData', + ConfigureUseInFile => 'DelimitedFile_ConfigureUseInFile', + }, + excludes => ['ReadRecord', 'WriteRecord', 'ReadData', 'WriteData', 'ConfigureUseInFile',], + }, + 'Interfaces::DataTable' => {alias => {ReadData => 'DataTable_ReadData', WriteData => 'DataTable_WriteData',}, excludes => ['ReadData', 'WriteData',],}, + 'Interfaces::ExcelBinary' => { + alias => { + ReadRecord => 'ExcelBinary_ReadRecord', + WriteRecord => 'ExcelBinary_WriteRecord', + ReadData => 'ExcelBinary_ReadData', + WriteData => 'ExcelBinary_WriteData', + ConfigureUseInFile => 'ExcelBinary_ConfigureUseInFile', + WriteHeaders => 'ExcelBinary_WriteHeaders', + }, + excludes => ['ReadRecord', 'WriteRecord', 'ReadData', 'WriteData', 'ConfigureUseInFile', 'WriteHeaders',], + }, + 'Interfaces::ExcelX' => { + alias => { + ReadRecord => 'ExcelX_ReadRecord', + WriteRecord => 'ExcelX_WriteRecord', + ReadData => 'ExcelX_ReadData', + WriteData => 'ExcelX_WriteData', + ConfigureUseInFile => 'ExcelX_ConfigureUseInFile', + WriteHeaders => 'ExcelX_WriteHeaders', + }, + excludes => ['ReadRecord', 'WriteRecord', 'ReadData', 'WriteData', 'ConfigureUseInFile', 'WriteHeaders',], + }, + 'Interfaces::XMLFile' => { + alias => { + ReadRecord => 'XMLFile_ReadRecord', + WriteRecord => 'XMLFile_WriteRecord', + ReadData => 'XMLFile_ReadData', + WriteData => 'XMLFile_WriteData', + ConfigureUseInFile => 'XMLFile_ConfigureUseInFile', + ConfigureUseInFile_Manual => 'XMLFile_ConfigureUseInFile_Manual', + }, + excludes => ['ReadRecord', 'WriteRecord', 'ReadData', 'WriteData', 'ConfigureUseInFile', 'ConfigureUseInFile_Manual',], + }, + 'Interfaces::JSON' => { + alias => { + ReadRecord => 'JSON_ReadRecord', + WriteRecord => 'JSON_WriteRecord', + ReadData => 'JSON_ReadData', + WriteData => 'JSON_WriteData', + ConfigureUseInFile => 'JSON_ConfigureUseInFile', + }, + excludes => ['ReadRecord', 'WriteRecord', 'ReadData', 'WriteData', ], + }; +{ + my $meta = __PACKAGE__->meta; + no strict; + foreach my $build_attribute ($meta->get_all_attributes) { + my $build_attributename = $build_attribute->name; + # print ("Creating builder for attribute [" . $build_attributename . "]\n"); + if (!defined *{__PACKAGE__ . '::_build_' . $build_attributename}) { + *{__PACKAGE__ . '::_build_' . $build_attributename} = sub { + my $self = shift; + my $meta = $self->meta; + my $attribute = $meta->find_attribute_by_name($build_attributename); + if (!defined $attribute) { Carp::confess("Error: can't find attribute [$build_attributename]\n"); } + my $type_name = $attribute->type_constraint->name; + if ($attribute->type_constraint->is_a_type_of("ArrayRef")) { return []; } + elsif ($attribute->type_constraint->is_a_type_of("HashRef")) { return {}; } + elsif ($attribute->type_constraint->equals("Str")) { return ""; } + elsif ($attribute->type_constraint->is_a_type_of("Num")) { return 0; } + else { return; } + }; + } ## end if (!defined *{__PACKAGE__...}) + } ## end foreach my $build_attribute... + use strict; +} + +1; + +=head1 NAME + +Interfaces::Interface - Generic data-interface between file-formats and databases + +=head1 VERSION + +This document refers to Interfaces::Interface version 2.0.0 + +=head1 SYNOPSIS + + use Interfaces::Interface; + my $interface = Interfaces::Interface->new(); + +=head1 C MODULES + +The C hierarchy of modules is an attempt at creating a general +method for transferring data from various file-formats and (MySQL) databases to +other file-formats and (MYSQL) databases. Currently implemented are: + +=over 4 + +=item * Interfaces::FlatFile + +=item * Interfaces::DelimitedFile + +=item * Interfaces::DataTable + +=item * Interfaces::ExcelBinary + +=back + +=head1 DESCRIPTION + +This module is the main module of the Interfaces-hierarchy and is the only +one that needs to be instantiated to use. All other modules add Moose::Roles to this +interface to extend funcionality. +The interface itself cannot do anything, it depends on additional modules to provide +the various read- and write-methods. +The interface can be configured using ReConfigureFromHash with a given hashref filled +with configuration data. The basic data that all interfaces require consists of the +following: + +=over 4 + +=item * a (table)name which defines the name of the interface (and is also the default +tablename used when interfacing with a (MySQL) database using Interfaces::DataTable). + +=item * an arrayref with columnnames. These are used when referencing specific columns, + and also when interfacing with a (MySQL) database. + +=item * an arrayref with (MySQL) datatypes describing the type of each column. + +=item * an arrayref with lengths describing the amount of characters (or digits for numeric +types) used for each column. + +=item * an arrayref describing the amount of digits used in the fraction of numeric types +(that support fractions) for each column. This is undefined for columns with types that +don't use fractions. + +=item * an arrayref describing whether or not a numeric type is signed. This is undefined +for columns with non-numeric types. + +=item * an arrayref describing whether a column may contain NULL (undefined) values. + +=item * an arrayref containing the default values that should be given to a column. + +=item * an arrayref containing a field-id for each column. This is not used in the +interface itself, but in the configuration of the interface to indicate the order in which +columns should be used. + +=back + +Modules which add roles can introduce other attributes that need to be supplied in the +configuration data. The DelimitedFile-module needs a delimiter and a displayname (for the +header row), and the FlatFile-module requires flatfield_start and flatfield_length-attributes. + + +=head2 Methods for C + +=over 4 + +=item * Cnew($dbh, $name);> + +Calls C's C method. Creates an unconfigured interface object. +Optionally can be supplied with an active database handle and an interface name. The +interface will automatically be configured using data from tables 'datarepository', +'datareposidx' and 'datarepos_alias' that should be present in the supplied database. +This method (BUILD) can be augmented (using Moose's "after") for each additional module +in the Interfaces-hierarchy. + +=item * C<$interface-EReConfigureFromHash($hr_config);> + +Configures the interface object with the supplied configuration. Will Carp::confess if some basic +checks pertaining the integrity of the configuration are not met. The supplied $hr_config will be +saved in $self->config. $hr_config has the following structure: + { Fields => { + $fieldname => { + displayname => $displayname, + datatype => $datatype, + length => $length, + decimals => $decimals, + signed => $signed, + allownull => $allownull, + default => $defaultvalue, + fieldid => $fieldid, + ... (other attributes introduced by additional roles) + } + }, Indices => { + keyname1 => 'keyfield1,keyfield2, keyfield3 , keyfield4', + keyname2 => 'keyfield2', + ... + } +The Indices-part is only required for interfacing with databases (or other future interfaces which +would want to use indices this way). The keyfields are input as a commaseparated string. When this +string is parsed, each fieldname is trimmed to remove leading and trailing whitespace. + +=item * C<$interface-ECheck();> + +Starts a more thorough check on the integrity and correctness of the currently configured interface +object. This method can be augmented (using Moose's "after") for each additional module in the +Interfaces-hierarchy. + +=back + +=head1 DEPENDENCIES + +L, L and L + +=head1 AUTHOR + +The original author is Herbert Buurman + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. See L. + +=cut diff --git a/Interfaces/JSON.pm b/Interfaces/JSON.pm old mode 100644 new mode 100755 index 1321b07..5eafaef --- a/Interfaces/JSON.pm +++ b/Interfaces/JSON.pm @@ -1,12 +1,12 @@ package Interfaces::JSON; -use Moose::Role; # automatically turns on strict and warnings use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater use Smart::Comments; +use Moose::Role; # automatically turns on strict and warnings use JSON; use Scalar::Util; use MooseX::Method::Signatures; +no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater BEGIN { $Interfaces::JSON::VERSION = 1.00; # 11-02-2014 diff --git a/Interfaces/XMLFile.pm b/Interfaces/XMLFile.pm old mode 100644 new mode 100755 index 6018f49..9342c4c --- a/Interfaces/XMLFile.pm +++ b/Interfaces/XMLFile.pm @@ -1,61 +1,32 @@ package Interfaces::XMLFile; -use Moose::Role; # automatically turns on strict and warnings use 5.010; -no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater +use Smart::Comments; +use Moose::Role; # automatically turns on strict and warnings use XML::Twig; +use Scalar::Util; use MooseX::Method::Signatures; +no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater BEGIN { $Interfaces::XMLFile::VERSION = 1.00; # 27-11-2013 } -has 'XMLFile_ar_useinfile' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); -has 'XMLFile_hr_columns' => (is => 'rw', isa => 'HashRef[Int]', lazy_build => 1,); -has 'XMLFile_datatypes' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); -has 'XMLFile_fieldmask' => (is => 'rw', isa => 'HashRef[Str]', lazy_build => 1,); -has 'data' => (is => 'rw', isa => 'Any', lazy_build => 1,); - -# Scan for subroles -BEGIN { - no strict; - my ($package_fqpn, $package_this, $package_aspath) = (__PACKAGE__)x3; - $package_aspath =~ s'::'/'g; - $package_this =~ s/^.*::([^:]*)$/$1/; - my (undef, $include_dir, $package_pm) = File::Spec->splitpath($INC{$package_aspath . '.pm'}); - my @subroles; - if (-d $include_dir . $package_this ) { - @subroles = File::Find::Rule->file()->maxdepth(1)->name('*.pm')->relative->in($include_dir . $package_this); - foreach my $subrole (@subroles) { - require $package_aspath . '/' . $subrole; - $subrole =~ s/\.pm//; # Remove .pm - # Store the subrole's exported aliases in a fully qualified hash with the fully qualified subrole as key - # We can't apply the role here in case the subrole modifies methods (not yet) declared in this role - ${$package_fqpn . '::subroles'}->{$package_fqpn . '::' . $subrole} = ${$package_fqpn . '::' . $subrole . '::aliases'}; - } - } - # Export own aliases - foreach my $alias (@{$package_fqpn . '::methods'}) { - ${$package_fqpn . '::aliases'}->{-alias}->{$alias} = $package_this . '_' . $alias; - push(@{${$package_fqpn . '::aliases'}->{-excludes}}, $alias); - } - use strict; -} - -INIT { - no strict; - foreach my $subrole_fqpn (keys %{${__PACKAGE__ . '::subroles'}}) { - # Apply the role, using the exported aliases from the subrole - with $subrole_fqpn => ${__PACKAGE__ . '::subroles'}->{$subrole_fqpn}; - } -} - -use strict; +has 'XMLFile_ar_useinfile' => (is => 'rw', isa => 'ArrayRef[Int]', lazy_build => 1,); +has 'XMLFile_hr_columns' => (is => 'rw', isa => 'HashRef[Int]', lazy_build => 1,); +has 'XMLFile_fieldmask' => (is => 'rw', isa => 'HashRef[Str]', lazy_build => 1,); +has 'XMLFile_root_tag' => (is => 'rw', isa => 'Str', lazy_build => 1,); +has 'XMLFile_item_tag' => (is => 'rw', isa => 'Str', lazy_build => 1,); +has 'XMLFile_ar_writemask' => (is => 'rw', isa => 'Str', lazy_build => 0, clearer => 'clear_XMLFile_ar_writemask'); after 'BUILD' => sub { my $self = shift; # Initialize our own attributes with default values and set all columns with a displayname to be used Interfaces::XMLFile::ConfigureUseInFile($self, $self->displayname()); + # Other defaults + $self->XMLFile_root_tag($self->name // 'root'); + $self->XMLFile_item_tag('item'); + $self->{XMLFile_ar_writemask} = []; }; after 'Check' => sub { @@ -64,37 +35,29 @@ after 'Check' => sub { # Check if all fields that are marked with "useinfile" have a displayname for (0 .. $#{$self->columns}) { if ($self->XMLFile_ar_useinfile->[$_] && !($self->displayname->[$_] // "")) { - Crash("XMLFile field [" . $self->columns->[$_] . "] is configured to be used, but has no displayname"); + Interfaces::Interface::Crash("XMLFile field [" . $self->columns->[$_] . "] is configured to be used, but has no displayname"); } } ## end for (0 .. $#{$self->columns... + if (!$self->has_XMLFile_root_tag) { Interfaces::Interface::Crash('root tag not defined'); } + if (!$self->has_XMLFile_item_tag) { Interfaces::Interface::Crash('item tag not defined'); } }; after 'ReConfigureFromHash' => sub { my $self = shift; + $self->clear_XMLFile_ar_writemask(); # Init datatypes for speed (saves having to do regexes for each ReadRecord call) foreach my $index (0 .. $#{$self->columns}) { - given ($self->datatype->[$index]) { - when (/^(?:CHAR|VARCHAR|DATE|TIME|DATETIME|ENUM)$/x) { $self->{XMLFile_datatypes}->[$index] = $Interfaces::Interface::DATATYPE_TEXT; } - when (/^(?:TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT)$/x) { $self->{XMLFile_datatypes}->[$index] = $Interfaces::Interface::DATATYPE_NUMERIC; } - when (/^(?:FLOAT|SINGLE|DOUBLE)$/x) { $self->{XMLFile_datatypes}->[$index] = $Interfaces::Interface::DATATYPE_FLOATINGPOINT; } - when (/^(?:DECIMAL|NUMERIC)$/x) { $self->{XMLFile_datatypes}->[$index] = $Interfaces::Interface::DATATYPE_FIXEDPOINT; } - default { Crash("Datatype [$_] unknown"); } - } $self->{XMLFile_hr_columns}->{$self->columns->[$index]} = $index; $self->{XMLFile_ar_useinfile}->[$index] = 1; } + # Other defaults + $self->XMLFile_root_tag($self->name); + $self->XMLFile_item_tag('item'); }; after 'AddField' => sub { my ($self, $hr_config) = @_; my $last_index = $#{$self->columns}; - given ($hr_config->{datatype}) { - when (/^(?:CHAR|VARCHAR|DATE|TIME|DATETIME)$/x) { $self->{XMLFile_datatypes}->[$last_index] = $Interfaces::Interface::DATATYPE_TEXT; } - when (/^(?:TINYINT|SMALLINT|MEDIUMINT|INT|INTEGER|BIGINT)$/x) { $self->{XMLFile_datatypes}->[$last_index] = $Interfaces::Interface::DATATYPE_NUMERIC; } - when (/^(?:FLOAT|SINGLE|DOUBLE)$/x) { $self->{XMLFile_datatypes}->[$last_index] = $Interfaces::Interface::DATATYPE_FLOATINGPOINT; } - when (/^(?:DECIMAL|NUMERIC)$/x) { $self->{XMLFile_datatypes}->[$last_index] = $Interfaces::Interface::DATATYPE_FIXEDPOINT; } - default { Crash("Datatype [$_] unknown"); } - } $self->{XMLFile_hr_columns}->{$hr_config->{fieldname}} = $last_index; $self->{XMLFile_ar_useinfile}->[$last_index] = 1; }; @@ -115,19 +78,58 @@ sub xml_escape { # WriteRecord ($hr_data) returns string method WriteRecord(HashRef $hr_data !) { # Filter kolomindices die geen xml_columns hebben -#print('ar_useinfile: [' . Data::Dump::dump($self->{XMLFile_ar_useinfile}) . "]\r\n"); my @process_these_columns = grep { $self->{XMLFile_ar_useinfile}->[$_]; } (0 .. $#{$self->{columns}}); my %columnnames = map { $_ => $self->{columns}->[$_]; } @process_these_columns; - my $result = "\t\r\n"; -#print("Processing these columns: [" . Data::Dump::dump(@process_these_columns) . "]\n"); -#print("Processing these columnnames: [" . Data::Dump::dump(%columnnames) . "]\n"); + my $result = "\t\n"; + # Filter kolomindices die geen XMLFile_ar_useinfile hebben + # Maak printf-masks + if (scalar grep { !defined $_; } map { $self->{XMLFile_ar_writemask}->[$_]; } @process_these_columns > 0) { + for my $index (@process_these_columns) { + if (!defined $self->{XMLFile_ar_writemask}->[$index]) { + $self->{XMLFile_ar_writemask}->[$index] = "%"; + given ($self->{internal_datatype}->[$index]) { + when ($Interfaces::Interface::DATATYPE_TEXT) { + $self->{XMLFile_ar_writemask}->[$index] .= "s"; + } + when ($Interfaces::Interface::DATATYPE_NUMERIC) { + $self->{XMLFile_ar_writemask}->[$index] .= $self->{signed}->[$index] == 1 ? "d" : "u"; + } + when ($_ > $Interfaces::Interface::DATATYPE_NUMERIC) { + $self->{XMLFile_ar_writemask}->[$index] .= "." . $self->{decimals}->[$index] . "f"; + } + default { + $self->{XMLFile_ar_writemask}->[$index] .= "s"; + } + } ## end given + } + } + if (!defined $self->{XMLFile_ar_writemask}) { + Interfaces::Interface::Crash("No columns were identified as being used in file (have you forgot to use ConfigureUseInFile?)."); + } + } foreach my $column_index (@process_these_columns) { - my $CurrentColumnName = $columnnames{$column_index}; - next if !defined $hr_data->{$CurrentColumnName}; - my $ExportColumnName = xml_escape($CurrentColumnName); - $result .= "\t\t<" . $ExportColumnName . '>' . xml_escape($hr_data->{$CurrentColumnName}) . '\r\n"; + my $current_column_name = $columnnames{$column_index}; + my $field_value = $hr_data->{$current_column_name}; + if (!defined $field_value) { + if ($self->{allownull}->[$column_index]) { + next; + } else { + # Required field + if ($self->{write_defaultvalues} and defined $self->{default}->[$column_index]) { + $field_value = $self->{default}->[$column_index]; + } else { + Interfaces::Interface::Crash('Field [' . $current_column_name . '] requires a value, but has none (write_defaultvalues [' . $self->{write_defaultvalues} . '], default [' . $self->{default}->[$column_index] . "])\n" . Data::Dump::dump($hr_data)); + } + } + } + my $export_column_name = xml_escape($current_column_name); + $result .= "\t\t<" . $export_column_name . '>'; + if ($self->{internal_datatype}->[$column_index] >= $Interfaces::Interface::DATATYPE_NUMERIC) { + $field_value = $self->minmax($column_index, $field_value); + } + $result .= xml_escape(sprintf($self->{XMLFile_ar_writemask}->[$column_index], $field_value)) . '" . $/; } - $result .= "\t\r\n"; + $result .= "\t" . $/; return $result; } ## end sub WriteRecord @@ -140,13 +142,13 @@ method WriteData(Str $filename !, ArrayRef $ar_data !, HashRef $hr_options ?) { $hr_options->{append} //= 0; $hr_options->{encoding} //= 'utf8'; my $filehandle; - open ($filehandle, '>:' . $hr_options->{encoding}, $filename) or Crash("Error opening outputfile [$filename]: $!"); - print $filehandle '' . "\r\n"; - print $filehandle '<' . $self->name . ">\r\n"; - foreach my $hr_data (@{$ar_data}) { + open ($filehandle, '>:' . $hr_options->{encoding}, $filename) or Interfaces::Interface::Crash("Error opening outputfile [$filename]: $!"); + print $filehandle '' . $/; + print $filehandle '<' . $self->name . ">" . $/; + foreach my $hr_data (@{$ar_data}) { ### Writing [===[%] ] print $filehandle Interfaces::XMLFile::WriteRecord($self, $hr_data); } - print $filehandle 'name . ">\r\n"; + print $filehandle 'name . ">" . $/; close ($filehandle); } ## end sub WriteData ($$$) @@ -154,7 +156,7 @@ method WriteData(Str $filename !, ArrayRef $ar_data !, HashRef $hr_options ?) { method ReadRecord($twig, $element) { # Use all columns specified in useinfile my $hr_returnvalue = {}; - my $decimalseparator = $self->{decimalseperator}; + my $decimalseparator = $self->{decimalseparator}; foreach my $child_node ($element->children()) { my $name = $child_node->gi(); @@ -162,28 +164,34 @@ method ReadRecord($twig, $element) { my $field_value = $child_node->text(); next if not defined $column_index; my $CurrentColumnDecimals = $self->{decimals}->[$column_index]; - my $CurrentColumnDatatype = $self->{XMLFile_datatypes}->[$column_index]; + my $CurrentColumnDatatype = $self->{internal_datatype}->[$column_index]; if ($CurrentColumnDatatype >= $Interfaces::Interface::DATATYPE_NUMERIC) { - # Check if field ends with '-', if so, move '-' to start - $field_value =~ s/([^ ]*)-$/-$1/x; - if ($field_value eq '') { + Interfaces::Interface::Crash("Field [$name] does not contain numeric data: [$field_value]\n") if !Scalar::Util::looks_like_number($field_value); #if ($field_value !~ /^[0-9\Q${decimalseparator}\E]*$/x); # Prof: 5239806 29.5s 10479612 11.9s + # Check if there are trailing negators, and fix it to be a heading negator + if (substr($field_value,-1) eq '-') { + #$field_value =~ s/^(.*)-$/-$1/; # 11.2s, 2.67s + $field_value = '-' . substr($field_value, 0, -1); + } elsif ($field_value eq '') { $field_value = '0'; } if ($CurrentColumnDatatype > $Interfaces::Interface::DATATYPE_NUMERIC && $CurrentColumnDecimals) { # Field is a type that has decimals (FLOAT, NUMERIC etc) - # Compensate for decimalseperators other than period, change them to . - if ($decimalseparator ne '.' && $field_value !~ s/\Q${decimalseparator}\E/\./x || index($field_value, '.') + 1 > 0) { - # There were no $decimalseperators present and there is no period present in $field_value + # Compensate for decimalseparators other than period, change them to . + if ($decimalseparator ne '.' && !($field_value =~ s/\Q${decimalseparator}\E/./x) || index($field_value, '.') + 1 == 0) { + # There were no $decimalseparators present and there is no period present in $field_value $field_value .= '.'; } $field_value = "0$field_value" if substr($field_value, 0, 1) eq '.'; $field_value .= '0' x $CurrentColumnDecimals; $field_value =~ s/(\.[0-9]{$CurrentColumnDecimals}).+/$1/x; # Trim trailing digits to max $CurrentColumnDecimals } + # Check if field is numeric +#print("Field [$name] type [$self->{datatype}->[$column_index]] value [$field_value]\n"); +#Devel::Peek::Dump $field_value; $hr_returnvalue->{$name} = 0 + $field_value; } else { if ($field_value eq '') { # Store default value or undef (if no default value exists) - if (defined $self->{default}->[$column_index]) { + if ($self->read_defaultvalues and defined $self->{default}->[$column_index]) { $hr_returnvalue->{$name} = $self->{default}->[$column_index]; } # else don't store the value at all..saves a key-value pair @@ -238,7 +246,7 @@ method ReadData(Str $filename !, HashRef $hr_options ?) { }, ); if (!defined $xml_twig) { - Crash("Error initializing XML parser"); + Interfaces::Interface::Crash("Error initializing XML parser"); } $xml_twig->parsefile($filename); return $ar_returnvalue; @@ -248,40 +256,30 @@ method ReadData(Str $filename !, HashRef $hr_options ?) { =head1 NAME -Interfaces::DelimitedFile - Delimited file format extension to Interfaces::Interface +Interfaces::XMLFile - XML file format extension to Interfaces::Interface =head1 VERSION -This document refers to Interfaces::DelimitedFile version 1.0.0. +This document refers to Interfaces::XMLFile version 1.0.0. =head1 SYNOPSIS use Interfaces::Interface; my $interface = Interfaces::Interface->new(); $interface->ReConfigureFromHash($hr_config); - $interface->delimiter(','); - my $ar_data = $interface->DelimitedFile_ReadData("foobar.csv"); - $interface->DelimitedFile_WriteData("foobar.csv", $ar_data); + my $ar_data = $interface->DelimitedFile_ReadData("foobar.xml"); + $interface->DelimitedFile_WriteData("foobar.xml", $ar_data); =head1 DESCRIPTION This module extends the Interfaces::Interface with the capabilities to read from - and -write to files in a character or string-delimited file. +write to files in an XML file. -=head2 Attributes for C +=head2 Attributes for C =over 4 -=item * C -Contains the field-delimiter character (or string). - -=item * C -When importing csv-files into Excel, values can get mangled. In order to prevent this, a workaround -was implemented to assign "=value" to a field instead of just the value. This works for textfields only. - -=back - -=head2 Methods for C +=head2 Methods for C =over 4 @@ -291,33 +289,25 @@ Supplied an arrayref of strings, matches those with $self->displayname to determ the file are to be linked with which columns of the interface. Is automatically called from ReadData, but not from ReadRecord. -=item * C<$interface-EParseHeaders($headerstring);> - -Performs an identical function to ConfigureUseInFile, except this takes a string from which it extracts -the headers. - -=item * C<$interface-EReadRecord($string);> +=item * C<$interface-EReadRecord($twig, $element);> -Parses the supplied line of text as a character/string-delimited record. Returns an hashref with the data -with the columnnames as key. Only reads the columns configured by ConfigureUseInFile or ParseHeaders. +Parses the supplied element node and it's children. Returns an hashref with the data +with the columnnames as key. Only reads the columns configured by ConfigureUseInFile. =item * C<$interface-EWriteRecord($hr_data);> Converts the supplied hashref datarecord to a line of text. Returns a string of text containing the -character/string-delimeted data. +XML data. =item * C<$interface-EReadData($fullpath_to_file);> Reads the given file and returns its data as an arrayref with a hashref per datarecord. -If ConfigureUseInFile or ParseHeaders has not been called before, an initial record with headers is assumed -present and is parsed. The special variable $/ (or $INPUT_RECORD_SEPARATOR) can be changed to a different -input record separator should that be required. +If ConfigureUseInFile has not been called before, an initial record with headers is assumed +present and is parsed. =item * C<$interface-EWriteData($fullpath_to_file, $ar_data, $hr_options);> Writes the given data to the file specified by $fullpath_to_file. -Options consist of: header = 0 | 1 (Write a header to the file (default = 1)). -Each record is appended with $/ when written to file. =back diff --git a/README.md b/README.md index ef65195..35ae99d 100644 --- a/README.md +++ b/README.md @@ -1,18 +1,4 @@ interfaces ========== -Currently uses the following Perl modules (haven't separated debugging and release builds yet): -- Data::Dump -- Try::Tiny -- Moose -- Smart::Comments -- MooseX::Method::Signatures -- Readonly -- Spreadsheet::ParseExcel::S?tream -- Spreadsheet::Xlsx -- Excel::Writer::xlsx -- XML::Twig -- JSON -- File::Find::Rule - -V2 autodetects and loads additional modules +Perl Interfaces module diff --git a/interfaces.t b/interfaces.t index a6b2a8f..2986084 100755 --- a/interfaces.t +++ b/interfaces.t @@ -9,10 +9,10 @@ use v5.10.0; no if $] >= 5.018, warnings => "experimental"; # Only suppress experimental warnings in Perl 5.18.0 or greater # Test 1: Module inclusion -BEGIN { no strict; use_ok(Interfaces); use strict; } +BEGIN { no strict; use_ok(Interfaces::Interface); use strict; } -my $OVERFLOW_METHOD_TRUNC = $Interfaces::OVERFLOW_METHOD_TRUNC; -my $OVERFLOW_METHOD_ROUND = $Interfaces::OVERFLOW_METHOD_ROUND; +my $OVERFLOW_METHOD_TRUNC = $Interfaces::Interface::OVERFLOW_METHOD_TRUNC; +my $OVERFLOW_METHOD_ROUND = $Interfaces::Interface::OVERFLOW_METHOD_ROUND; # Testfiles for various interfaces my $hr_testfiles = { @@ -24,7 +24,7 @@ my $hr_testfiles = { # Test 2: Object creation no strict; -my $interface = new_ok(Interfaces); +my $interface = new_ok(Interfaces::Interface); use strict; # Test single interactions From 6dd276d8ca8f8557195c9acdac0b51fb4c0c36af Mon Sep 17 00:00:00 2001 From: Herbert Buurman Date: Thu, 22 May 2014 16:43:53 +0200 Subject: [PATCH 4/4] Tests failed due to floating point numbers with trailing zeroes were parsed to numbers without trailing zeroes. Stringified them and now all is well --- interfaces.t | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) mode change 100755 => 100644 interfaces.t diff --git a/interfaces.t b/interfaces.t old mode 100755 new mode 100644 index 2986084..c9c730e --- a/interfaces.t +++ b/interfaces.t @@ -1648,9 +1648,9 @@ if (-e $hr_testfiles->{delimited}) { ok(!defined $error, 'DelimitedFile: Read data'); is(@{$ar_data}, 4070, 'DelimitedFile: 4070 Records read'); # A few record tests: - is_deeply( { quote_date => "2011-01-03 11:03:00", price => 0.575, unknown => 261844, ask => 0.610, ask_size => 2500, bid => 0.570, bid_size => 2500 }, $ar_data->[41], 'Record 41 data validity'); - is_deeply( { quote_date => "2011-01-04 09:30:00", price => 0.580, unknown => 2500, ask => 0.000, ask_size => 0, bid => 0.000, bid_size => 0 }, $ar_data->[144], 'Record 144 data validity'); - is_deeply( { quote_date => "2011-02-23 14:37:00", price => 0.440, unknown => 111281, ask => 2.200, ask_size => 500, bid => 0.200, bid_size => 5000 }, $ar_data->[1269], 'Record 1269 data validity'); + is_deeply( { quote_date => "2011-01-03 11:03:00", price => '0.575', unknown => 261844, ask => '0.610', ask_size => 2500, bid => '0.570', bid_size => 2500 }, $ar_data->[41], 'Record 41 data validity'); + is_deeply( { quote_date => "2011-01-04 09:30:00", price => '0.580', unknown => 2500, ask => '0.000', ask_size => 0, bid => '0.000', bid_size => 0 }, $ar_data->[144], 'Record 144 data validity'); + is_deeply( { quote_date => "2011-02-23 14:37:00", price => '0.440', unknown => 111281, ask => '2.200', ask_size => 500, bid => '0.200', bid_size => 5000 }, $ar_data->[1269], 'Record 1269 data validity'); } else { print("Testfile for delimited data [$hr_testfiles->{delimited}] does not exist, tests skipped\n"); }