DBD-Sprite
view release on metacpan or search on metacpan
lib/JSprite.pm view on Meta::CPAN
my $BLOBTYPES = '^(LONG.*|.*?LOB|MEMO|.FILE)$';
my $REFTYPES = '^(LONG.*|.FILE)$'; #SUPPORT FILE-REFERENCING FOR THESE BLOB-TYPES. (OTHERS ARE STORED INLINE). 20010125
my @perlconds = ();
my @perlmatches = ();
my $sprite_user = ''; #ADDED 20011026.
our ($errdetails);
##++
## Public Methods and Constructor
##--
sub new
{
my $class = shift;
my $self;
$self = {
commands => 'select|update|delete|alter|insert|create|drop|truncate|primary_key_info',
# column => '[A-Za-z0-9\~\x80-\xFF][\w\x80-\xFF]+', #CHGD. TO NEXT 20020214 TO ALLOW 1-LETTER FIELD NAMES!!!! (HOW DID THIS GO ON FOR SO LONG?)
column => '[A-Za-z0-9][\w\x80-\xFF]*',
_select => '[\w\x80-\xFF\*,\s\~]+',
path => '[\w\x80-\xFF\-\/\.\:\~\\\\]+',
table => '',
file => '',
table => '', #JWT: ADDED 20020515
ext => '', #JWT:ADD FILE EXTENSIONS.
directory => '',
timestamp => 0,
_read => ',',
_write => ',',
_record => "\n", #JWT:SUPPORT ANY RECORD-SEPARATOR!
fields => {},
fieldregex => '', #ADDED 20001218
use_fields => '',
key_fields => '',
order => [],
types => {},
lengths => {},
scales => {},
defaults => {},
records => [],
platform => 'Unix',
fake_lock => 0,
default_lock => 'Sprite.lck',
sprite_lock_file => '',
lock_handle => '',
default_try => 10,
sprite_lock_try => '',
lock_sleep => 1,
errors => {},
lasterror => 0, #JWT: ADDED FOR ERROR-CONTROL
lastmsg => '',
CaseTableNames => 0, #JWT: 19990991 TABLE-NAME CASE-SENSITIVITY?
LongTruncOk => 0, #JWT: 19991104: ERROR OR NOT IF TRUNCATION.
LongReadLen => 0, #JWT: 19991104: ERROR OR NOT IF TRUNCATION.
RaiseError => 0, #JWT: 20000114: ADDED DBI RAISEERROR HANDLING.
silent => 0,
dirty => 0, #JWT: 20000229: PREVENT NEEDLESS RECOMMITS.
StrictCharComp => 0, #JWT: 20010313: FORCES USER TO PAD STRING LITERALS W/SPACES IF COMPARING WITH "CHAR" TYPES.
sprite_forcereplace => 0, #JWT: 20010912: FORCE DELETE/REPLACE OF DATAFILE (FOR INTERNAL WEBFARM USE)!
sprite_Crypt => 0, #JWT: 20020109: Encrypt Sprite table files! FORMAT: [[encrypt=|decrypt=][Crypt]::CBC;][[IDEA[_PP]|DES]_PP];]keystr
sprite_reclimit => 0, #JWT: 20010123: PERMIT LIMITING # OF RECORDS FETCHED.
sprite_sizelimit => 0, #JWT: 20010123: SAME AS RECLIMIT, NEEDED BOR BACKWARD COMPAT.
sprite_actlimit => 0, #JWT: 20010123: SAME AS RECLIMIT, NEEDED BOR BACKWARD COMPAT.
dbuser => '', #JWT: 20011026: SAVE USER'S NAME.
dbname => '', #JWT: 20020515: SAVE DATABASE NAME.
CBC => 0, #JWT: 20020529: SAVE Crypt::CBC object, if encrypting!
sprite_xsl => '', #JWT: 20020611: OPTIONAL XSL TEMPLATE FILE.
sprite_CaseFieldNames => 0, #JWT: 20020618: FIELD-NAME CASE-SENSITIVITY?
sprite_lastsequence => '', #JWT: ADDED 20020905 TO SUPPORT DBIx::GeneratedKey!
sprite_nocase => 0, #JWT: ADDED 20040323 TO SUPPORT CASE-INSENSITIVE WHERE-CLAUSES LIKE LDAP.
#NOTE - ONLY CURRENTLY FOR "LIKE/NOT LIKE" (VALUE=1|'L)!
#MAY ADD OTHER VALUES LATER!
ASNAMES => {}, #ADDED 20040913 TO SUPPORT "AS" IN SELECTS.
};
$self->{separator} = { Unix => '/', Mac => ':', #JWT: BUGFIX.
PC => '\\\\', VMS => '/' };
$self->{maxsizes} = {
'LONG RAW' => 2147483647,
'RAW' => 255,
'LONG' => 2147483647,
'CHAR' => 255,
'NUMBER' => 38,
'AUTONUMBER' => 38,
'DOUBLE' => 15,
'DATE' => 19,
'VARCHAR' => 2000,
'VARCHAR2' => 2000,
'BOOLEAN' => 1,
'BLOB' => 2147483647,
'MEMO' => 2147483647,
};
bless $self, $class;
for (my $i=0;$i<scalar(@_);$i+=2) #ADDED: 20020109 TO ALLOW SETTING ATTRIBUTES IN INITIALIZATION!
{
$self->{$_[$i]} = $_[$i+1];
}
$self->initialize;
return $self;
}
sub initialize
{
my $self = shift;
$sprite_user = $self->{'dbuser'}; #ADDED 20011026.
$self->define_errors;
$self->set_os ($^O) if (defined $^O);
if ($self->{sprite_Crypt}) #ADDED: 20020109
{
my (@cryptinfo) = split(/\;/, $self->{sprite_Crypt});
unshift (@cryptinfo, 'IDEA') if ($#cryptinfo < 1);
unshift (@cryptinfo, 'Crypt::CBC') if ($#cryptinfo < 2);
$self->{sprite_Crypt} = 1;
$self->{sprite_Crypt} = 2 if ($cryptinfo[0] =~ s/^encrypt\=//i);
$self->{sprite_Crypt} = 3 if ($cryptinfo[0] =~ s/^decrypt\=//i);
$cryptinfo[0] = 'Crypt::' . $cryptinfo[0]
unless ($cryptinfo[0] =~ /\:\:/);
eval "require $cryptinfo[0]";
if ($@)
{
$errdetails = $@;
$self->display_error (-526);
}
else
{
eval {$self->{CBC} = Crypt::CBC->new($cryptinfo[2], $cryptinfo[1]); };
if ($@)
{
$errdetails = "Can't find/use module \"$cryptinfo[1].pm\"? ($@)!";
$self->display_error (-526);
}
}
}
return $self;
}
sub set_delimiter
{
my ($self, $type, $delimiter) = @_;
$type ||= 'other';
$delimiter ||= $self->{_read} || $self->{_write};
$type =~ s/^-//;
$type =~ tr/A-Z/a-z/;
if ($type eq 'read') {
$self->{_read} = $delimiter;
} elsif ($type eq 'write') {
$self->{_write} = $delimiter;
} elsif ($type eq 'record') { #JWT:SUPPORT ANY RECORD-SEPARATOR!
###$delimiter =~ s/^\r// if ($self->{platform} eq 'PC'); #20000403 (BINMODE HANDLES THIS!!!)
$self->{_record} = $delimiter;
} else {
$self->{_read} = $self->{_write} = $delimiter;
}
return (1);
}
sub set_os
{
my ($self, $platform) = @_;
#$platform = 'Unix', return unless ($platform); #20000403.
return $self->{platform} unless ($platform); #20000403
$platform =~ s/\s//g;
# if ($platform =~ /^(?:OS2|(?:Win)?NT|Win(?:dows)?95|(?:MS)?DOS)$/i) {
# $self->{platform} = ''; #20000403
if ($platform =~ /(?:darwin|bsdos)/i) #20020218: ADDED FOR NEW MAC OS "OS X" WHICH USES "/"
{
$self->{platform} = 'Unix';
}
elsif ($platform =~ /(OS2|Win|DOS)/i)
{ #20000403
$self->{platform} = 'PC';
}
elsif ($platform =~ /^Mac(?:OS|intosh)?$/i)
{
$self->{platform} = 'Mac';
}
elsif ($platform =~ /^VMS$/i)
{
$self->{platform} = 'VMS';
}
lib/JSprite.pm view on Meta::CPAN
#if (${$self->{types}}{$jj} =~ /$NUMERICTYPES/) #CHGD TO NEXT LINE 20010313.
unless ($colskipreformat) #ADDED 20011018 TO OPTIMIZE.
{
if (length($rawvalue) > 0 && ${$self->{types}}{$jj} =~ /$NUMERICTYPES/)
{
$k = sprintf(('%.'.${$self->{scales}}{$jj}.'f'),
$rawvalue);
}
else
{
$k = $rawvalue;
}
#$rawvalue = substr($k,0,${$self->{lengths}}{$jj});
$rawvalue = (${$self->{types}}{$jj} =~ /$BLOBTYPES/) ? $k : substr($k,0,${$self->{lengths}}{$jj});
unless ($self->{LongTruncOk} || $rawvalue eq $k ||
(${$self->{types}}{$jj} eq 'FLOAT'))
{
$errdetails = "$jj to ${$self->{lengths}}{$jj} chars";
return (-519); #20000921: ADDED (MANY PLACES) LENGTH TO ERRDETAILS "(fieldname to ## chars)"
}
if ((${$self->{types}}{$jj} eq 'FLOAT')
&& (int($rawvalue) != int($k)))
{
$errdetails = "$jj to ${$self->{lengths}}{$jj} chars";
return (-519);
}
#if (${$self->{types}}{$jj} eq 'CHAR') #CHGD. TO NEXT 20030812.
if (${$self->{types}}{$jj} eq 'CHAR' && length($rawvalue) > 0)
{
$values->{$jj} = "'" . sprintf(
'%-'.${$self->{lengths}}{$jj}.'s',
$rawvalue) . "'";
}
#elsif (${$self->{types}}{$jj} !~ /$NUMERICTYPES/) #CHGD. TO NEXT 20010313.
#CHGD. TO NEXT 20160111: elsif (!length($rawvalue) || ${$self->{types}}{$jj} !~ /$NUMERICTYPES/)
#REASON: STOP TRAILING ZEROES IN DECIMALS FROM BEING TRUNCATED (WE ALREADY FORMATTED AT LINE 1541 ABOVE!)
else
{
$values->{$jj} = "'" . $rawvalue . "'";
}
#xNEXT 4 REMOVED 20160111: else
#x {
#x $values->{$jj} = $rawvalue;
#x }
}
}
#map { $code .= qq|\$_->{'$_'} = $values->{$_};| } @columns; #NEXT 2 CHGD TO NEXT 34 20020125 TO SUPPORT BLOB REFERENCING.
#eval $code;
for (my $i=0;$i<=$#columns;$i++)
{
if ($coltypes[$i]) #BLOB REF.
{
$code = qq|\$rawvalue = $values->{$columns[$i]};|;
eval $code;
$blobfid = $self->{directory}.$self->{separator}->{ $self->{platform} }
.$self->{table}.'_'.$_->{$columns[$i]}."_$$.tmp";
if (open(FILE, ">$blobfid"))
{
binmode FILE;
if ($self->{CBC} && $self->{sprite_Crypt} <= 2) #ADDED: 20020109
{
print FILE $self->{CBC}->encrypt($rawvalue);
}
else
{
print FILE $rawvalue;
}
close FILE;
}
else
{
$errdetails = "$blobfid: ($?)";
return (-528);
}
}
else
{
$code = qq|\$_->{'$columns[$i]'} = $values->{$columns[$i]};|;
eval $code;
}
}
return (-517) if ($@);
}
elsif ($command eq 'add')
{
$_->{$single} = ''; #ORACLE DOES NOT SET EXISTING RECORDS TO DEFAULT VALUE!
}
elsif ($command eq 'drop')
{
delete $_->{$single};
}
++$rowcnt;
$skipreformat = 1;
}
elsif ($@) #ADDED 20010313 TO CATCH SYNTAX ERRORS.
{
$errdetails = "Condition failed ($@) in condition=$condition!";
return -503 if ($command eq 'select');
return -505 if ($command eq 'delete');
return -504;
}
}
if ($status <= 0)
{
return $status;
}
elsif ( $command ne 'select' )
{
return $rowcnt;
}
else
{
my $theresanull = 0; #ADDED 20030930 TO HANDLE SINGLE NULL ELEMENT TO FIX _set_fbav ERROR!
my $rowcntdigits = length(scalar(@$results)); #ADDED 20050514 TO ENSURE SORTING WORKS CORRECTLY.
my ($ii, $t);
if ($distinct) #THIS IF ADDED 20010521 TO MAKE "DISTINCT" WORK.
{
my (%disthash);
for (my $i=0;$i<=$#$results;$i++)
{
++$disthash{join("\x02\^2jSpR1tE\x02",@{$results->[$i]})};
lib/JSprite.pm view on Meta::CPAN
foreach $column (@{ $self->{order} })
{
$column =~ tr/a-z/A-Z/ unless ($self->{sprite_CaseFieldNames}); #JWT
$hash->{$column} = $self->{defaults}->{$column}
if (defined($self->{defaults}->{$column}) && length($self->{defaults}->{$column}));
}
for ($loop=0; $loop <= $#columns; $loop++)
{
$column = $columns[$loop];
$column =~ tr/a-z/A-Z/ unless ($self->{sprite_CaseFieldNames});
my ($v);
if ($self->{fields}->{$column})
{
$values[$loop] =~ s/^\'(.*)\'$/my ($stuff) = $1;
#$stuff =~ s|\'|\\\'|gs;
$stuff =~ s|\'\'|\'|gso;
$stuff/es;
$values[$loop] =~ s|^\'$||so; #HANDLE NULL VALUES!!!.
if (${$self->{types}}{$column} =~ /AUTO/o) #NEXT 12 ADDED 20011029 TO DO ODBC&MYSQL-LIKE AUTOSEQUENCING.
{
if (length($values[$loop]))
{
$errdetails = "value($values[$loop]) into column($column)";
return (-524);
}
else
{
$v = ++$self->{defaults}->{$column};
$self->{sprite_lastsequence} = $v; #ADDED 20020905 TO SUPPORT DBIx::GeneratedKey!
}
}
elsif (length($values[$loop]) || !length($self->{defaults}->{$column}))
{
$v = $values[$loop];
}
else
{
$v = $self->{defaults}->{$column};
}
#if (${$self->{types}}{$column} =~ /$NUMERICTYPES/) #CHGD TO NEXT LINE 20010313.
if (length($v) > 0 && ${$self->{types}}{$column} =~ /$NUMERICTYPES/)
{
$hash->{$column} = sprintf(('%.'.${$self->{scales}}{$column}.'f'), $v);
}
elsif (${$self->{types}}{$column} =~ /$REFTYPES/o) #ADDED 20020124 TO SUPPORT REFERENCED TYPES.
{
my $randblobid = int(rand(99999));
my $randblobfid;
do {
$randblobid = int(rand(99999));
$randblobfid = $self->{directory}
.$self->{separator}->{ $self->{platform} }
.$self->{table}."_${randblobid}_$$.tmp";
} while (-e $randblobfid);
if (open(FILE, ">$randblobfid"))
{
binmode FILE;
if ($self->{CBC} && $self->{sprite_Crypt} <= 2) #ADDED: 20020109
{
print FILE $self->{CBC}->encrypt($v);
}
else
{
print FILE $v;
}
close FILE;
$hash->{$column} = $randblobid;
}
else
{
$errdetails = "$randblobfid: ($?)";
return (-528);
}
}
else
{
$hash->{$column} = $v;
}
#$v = substr($hash->{$column},0,${$self->{lengths}}{$column}); #CHGD TO NEXT (20020110)
$v = (${$self->{types}}{$column} =~ /$BLOBTYPES/) ? $hash->{$column} : substr($hash->{$column},0,${$self->{lengths}}{$column});
unless ($self->{LongTruncOk} || $v eq $hash->{$column} ||
(${$self->{types}}{$column} eq 'FLOAT'))
{
$errdetails = "$column to ${$self->{lengths}}{$column} chars";
return (-519);
}
if ((${$self->{types}}{$column} eq 'FLOAT')
&& (int($v) != int($hash->{$column})))
{
$errdetails = "$column to ${$self->{lengths}}{$column} chars";
return (-519);
}
#elsif (${$self->{types}}{$column} eq 'CHAR') #CHGD. TO NEXT 20030812.
elsif (${$self->{types}}{$column} eq 'CHAR' && length($v) > 0)
{
$hash->{$column} = sprintf('%-'.${$self->{lengths}}{$column}.'s',$v);
}
else
{
$hash->{$column} = $v;
}
}
}
#20000201 - FIX UNIQUE-KEY TEST FOR LARGE DATASETS.
recloop: for ($k=0;$k < scalar @{ $self->{records} }; $k++) #CHECK EACH RECORD.
{
$matchcnt = 0;
valueloop: foreach $column (keys %$hash) #CHECK EACH NEW VALUE AGAINST IT'S RESPECTIVE COLUMN.
{
keyloop: for ($j=0;$j<=$#keyfields;$j++)
{
if ($column eq $keyfields[$j])
{
if ($self->{records}->[$k]->{$column} eq $hash->{$column})
{
++$matchcnt;
return (-518) if ($matchcnt && $matchcnt > $#keyfields); #ALL KEY FIELDS WERE DUPLICATES!
}
}
}
}
#return (-518) if ($matchcnt && $matchcnt > $#keyfields); #ALL KEY FIELDS WERE DUPLICATES!
}
push @{ $self->{records} }, $hash;
$self->{dirty} = 1;
return (1);
} else {
$errdetails = "$#columns != $#values"; #20000114
return (-509);
}
}
sub write_file
{
my ($self, $new_file) = @_;
my ($i, $j, $status, $loop, $record, $column, $value, $fields, $record_string);
my (@keyfields) = split(',', $self->{key_fields}); #JWT: PREVENT DUP. KEYS.
return ($self->display_error (-531) * -531)
if (($self->{_write} =~ /^xml/io) && $self->{CBC} && $self->{sprite_Crypt} <= 2);
local (*FILE, $^W);
local ($/);
if ($self->{CBC} && $self->{sprite_Crypt} <= 2) #ADDED: 20020109
{
$/ = "\x03^0jSp".$self->{_record}; #(EOR) JWT:SUPPORT ANY RECORD-SEPARATOR!
}
elsif ($self->{_write} !~ /^xml/io)
{
$/ = $self->{_record}; #JWT:SUPPORT ANY RECORD-SEPARATOR!
}
$^W = 0;
#$status = (scalar @{ $self->{records} }) ? 1 : -513;
$status = 1; #JWT 19991222
return 1 if $#{$self->{order}} < 0; #ADDED 20000225 PREVENT BLANKING OUT TABLES, IE IF USER CREATES SEQUENCE W/SAME NAME AS TABLE, THEN COMMITS!
#########$new_file =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
unlink ($new_file) if ($status >= 1 && $self->{sprite_forcereplace} && -e $new_file); #ADDED 20010912.
if ( ($status >= 1) && (open (FILE, ">$new_file")) ) {
binmode FILE; #20000404
#if (($^O eq 'MSWin32') or ($^O =~ /cygwin/i)) #CHGD. TO NEXT 20020221
if ($self->{platform} eq 'PC')
{
$self->lock || $self->display_error (-515);
}
else #GOOD, MUST BE A NON-M$ SYSTEM :-)
{
eval { flock (FILE, $JSprite::LOCK_EX) || die };
if ($@)
{
$self->lock || $self->display_error (-515) if ($@);
}
}
$fields = '';
my $reccnt = scalar @{ $self->{records} };
if ($self->{_write} =~ /^xml/io)
{
require MIME::Base64;
$fields = <<END_XML;
<?xml version="1.0" encoding="UTF-8"?>
END_XML
$fields .= <<END_XML if ($self->{sprite_xsl});
<?xml-stylesheet type="text/xsl" href="$self->{sprite_xsl}"?>
END_XML
$fields .= <<END_XML;
<database name="$self->{dbname}" user="$self->{dbuser}">
<select query="select * from $self->{table}" rows="$reccnt">
END_XML
$fields .= ' <columns order="'.join(',',@{ $self->{order} }).'">'."\n";
my ($iskey, $haveadefault, $havemaxsize, $typeinfo);
for $i (0..$#{$self->{order}})
{
$iskey = 'NO';
for ($j=0;$j<=$#keyfields;$j++) #JWT: MARK KEY FIELDS.
{
if (${$self->{order}}[$i] eq $keyfields[$j])
{
$iskey = 'PRIMARY';
last;
}
}
$haveadefault = ${$self->{defaults}}{${$self->{order}}[$i]};
$havemaxsize = (${$self->{types}}{${$self->{order}}[$i]} =~ /$BLOBTYPES/)
? ($self->{LongReadLen} || '0')
: ($self->{maxsizes}->{${$self->{types}}{${$self->{order}}[$i]}}
|| ${$self->{lengths}}{${$self->{order}}[$i]} || '0');
$fields .= <<END_XML
<column>
<name>${$self->{order}}[$i]</name>
<type>${$self->{types}}{${$self->{order}}[$i]}</type>
<size>$havemaxsize</size>
<precision>${$self->{lengths}}{${$self->{order}}[$i]}</precision>
<scale>${$self->{scales}}{${$self->{order}}[$i]}</scale>
<nullable>NULL</nullable>
<key>$iskey</key>
<default>$haveadefault</default>
</column>
END_XML
}
$fields .= " </columns>\n";
}
else
{
for $i (0..$#{$self->{order}})
{
$fields .= ${$self->{order}}[$i] . '=';
for ($j=0;$j<=$#keyfields;$j++) #JWT: MARK KEY FIELDS.
{
$fields .= '*' if (${$self->{order}}[$i] eq $keyfields[$j])
}
#$fields .= ${$self->{types}}{${$self->{order}}[$i]} . '(' #CHGD. TO NEXT 20020110
# . ${$self->{lengths}}{${$self->{order}}[$i]};
$fields .= ${$self->{types}}{${$self->{order}}[$i]};
unless (${$self->{types}}{${$self->{order}}[$i]} =~ /$BLOBTYPES/)
{
$fields .= '(' . ${$self->{lengths}}{${$self->{order}}[$i]};
if (${$self->{scales}}{${$self->{order}}[$i]}
&& ${$self->{types}}{${$self->{order}}[$i]} =~ /$NUMERICTYPES/)
{
$fields .= ',' . ${$self->{scales}}{${$self->{order}}[$i]}
}
#$fields .= ')' . $self->{_write};
$fields .= ')';
}
$fields .= '='. ${$self->{defaults}}{${$self->{order}}[$i]}
if (length(${$self->{defaults}}{${$self->{order}}[$i]}));
$fields .= $self->{_write};
}
$fields =~ s/$self->{_write}$//;
}
if ($self->{CBC} && $self->{sprite_Crypt} <= 2) #ADDED: 20020109
{
print FILE $self->{CBC}->encrypt($fields).$/;
}
else
{
print FILE "$fields$/";
}
my $rsinit = ($self->{_write} =~ /^xml/io) ? " <row>\n" : '';
my $rsend = $rsinit ? " </row>\n" : '';
for ($loop=0; $loop < $reccnt; $loop++) {
#++$loop1;
$record = $self->{records}->[$loop];
next unless (defined $record);
$record_string = $rsinit;
#$record_string =~ s/\?/$loop1/;
foreach $column (@{ $self->{order} })
{
#if (${$self->{types}}{$column} eq 'CHAR') #CHGD. TO NEXT 20030812.
if (${$self->{types}}{$column} eq 'CHAR' && length($record->{$column}) > 0)
{
$value = sprintf(
'%-'.${$self->{lengths}}{$column}.'s',
$record->{$column});
}
#elsif (${$self->{types}}{$column} =~ /$NUMERICTYPES/)
#{
# $value = sprintf(('%.'.${$self->{scales}}{$column}.'f'),
# $record->{$column});
#}
else
{
$value = $record->{$column};
}
#NEXT 2 ADDED 20020111 TO PERMIT EMBEDDED RECORD & FIELD SEPERATORS.
$value =~ s/$self->{_record}/\x02\^0jSpR1tE\x02/gso; #PROTECT EMBEDDED RECORD SEPARATORS.
$value =~ s/$self->{_write}/\x02\^1jSpR1tE\x02/gso; #PROTECT EMBEDDED RECORD SEPARATORS.
$record_string .= $rsinit ? (&xmlescape($column,$value)."\n")
: "$self->{_write}$value";
}
#$record_string =~ s/^$self->{_write}//o; #CHGD TO NEXT LINE 20010917.
$record_string =~ s/^$self->{_write}//s;
$record_string .= $rsend;
if ($self->{CBC} && $self->{sprite_Crypt} <= 2) #ADDED: 20020109
{
print FILE $self->{CBC}->encrypt($record_string).$/;
}
else
{
print FILE "$record_string$/";
}
}
if ($rsend)
{
$rsend = " </select>\n</database>\n";
if ($self->{CBC} && $self->{sprite_Crypt} <= 2) #ADDED: 20020109
{
print FILE $self->{CBC}->encrypt($rsend).$/;
}
else
{
print FILE "$rsend$/";
}
}
close (FILE);
my (@stats) = stat ($new_file);
$self->{timestamp} = $stats[9];
$self->unlock || $self->display_error (-516);
} else {
$status = ($status < 1) ? $status : -511;
}
return $status;
}
{
my %xmleschash = (
'<' => '<',
'>' => '>',
'"' => '"',
'--' => '--',
);
sub xmlescape
{
my $res;
$_[1] =~ s/\&/\&/gs;
eval "\$_[1] =~ s/(".join('|', keys(%xmleschash)).")/\$xmleschash{\$1}/gs;";
#$_[1] =~ s/([\x01-\x1b\x7f-\xff])/"\&\#".ord($1).';'/egs;
if ($_[1] =~ /[\x00-\x08\x0A-\x0C\x0E-\x19\x7f-\xff]/o)
{
return " <$_[0] xml:encoding=\"base64\">"
. MIME::Base64::encode_base64($_[1]) . "</$_[0]>";
}
else
{
return " <$_[0]>$_[1]</$_[0]>";
}
}
}
sub load_database
{
my ($self, $file) = @_;
return -531
if (($self->{_read} =~ /^xml/io) && $self->{CBC} && $self->{sprite_Crypt} <= 2);
my ($i, $header, @fields, $no_fields, @record, $hash, $loop, $tp, $dflt);
local (*FILE);
local ($/);
if ($self->{CBC} && $self->{sprite_Crypt} != 2) #ADDED: 20020109
{
$/ = "\x03^0jSp".$self->{_record}; #JWT:SUPPORT ANY RECORD-SEPARATOR!
}
else
{
$/ = $self->{_record}; #JWT:SUPPORT ANY RECORD-SEPARATOR!
}
########$file =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
#$thefid = $file;
# open (FILE, $file) || return (-501);
# binmode FILE; #20000404
undef @{ $self->{records} } if (scalar @{ $self->{records} });
$self->{use_fields} = '';
$self->{key_fields} = ''; #20000223 - FIX LOSS OF KEY ASTERISK ON ROLLBACK!
if ($self->{_read} =~ /^xml/io)
{
return -532 unless ($XMLavailable);
my $xs1 = XML::Simple->new();
my $xmldoc;
eval {$xmldoc = $xs1->XMLin($file, suppressempty => undef); };
$errdetails = $@;
return -501 unless ($xmldoc);
@fields = ($xmldoc->{select}->{columns}->{order})
? split(/\,/, $xmldoc->{select}->{columns}->{order})
: keys(%{$xmldoc->{select}->{columns}->{column}});
foreach my $i (0..$#fields)
{
#$fields[$i] =~ tr/a-z/A-Z/ unless ($self->{sprite_CaseFieldNames}); #DON'T *SEEM* TO NEED, BUT ADD IF NEEDED!
$self->{key_fields} .= ($fields[$i] . ',')
if ($xmldoc->{select}->{columns}->{column}->{$fields[$i]}->{key}
eq 'PRIMARY');
${$self->{types}}{$fields[$i]} =
$xmldoc->{select}->{columns}->{column}->{$fields[$i]}->{type};
${$self->{lengths}}{$fields[$i]} =
$xmldoc->{select}->{columns}->{column}->{$fields[$i]}->{precision};
${$self->{scales}}{$fields[$i]} =
$xmldoc->{select}->{columns}->{column}->{$fields[$i]}->{scale};
${$self->{defaults}}{$fields[$i]} = undef;
if (length($xmldoc->{select}->{columns}->{column}->{$fields[$i]}->{default}) > 0)
{
${$self->{defaults}}{$fields[$i]} =
$xmldoc->{select}->{columns}->{column}->{$fields[$i]}->{default};
}
$self->{use_fields} .= $fields[$i] . ',';
}
if (ref($xmldoc->{select}->{row}) eq 'ARRAY') #ADDED IF-STMT 20020611 TO HANDLE TABLES W/0 OR 1 RECORD!
{
$self->{records} = $xmldoc->{select}->{row}; #TABLE HAS >1 RECORD.
}
elsif (ref($xmldoc->{select}->{row}) eq 'HASH')
{
$self->{records}->[0] = $xmldoc->{select}->{row}; #TABLE HAS 1 RECORD.
}
else
{
$self->{records} = undef; #TABLE HAS NO RECORDS!
}
$xmldoc = undef;
#UNESCAPE ALL VALUES.
if (ref($self->{records}) eq 'ARRAY') #ADDED IF-STMT 20020611 TO SKIP TABLES W/NO RECORDS!
{
require MIME::Base64; #ADDED 20020816!
for (my $i=0;$i<=$#{$self->{records}};$i++)
{
foreach my $j (@fields)
{
if ($self->{records}->[$i]->{$j}->{'xml:encoding'})
{
$self->{records}->[$i]->{$j} = MIME::Base64::decode_base64($self->{records}->[$i]->{$j}->{content});
}
$self->{records}->[$i]->{$j} = '' if (ref($self->{records}->[$i]->{$j}));
$self->{records}->[$i]->{$j} =~ s/\</\</gso;
$self->{records}->[$i]->{$j} =~ s/\>/\>/gso;
$self->{records}->[$i]->{$j} =~ s/\"/\"/gso;
$self->{records}->[$i]->{$j} =~ s/\&\#45;/\-/gso;
#$self->{records}->[$i]->{$j} =~ s/\&\#0;/\0/gs;
#$self->{records}->[$i]->{$j} =~ s/\&\#(\d+);/pack('C', $1)/egs;
$self->{records}->[$i]->{$j} =~ s/\&/\&/gso;
}
}
}
}
else
{
open (FILE, $file) || return (-501);
binmode FILE; #20000404
# if (($^O eq 'MSWin32') or ($^O =~ /cygwin/i)) #CHGD. TO NEXT 20020221
if ($self->{platform} eq 'PC')
{
$self->lock || $self->display_error (-515);
}
else #GOOD, MUST BE A NON-M$ SYSTEM :-)
{
eval { flock (FILE, $JSprite::LOCK_EX) || die };
if ($@)
{
$self->lock || $self->display_error (-515) if ($@);
}
}
$_ = <FILE>;
chomp; #JWT:SUPPORT ANY RECORD-SEPARATOR!
my $t = $_;
$_ = $self->{CBC}->decrypt($t) if ($self->{CBC} && $self->{sprite_Crypt} != 2); #ADDED: 20020109
return -527 unless (/^\w+\=/o); #ADDED 20020110
($header) = /^ *(.*?) *$/o;
#####################$header =~ tr/a-z/A-Z/; #JWT 20000316
#@fields = split (/$self->{_read}/o, $header); #CHGD TO NEXT LINE 20021216.
@fields = split (/\Q$self->{_read}\E/, $header);
$no_fields = $#fields;
undef %{ $self->{types} };
undef %{ $self->{lengths} };
undef %{ $self->{scales} }; #ADDED 20000306.
my $ln;
foreach $i (0..$#fields)
{
$dflt = undef;
($fields[$i],$tp,$dflt) = split(/\=/o ,$fields[$i]);
$fields[$i] =~ tr/a-z/A-Z/ unless ($self->{sprite_CaseFieldNames});
$tp = 'VARCHAR(40)' unless($tp);
$tp =~ tr/a-z/A-Z/;
$self->{key_fields} .= $fields[$i] . ','
if ($tp =~ s/^\*//o); #JWT: *TYPE means KEY FIELD!
$ln = 40;
$ln = 10 if ($tp =~ /NUM|INT|FLOAT|DOUBLE/);
#$ln = 5000 if ($tp =~ /$BLOBTYPES/); #CHGD. 20020110.
$ln = $self->{LongReadLen} || 0 if ($tp =~ /$BLOBTYPES/);
$ln = $2 if ($tp =~ s/(.*)\((.*)\)/$1/);
${$self->{types}}{$fields[$i]} = $tp;
${$self->{lengths}}{$fields[$i]} = $ln;
${$self->{defaults}}{$fields[$i]} = undef;
${$self->{defaults}}{$fields[$i]} = $dflt if (defined $dflt);
if (${$self->{lengths}}{$fields[$i]} =~ s/\,(\d+)//)
{
#NOTE: ORACLE NEGATIVE SCALES NOT CURRENTLY SUPPORTED!
${$self->{scales}}{$fields[$i]} = $1;
}
elsif (${$self->{types}}{$fields[$i]} eq 'FLOAT')
{
${$self->{scales}}{$fields[$i]} = ${$self->{lengths}}{$fields[$i]} - 3;
}
${$self->{scales}}{$fields[$i]} = '0' unless (${$self->{scales}}{$fields[$i]});
# (JWT 8/8/1998) $self->{use_fields} .= $column_string . ','; #JWT
$self->{use_fields} .= $fields[$i] . ','; #JWT
}
while (<FILE>)
{
chomp;
$t = $_;
$_ = $self->{CBC}->decrypt($t) if ($self->{CBC} && $self->{sprite_Crypt} != 2); #ADDED: 20020109
next unless ($_);
#@record = split (/$self->{_read}/s, $_); #CHGD. TO NEXT LINE 20021216
@record = split (/\Q$self->{_read}\E/s, $_);
$hash = {};
for ($loop=0; $loop <= $no_fields; $loop++)
{
#NEXT 2 ADDED 20020111 TO PERMIT EMBEDDED RECORD & FIELD SEPERATORS.
$record[$loop] =~ s/\x02\^0jSpR1tE\x02/$self->{_record}/gs; #RESTORE EMBEDDED RECORD SEPARATORS.
$record[$loop] =~ s/\x02\^1jSpR1tE\x02/$self->{_read}/gs; #RESTORE EMBEDDED RECORD SEPARATORS.
$hash->{ $fields[$loop] } = $record[$loop];
}
push @{ $self->{records} }, $hash;
}
close (FILE);
$self->unlock || $self->display_error (-516);
}
chop ($self->{use_fields}) if ($self->{use_fields}); #REMOVE TRAILING ','.
chop ($self->{key_fields}) if ($self->{key_fields});
undef %{ $self->{fields} };
undef @{ $self->{order} };
$self->{order} = [ @fields ];
$self->{fieldregex} = $self->{use_fields};
$self->{fieldregex} =~ s/,/\|/go;
map { $self->{fields}->{$_} = 1 } @fields;
return (1);
}
sub load_columninfo
{
my ($self) = shift;
my ($sep) = shift;
my $colmlist;
if ($#{$self->{order}} >= 0)
{
$colmlist = join($sep, @{$self->{order}});
}
else
{
local (*FILE);
local ($_);
local ($/) = $self->{_record}; #JWT:SUPPORT ANY RECORD-SEPARATOR!
open(FILE, $self->{file}) || return -501;
binmode FILE; #20000404
if ($self->{_read} =~ /^xml/io)
{
return -531 if ($self->{CBC} && $self->{sprite_Crypt} <= 2);
return -532 unless ($XMLavailable);
my $xs1 = XML::Simple->new();
my $xmltext = '';
my $xmldoc;
# eval {$xmldoc = $xs1->XMLin($self->{file}, suppressempty => undef); };
while (<FILE>)
{
last if (/^\s*\<row.*\>\s*$/o);
$xmltext .= $_;
}
$xmltext .= <<END_XML; #MAKE IT WELL-FORMED!
</row>
</select>
</database>
END_XML
eval {$xmldoc = $xs1->XMLin($xmltext, suppressempty => undef); };
$errdetails = $@;
return -501 unless ($xmldoc);
$colmlist = $xmldoc->{select}->{columns}->{order};
if ($colmlist)
{
@{$self->{order}} = split(/$sep/, $colmlist);
}
else
{
@{$self->{order}} = keys(%{$xmldoc->{select}->{columns}->{column}});
$colmlist = join($sep, @{$self->{order}});
}
}
else
{
my $colmlist = <FILE>;
chomp ($colmlist);
#$colmlist =~ s/$self->{_read}/$sep/g; #CHGD. TO NEXT LINE 20021216
$colmlist =~ s/\Q$self->{_read}\E/$sep/g;
@{$self->{order}} = split(/$sep/, $colmlist);
}
close FILE;
}
return $colmlist;
}
sub pscolfn
{
my ($self,$id) = @_;
return $id unless ($id =~ /CURRVAL|NEXTVAL/);
my ($value) = '';
my ($seq_file,$col) = split(/\./,$id);
$seq_file = $self->get_path_info($seq_file) . '.seq';
# $seq_file =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! - REMOVED 20011218 (get_path_info HANDLES THIS RIGHT!)
#open (FILE, "<$seq_file") || return (-511);
unless (open (FILE, "<$seq_file"))
{
$errdetails = "$@/$? (file:$seq_file)";
return (-511);
}
my $x = <FILE>;
#chomp($x);
$x =~ s/\s+$//o; #20000113
( run in 0.840 second using v1.01-cache-2.11-cpan-e1769b4cff6 )