File Coverage

!$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && $class-> _traceln("<-++ BUT ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT=0 THEN WE WILL NOT EXIT AND ROLLBACK -- YOU NEED TO DO IT YOURSELF\n\n");

1553

#DONE IN DESTROY $class-> autorollback && $class-> rollback;

1554

# $class-> autorollback && $class-> rollback;

1555

$class-> _internal_state(ISTATE_CRISIS);

1556

#########$xprm{DIE_AFTER_ROLLBACK} && $class-> autorollback && $class-> disconnect;

1557

#######$xprm{DIE_AFTER_ROLLBACK} && $class-> autorollback && die "CRITICAL ERROR IN DO()... ROLLED BACK r> DISCONNECTED DBHANDLE d> PROGRAM TERMINATED x>\n";

1558

#return 0;

1559

#$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && (exit);

1560

#$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && ($class-> DESTROY);

1561

1562

# if ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT is 1 then check to see whichever exit will be called

1563

$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && ($PERSISTENT_OBJECT_ENABLED) && ($class-> _persistent_exit);

1564

$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && (exit);

1565

# otherwise return undef

1566

return undef;

1567

}

1568

1569

}

1570

1571

1572

1573

########################################################################################

1574

########################################################################################

1575

# PRIVATE!

1576

sub sqlRawbnd {

1577

my $class = shift;

1578

my $q = shift;

1579

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

1580

$class-> _tracingB("sqlRawbnd(): $q\n");

1581

#$class-> _tracingB("sqlRawbnd(): $q ++ @_\n");

1582

1583

# localize variables

1584

local $class->{connection}->{PrintError} if $class->printerror == 0;

1585

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

1586

$class->{connection}->{PrintError}=$class->printerror;

1587

$class->{connection}->{RaiseError}=$class->raiseerror;

1588

local $class->{connection}->{AutoCommit} if $class->autocommit == 0;

1589

$class->{connection}->{AutoCommit}=$class->autocommit;

1590

1591

#my $tm0 = time;

1592

my $tm0 = Time::HiRes::clock();

1593

my $cursor = $class->{connection}->prepare( $q );

1594

$class->{cursor} = $cursor;

1595

my @bind_data_bins=();

1596

if (@_) {

1597

#@bind_data_bins = @_;

1598

foreach (@_) {

1599

# passing string ref is possible, check for these ref and dereference 'em

1600

#my $bnd = ref $_ eq 'SCALAR' ? ${$_} : $_;

1601

# WARNING: because this may not work for Oracle, where the qq{} is needed for the string or varchar...

1602

# in that case use the sqlbnd, or have it done this way!!!

1603

my $bnd = ref $_ eq 'SCALAR' ? qq{${$_}} : $_;

1604

push(@bind_data_bins, $bnd);

1605

}

1606

}

1607

#if ( $binding && ( $class->{cursor}->execute(@bind_data_bins) ) ) {

1608

if ( $class->{cursor}->execute(@bind_data_bins) ) {

1609

$class->{rows} = $class->{cursor}->rows;

1610

$class->{cursor}->finish();

1611

#$class->{cumu_conrun} += time - $tm0;

1612

my $tm1 = Time::HiRes::clock();

1613

$class->{cumu_conrun} += $tm1 - $tm0;

1614

my $elapsed = $tm1 - $tm0;

1615

$class-> _tracingE("sqlRawbnd() PASSED (DONE)(SYSTEM TIME=$elapsed)\n\n");

1616

return 1;

1617

}

1618

else {

1619

# if we did not exited due to raiseerror, then rolling back is possible

1620

# and this is useful in complex $q statement where multiple insert may be embedded!

1621

if ($class-> autorollback && !$class-> autocommit) {

1622

$class-> _traceln("<-r rollback AUTOROLLBACK IS SET TO 1, ALAS ROLLING-BACK\n\n");

1623

$class-> rollback;

1624

##$class-> disconnect;

1625

##die "CRITICAL ERROR WHEN INSERTING... ROLLED BACK\n"; }

1626

$class-> _tracingE("sqlRawbnd() FAILED (ROLLBACK IN EFFECT -- ALAS ROLLING-BACK): ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

1627

}

1628

else {

1629

$class->{rows} = 0;

1630

#$class->{cursor} = $holdCursor;

1631

$class-> _tracingE("sqlRawbnd() FAILED: ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

1632

}

1633

#$class->{cumu_conrun} += time - $tm0;

1634

my $tm1 = Time::HiRes::clock();

1635

$class->{cumu_conrun} += $tm1 - $tm0;

1636

#return undef;

1637

return 0;

1638

}

1639

}

1640

1641

1642

########################################################################################

1643

########################################################################################

1644

1645

1646

# http://www.physiol.ox.ac.uk/Computing/Online_Documentation/DBI.html

1647

# http://www.easysoft.com/developer/languages/perl/dbi-debugging.html

1648

#use DBD::Oracle qw(:ora_types);

1649

#*insertbnd

1650

sub sqlbnd {

1651

my $class = shift;

1652

# start with a good state upon each entry

1653

$class-> _internal_state(ISTATE_GOOD);

1654

1655

my $q = shift;

1656

my $o_bnd = (@_ && (ref $_[0] eq 'ARRAY') && (ref ${$_[0]}[0] eq 'HASH')) ? shift : undef;

1657

my $o_typ = (@_ && (ref $_[0] eq 'HASH')) ? shift : undef;

1658

1659

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

1660

$class-> _tracingB("sqlbnd(): $q\n");

1661

#$class-> _tracingB("SQLSQL: $q ++ @_\n");

1662

1663

# localize variables

1664

local $class->{connection}->{PrintError} if $class->printerror == 0;

1665

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

1666

$class->{connection}->{PrintError}=$class->printerror;

1667

$class->{connection}->{RaiseError}=$class->raiseerror;

1668

local $class->{connection}->{AutoCommit} if $class->autocommit == 0;

1669

$class->{connection}->{AutoCommit}=$class->autocommit;

1670

1671

#my $tm0 = time;

1672

my $tm0 = Time::HiRes::clock();

1673

1674

# if $o is a pseudo hash then go for the binding

1675

if ((ref $o_bnd eq 'ARRAY') && (ref $$o_bnd[0] eq 'HASH')) {

1676

#my $b_canonical;

1677

my @ord = sort values %{$$o_bnd[0]};

1678

my %ord = reverse %{$$o_bnd[0]};

1679

#for (my $i=1; $i<=@ord; $i++) {

1680

# $b_canonical .= ':' . $ord{$i} . ',';

1681

1682

#chop($b_canonical);

1683

#my $sql = "BEGIN $pkgspc($b_canonical); END;";

1684

#my $cursor = $class->{connection}->prepare($sql) or die "Cannot prepare $sql\n";

1685

my $cursor = $class->{connection}->prepare($q) or die "Cannot prepare $q\n";

1686

$class->{cursor} = $cursor;

1687

for (my $i=1; $i<=@ord; $i++) {

1688

#if ($o->[$i]) {

1689

my $str;

1690

$str = (ref $o_bnd->[$i] eq 'SCALAR') ? ${$o_bnd->[$i]} : $o_bnd->[$i];

1691

# Escape as in /usr/lib/perl5/site_perl/5.8/cygwin/DBD/File.pm : sub quote

1692

#$str =~ s/\\/\\\\/sg; $str =~ s/\0/\\0/sg;

1693

#$str =~ s/\'/\\\'/sg; $str =~ s/\n/\\n/sg; $str =~ s/\r/\\r/sg;

1694

#"'$str'";

1695

1696

if ( exists $$o_typ{ $ord{$i} } ) {

1697

$class-> _traceln("................------------------------------........................................ binding $i :$ord{$i} ($$o_typ{ $ord{$i} })\n");

1698

#$cursor->bind_param($i, qq{$o_bnd->[$i]}, {ora_type=>ORA_BLOB} );

1699

#$cursor->bind_param($i, qq{$o_bnd->[$i]}, { ora_type=>$o_typ{ $ord{$i} } } );

1700

$cursor->bind_param($i, qq{$str}, { ora_type=>$$o_typ{ $ord{$i} } } );

1701

}

1702

else {

1703

$class-> _traceln("....................................................................................... binding $i :$ord{$i}\n");

1704

#$cursor->bind_param($i, qq{$o_bnd->[$i]} );

1705

$cursor->bind_param($i, qq{$str} );

1706

}

1707

}

1708

$cursor->execute or die __PACKAGE__, "::sqlbnd Cannot execute $q\n", caller,"\n";

1709

$cursor->finish();

1710

}

1711

else {

1712

my $cursor = $class->{connection}->prepare( $q );

1713

$class->{cursor} = $cursor;

1714

my @bind_data_bins=();

1715

if (@_) {

1716

#@bind_data_bins = @_;

1717

foreach (@_) {

1718

# passing string ref is possible, check for these ref and dereference 'em

1719

my $bnd = ref $_ eq 'SCALAR' ? ${$_} : $_;

1720

push(@bind_data_bins, $bnd);

1721

}

1722

}

1723

#if ( $binding && ( $class->{cursor}->execute(@bind_data_bins) ) ) {

1724

if ( $class->{cursor}->execute(@bind_data_bins) ) {

1725

$class->{rows} = $class->{cursor}->rows;

1726

$class->{cursor}->finish();

1727

#$class->{cumu_conrun} += time - $tm0;

1728

my $tm1 = Time::HiRes::clock();

1729

$class->{cumu_conrun} += $tm1 - $tm0;

1730

my $elapsed = $tm1 - $tm0;

1731

$class-> _tracingE("sqlbnd() PASSED (DONE)(SYSTEM TIME=$elapsed)\n\n");

1732

return 1;

1733

}

1734

else {

1735

# if we did not exit due to raiseerror, then rolling back is possible

1736

# and this is useful in complex $q statement where multiple insert may be embedded!

1737

if ($class-> autorollback && !$class-> autocommit) {

1738

$class-> _traceln("<-r rollback AUTOROLLBACK IS SET TO 1, ALAS ROLLING-BACK\n\n");

1739

$class-> rollback;

1740

##$class-> disconnect;

1741

##die "CRITICAL ERROR WHEN INSERTING... ROLLED BACK\n"; }

1742

$class-> _tracingE("sqlbnd() FAILED (ROLLBACK IN EFFECT -- ALAS ROLLING-BACK): ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

1743

}

1744

else {

1745

$class->{rows} = 0;

1746

#$class->{cursor} = $holdCursor;

1747

$class-> _tracingE("sqlbnd() FAILED: ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

1748

}

1749

#$class->{cumu_conrun} += time - $tm0;

1750

my $tm1 = Time::HiRes::clock();

1751

$class->{cumu_conrun} += $tm1 - $tm0;

1752

#return undef;

1753

return 0;

1754

}

1755

}

1756

}

1757

1758

# DATATY

1759

########################################################################################

1760

########################################################################################

1761

########################################################################################

1762

########################################################################################

1763

########################################################################################

1764

########################################################################################

1765

# need type mapping table, next release

1766

# Test this one with Oracle

1767

1768

use constant BBNNDD => 0;

19880

1769

sub typ_insertbnd { #rslt params

1770

my $class = shift;

1771

my $table = shift;

1772

my $UID0 = shift;

1773

my $targcolumns = shift;

1774

my $CoL_href = shift;

1775

my $El2Ty_href = shift;

1776

1777

my @columns = @{$targcolumns};

1778

1779

#my %H;

1780

my %H2O;

1781

my $xcol; my $yval;

1782

$xcol = 'LOOKUP,'; $yval = "'$UID0',";

1783

1784

###$H{LOOKUP} = "'$UID0'";

1785

#$H{LOOKUP} = \$UID0;

1786

1787

#Ideally: foreach (@RsColumns) { $H{$_} = \"$$CoL_href{$_}"; }

1788

#my $El2Ty_href = $class->{_rsltEl2Ty};

1789

foreach (@columns) {

1790

#foreach (keys %$CoL_href) {

1791

BBNNDD && print "................................................................................................$_ ++ $$El2Ty_href{$_} ++ $$CoL_href{$_} \n";

1792

if (($$El2Ty_href{$_} =~ /STRING/i) && ($$El2Ty_href{$_} !~ /STRING$\s*\^\s*$/i)) {

1793

# avoid inserting a NULL by default for empty string

1794

my $v = ($$CoL_href{$_} eq '') && $xprm{DBSETTING_FORCE_SINGLESPACE_FOR_EMPTY_STRING}

1795

#? \"' '"

1796

#: \"'$$CoL_href{$_}'";

1797

? "' '"

1798

: "'$$CoL_href{$_}'";

1799

$xcol .= $_ . ',';

1800

$yval .= $v . ',';

1801

}

1802

elsif ($$El2Ty_href{$_} =~ /STRING$\s*\^\s*$/) {

1803

# this is a ref of type string pointer STRING(^)=BLOB=~/_sref$/i

1804

$xcol .= $_ . ',';

1805

$yval .= '?,';

1806

$H2O{$_} = $$CoL_href{$_}; # ${ $$CoL_href{$_} }

1807

}

1808

elsif ($$El2Ty_href{$_} =~ /CBOOL/) {

1809

# this is a ref of type string pointer STRING(^)=BLOB=~/_sref$/i

1810

$xcol .= $_ . ',';

1811

$yval .= "'$$CoL_href{$_}'" . ',';

1812

}

1813

else {

1814

$xcol .= $_ . ',';

1815

$yval .= $$CoL_href{$_} . ',';

1816

}

1817

}

1818

$xcol .= 'RECORDDATE_T'; $yval .= $class-> {SYSDATE};

1819

#chop($xcol);

1820

#chop($yval);

1821

1822

my $SQL = "INSERT INTO $table ($xcol) VALUES ($yval)";

1823

my $pseudoLeft; my @pseudoRight; my $fldTyp;

1824

my $i=0;

1825

foreach my $k (sort keys %H2O) {

1826

$pseudoLeft .= "$k=>". ++$i . ",";

1827

#@pseudoRight = (@pseudoRight, $H2O{$k});

1828

push(@pseudoRight , $H2O{$k});

1829

$fldTyp .= "$k=>103,";

1830

}

1831

chop($pseudoLeft);

1832

chop($fldTyp);

1833

1834

BBNNDD && print "aaaaaa************************************************************************************\n";

1835

BBNNDD && print "aaaaaa************************************************************************************ $pseudoLeft\n";

1836

BBNNDD && print "aaaaaa************************************************************************************ $fldTyp\n";

1837

#my %pseudoLeft = eval "%{$pseudoLeft}";

1838

my %pseudoLeft = eval "($pseudoLeft)";

1839

my $o_bnd = [ {%pseudoLeft} , @pseudoRight ];

1840

#my %fldTyp = eval $fldTyp;

1841

my %fldTyp = eval "($fldTyp)";

1842

my $o_typ = \%fldTyp;

1843

if ((ref $o_bnd eq 'ARRAY') && (ref $$o_bnd[0] eq 'HASH')) {

1844

BBNNDD && print "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy $o_bnd\n";

1845

my @ord = sort values %{$$o_bnd[0]};

1846

my %ord = reverse %{$$o_bnd[0]};

1847

for (my $i=1; $i<=@ord; $i++) {

1848

my $str;

1849

$str = (ref $o_bnd->[$i] eq 'SCALAR') ? ${$o_bnd->[$i]} : $o_bnd->[$i];

1850

if ( exists $$o_typ{ $ord{$i} } ) {

1851

BBNNDD && print ".............................................. binding $i ++ :$ord{$i} ($$o_typ{ $ord{$i} })\n";

1852

}

1853

else {

1854

BBNNDD && print ".............................................. binding $i ++ :$ord{$i}\n";

1855

}

1856

}

1857

}

1858

BBNNDD && print "0>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $SQL\n";

1859

BBNNDD && print "1>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $pseudoLeft\n";

1860

BBNNDD && print "2>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> @pseudoRight\n";

1861

BBNNDD && print "3>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $fldTyp\n";

1862

BBNNDD && print "************************************************************************************\n";

1863

1864

1865

# start with a good state upon each entry

1866

$class-> _internal_state(ISTATE_GOOD);

1867

1868

# localize variables

1869

local $class->{connection}->{PrintError} if $class->printerror == 0;

1870

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

1871

$class->{connection}->{PrintError}=$class->printerror;

1872

$class->{connection}->{RaiseError}=$class->raiseerror;

1873

# when $class->autocommit==0 STORE('AutoCommit' undef)= 1

1874

local $class->{connection}->{AutoCommit} if $class->autocommit == 0;

1875

# when $class->autocommit==0 STORE('AutoCommit' '0')= 1

1876

$class->{connection}->{AutoCommit}=$class->autocommit;

1877

1878

1879

my $tm0 = Time::HiRes::clock();

1880

#if ($class->{_dbhandle}->sqlbnd($SQL, $o_bnd, $o_typ) ) {

1881

if ($class-> sqlbnd($SQL, $o_bnd) ) {

1882

my $tm1 = Time::HiRes::clock();

1883

$class->{cumu_conrun} += $tm1 - $tm0;

1884

my $elapsed = $tm1 - $tm0;

1885

}

1886

else {

1887

# $FATAL && die "INTERNAL ERROR ....\n";

1888

my $err = "INTERBAL ERROR WHEN WRITING TO $table failed: ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n";

1889

BBNNDD && print STDOUT $err;

1890

print STDERR $err;

1891

return 0;

1892

}

1893

1894

#$H{RECORDDATE_T}=$SYSDATE;

1895

#if ($class->{_dbhandle}->insertrec($BASETAB_RSLT_PARAMS, %H)) {}

1896

#else {

1897

# die "INTERNAL ERROR MatrixMapper > storeRSO_MatricesIndexTable! ", $class->{_dbhandle}->dbierror(), "\n";

1898

1899

}

1900

1901

########################################################################################

1902

# PRIVATE

1903

# need type mapping table, next release

1904

sub typ_updatebnd { #rslt params

1905

my $class = shift;

1906

my $table = shift;

1907

# my $UID0 = shift;

1908

# my $targcolumns = shift;

1909

my $CoL_href = shift;

1910

my $El2Ty_href = shift;

1911

my $wherecond = shift;

1912

1913

1914

# start with a good state upon each entry

1915

$class-> _internal_state(ISTATE_GOOD);

1916

1917

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

1918

$class-> _tracingB("typ_updatebnd(): $table\n");

1919

1920

# localize variables

1921

local $class->{connection}->{PrintError} if $class->printerror == 0;

1922

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

1923

$class->{connection}->{PrintError}=$class->printerror;

1924

$class->{connection}->{RaiseError}=$class->raiseerror;

1925

# when $class->autocommit==0 STORE('AutoCommit' undef)= 1

1926

local $class->{connection}->{AutoCommit} if $class->autocommit == 0;

1927

# when $class->autocommit==0 STORE('AutoCommit' '0')= 1

1928

$class->{connection}->{AutoCommit}=$class->autocommit;

1929

1930

#my $TOTAL_ELAPSETIME = sprintf("%.2f", Time::HiRes::tv_interval($INVOTIME0));

1931

#${$$statCC{$caconn}}{starttime} = [Time::HiRes::gettimeofday];

1932

#my $tm0 = [Time::HiRes::gettimeofday];

1933

#my $tm0 = time;

1934

my $tm0 = Time::HiRes::clock();

1935

1936

# my @columns = @{$targcolumns};

1937

1938

#my %H;

1939

my %H2O;

1940

# my $xcol; my $yval;

1941

my $xcol_yval = '';

1942

#$xcol = 'LOOKUP,'; $yval = "'$UID0',";

1943

1944

###$H{LOOKUP} = "'$UID0'";

1945

#$H{LOOKUP} = \$UID0;

1946

1947

#Ideally: foreach (@RsColumns) { $H{$_} = \"$$CoL_href{$_}"; }

1948

#my $El2Ty_href = $class->{_rsltEl2Ty};

1949

#foreach (@columns) {

1950

foreach (keys %$CoL_href) {

1951

BBNNDD && print "................................................................................................$_ ++ $$El2Ty_href{$_} ++ $$CoL_href{$_} \n";

1952

if (($$El2Ty_href{$_} =~ /STRING/i) && ($$El2Ty_href{$_} !~ /STRING$\s*\^\s*$/i)) {

1953

# avoid inserting a NULL by default for empty string

1954

my $v = ($$CoL_href{$_} eq '') && $xprm{DBSETTING_FORCE_SINGLESPACE_FOR_EMPTY_STRING}

1955

#? \"' '"

1956

#: \"'$$CoL_href{$_}'";

1957

? "' '"

1958

: "'$$CoL_href{$_}'";

1959

# $xcol .= $_ . ',';

1960

# $yval .= $v . ',';

1961

$xcol_yval .= $_ . '=' . $v . ','

1962

}

1963

elsif ($$El2Ty_href{$_} =~ /STRING$\s*\^\s*$/) {

1964

# this is a ref of type string pointer STRING(^)=BLOB=~/_sref$/i

1965

# $xcol .= $_ . ',';

1966

# $yval .= '?,';

1967

$xcol_yval .= $_ . '=?,';

1968

$H2O{$_} = $$CoL_href{$_}; # ${ $$CoL_href{$_} }

1969

}

1970

elsif ($$El2Ty_href{$_} =~ /CBOOL/) {

1971

# this is a ref of type string pointer STRING(^)=BLOB=~/_sref$/i

1972

# $xcol .= $_ . ',';

1973

# $yval .= "'$$CoL_href{$_}'" . ',';

1974

$xcol_yval .= $_ . "='$$CoL_href{$_}',";

1975

}

1976

else {

1977

# $xcol .= $_ . ',';

1978

# $yval .= $$CoL_href{$_} . ',';

1979

$xcol_yval .= $_ . '=' . $$CoL_href{$_} . ',';

1980

}

1981

}

1982

#$xcol .= 'RECORDDATE_T'; $yval .= $class-> {SYSDATE};

1983

$xcol_yval .= 'CHANGEDATE_T' . '=' . $class-> {SYSDATE};

1984

#chop($xcol);

1985

#chop($yval);

1986

1987

#UPDATE VS001NY_PRSS_JN_INFO SET DISPLAYNAME = 'yyyyyyyyy' WHERE EXISTS (SELECT 1 FROM VS001NY_PRSS_REGISTRY a WHERE VS001NY_PRSS_JN_INFO.LOOKUP = a.LOOKUP);

1988

1989

#my $SQL = "INSERT INTO $table ($xcol) VALUES ($yval)";

1990

my $SQL = "UPDATE $table SET $xcol_yval WHERE $wherecond";

1991

1992

my $pseudoLeft; my @pseudoRight; my $fldTyp;

1993

my $i=0;

1994

foreach my $k (sort keys %H2O) {

1995

$pseudoLeft .= "$k=>". ++$i . ",";

1996

#@pseudoRight = (@pseudoRight, $H2O{$k});

1997

push(@pseudoRight , $H2O{$k});

1998

$fldTyp .= "$k=>103,";

1999

}

2000

chop($pseudoLeft);

2001

chop($fldTyp);

2002

2003

BBNNDD && print "aaaaaa************************************************************************************\n";

2004

BBNNDD && print "aaaaaa************************************************************************************ $pseudoLeft\n";

2005

BBNNDD && print "aaaaaa************************************************************************************ $fldTyp\n";

2006

#my %pseudoLeft = eval "%{$pseudoLeft}";

2007

my %pseudoLeft = eval "($pseudoLeft)";

2008

my $o_bnd = [ {%pseudoLeft} , @pseudoRight ];

2009

#my %fldTyp = eval $fldTyp;

2010

my %fldTyp = eval "($fldTyp)";

2011

my $o_typ = \%fldTyp;

2012

if ((ref $o_bnd eq 'ARRAY') && (ref $$o_bnd[0] eq 'HASH')) {

2013

BBNNDD && print "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy $o_bnd\n";

2014

my @ord = sort values %{$$o_bnd[0]};

2015

my %ord = reverse %{$$o_bnd[0]};

2016

for (my $i=1; $i<=@ord; $i++) {

2017

my $str;

2018

$str = (ref $o_bnd->[$i] eq 'SCALAR') ? ${$o_bnd->[$i]} : $o_bnd->[$i];

2019

if ( exists $$o_typ{ $ord{$i} } ) {

2020

BBNNDD && print ".............................................. binding $i ++ :$ord{$i} ($$o_typ{ $ord{$i} })\n";

2021

}

2022

else {

2023

BBNNDD && print ".............................................. binding $i ++ :$ord{$i}\n";

2024

}

2025

}

2026

}

2027

BBNNDD && print "0>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $SQL\n";

2028

BBNNDD && print "1>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $pseudoLeft\n";

2029

BBNNDD && print "2>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> @pseudoRight\n";

2030

BBNNDD && print "3>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> $fldTyp\n";

2031

BBNNDD && print "************************************************************************************\n";

2032

#if ($class->{_dbhandle}->sqlbnd($SQL, $o_bnd, $o_typ) ) {

2033

if ($class-> sqlbnd($SQL, $o_bnd) ) {

2034

my $tm1 = Time::HiRes::clock();

2035

$class->{cumu_conrun} += $tm1 - $tm0;

2036

my $elapsed = $tm1 - $tm0;

2037

$class-> _tracingE("typ_updatebnd() PASSED (DONE)(SYSTEM TIME=$elapsed)\n\n");

2038

}

2039

else {

2040

$class-> _tracingE("typ_updatebnd() FAILED (ROLLBACK IN EFFECT -- ALAS ROLLING-BACK): ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

2041

# $FATAL && die "INTERNAL ERROR ....\n";

2042

my $err = "INTERBAL ERROR WHEN WRITING TO $table failed: ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n";

2043

BBNNDD && print STDOUT $err;

2044

print STDERR $err;

2045

return 0;

2046

}

2047

2048

#$H{RECORDDATE_T}=$SYSDATE;

2049

#if ($class->{_dbhandle}->insertrec($BASETAB_RSLT_PARAMS, %H)) {}

2050

#else {

2051

# die "INTERNAL ERROR MatrixMapper > storeRSO_MatricesIndexTable! ", $class->{_dbhandle}->dbierror(), "\n";

2052

2053

}

2054

2055

2056

########################################################################################

2057

########################################################################################

2058

########################################################################################

2059

########################################################################################

2060

########################################################################################

2061

########################################################################################

2062

2063

# On success:

2064

# return the number of rows affected

2065

2066

# On failure:

2067

# return undef on failure if raiseerror=0 and autorollback=0

2068

# will die (calling destroy) and will explicit-rollback and will not return if raiseerror=0 and autorollback=1

2069

# will die (calling destroy) and will not return if raiseerror=1 and autorollback=0

2070

2071

sub do {

2072

my $class = shift;

2073

2074

# start with a good state upon each entry

2075

$class-> _internal_state(ISTATE_GOOD);

2076

2077

my $q = shift;

2078

2079

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2080

$class-> _tracingB("DO:\n\t $q\n\n");

2081

2082

# localize variables

2083

local $class->{connection}->{PrintError} if $class->printerror == 0;

2084

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2085

$class->{connection}->{PrintError}=$class->printerror;

2086

$class->{connection}->{RaiseError}=$class->raiseerror;

2087

# when $class->autocommit==0 STORE('AutoCommit' undef)= 1

2088

local $class->{connection}->{AutoCommit} if $class->autocommit == 0;

2089

# when $class->autocommit==0 STORE('AutoCommit' '0')= 1

2090

$class->{connection}->{AutoCommit}=$class->autocommit;

2091

2092

#my $TOTAL_ELAPSETIME = sprintf("%.2f", Time::HiRes::tv_interval($INVOTIME0));

2093

#${$$statCC{$caconn}}{starttime} = [Time::HiRes::gettimeofday];

2094

#my $tm0 = [Time::HiRes::gettimeofday];

2095

#my $tm0 = time;

2096

my $tm0 = Time::HiRes::clock();

2097

#eval {

2098

2099

#my $second = undef;

2100

#my @p;

2101

#if (@_) { $second = shift; }

2102

#while (@_) {

2103

# my $next = shift;

2104

# my $p = ref $next eq 'SCALAR' ? qq{$$next} : $next;

2105

# push(@p,$p);

2106

2107

#my $rr = $class->{connection}->do( $q, $second, @p );

2108

2109

###if ($class->{connection}->do( $q, @_ ) && ! $DBI::err ) {

2110

my $rr_do = $class->{connection}->do( $q, @_ );

2111

# turn old mule "0E0" into plain 0; otherwise number of afftected columns; otherwise undef for false

2112

2113

# turn "0E0" into 0

2114

my $rr = defined $rr_do && $rr_do eq '0E0' ? 0 : $rr_do ? $rr_do : undef;

2115

2116

#TODO: need to benchmark the do() and see if the following assertions may cause a slow down in

2117

# a long do() harness

2118

# Add DOCUMENTATION in POD: Warn the user of the behavior of DROP (also used in recreateTable),

2119

2120

#whenever raiseerror is 0, for a DROP sttm force the return result $rr to 0, so we do not exit

2121

#because dropping a non-existent table will return undef

2122

($class->raiseerror == 0) && (!defined $rr) && ($q =~ /^\s*drop\s+/i) && ($rr = 0);

2123

2124

if (defined $rr) {

2125

$class->_tracingE("DO: PASSED WITH RR=$rr\n");

2126

#$class->autocommit && $class->{connection}->commit;

2127

2128

# my $elap = time - $tm0;

2129

#$class->{cumu_conrun} += time - $tm0;

2130

my $tm1 = Time::HiRes::clock();

2131

$class->{cumu_conrun} += $tm1 - $tm0;

2132

if ($xprm{ENABLE_STATISTICS_ON_DO}) {

2133

# Adjust statistics for arriving queries

2134

$class->{_qryStat}{$q}{count} = (defined $class->{_qryStat}{$q}) ? $class->{_qryStat}{$q}{count}+1 : 1;

2135

$class->{_qryStat}{$q}{tm0} = $tm0;

2136

#$class->{_qryStat}{$q}{tm1} = time;

2137

$class->{_qryStat}{$q}{tm1} = Time::HiRes::clock();

2138

}

2139

#return 1;

2140

return $rr;

2141

}

2142

else {

2143

$class-> _tracingE("DO: FAILED\nERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

2144

2145

# explicit rollback and disconnect

2146

$class-> autorollback && $class-> _traceln("<-++ rollback AUTOROLLBACK is set to 1, ALAS ROLLING-BACK\n\n");

2147

!$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && $class-> _traceln("<-++ BUT ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT=0 THEN WE WILL NOT EXIT AND ROLLBACK -- YOU NEED TO DO IT YOURSELF\n\n");

2148

#DONE IN DESTROY $class-> autorollback && $class-> rollback;

2149

# $class-> autorollback && $class-> rollback;

2150

$class-> _internal_state(ISTATE_CRISIS);

2151

#########$xprm{DIE_AFTER_ROLLBACK} && $class-> autorollback && $class-> disconnect;

2152

#######$xprm{DIE_AFTER_ROLLBACK} && $class-> autorollback && die "CRITICAL ERROR IN DO()... ROLLED BACK r> DISCONNECTED DBHANDLE d> PROGRAM TERMINATED x>\n";

2153

#return 0;

2154

#$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && (exit);

2155

#$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && ($class-> DESTROY);

2156

2157

# if ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT is 1 then check to see whichever exit will be called

2158

$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && ($PERSISTENT_OBJECT_ENABLED) && ($class-> _persistent_exit);

2159

$xprm{ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT} && (exit);

2160

# otherwise return undef

2161

return undef; # same as return $rr;

2162

}

2163

#};

2164

2165

#if ($@) {

2166

# print "ERROR: \t $@ \n\n";

2167

# $class->autorollback && $class->{connection}->rollback;

2168

# return 0;

2169

2170

#return 1;

2171

2172

}

2173

2174

2175

2176

########################################################################################

2177

########################################################################################

2178

# Calls the stored procedure $stproc. The first parameter $o can be either a pseudo-hash

2179

# or a scalar. Passing a pseudo-hash is documented as above, passing a scalar need to be

2180

# documented later.

2181

sub spc {

2182

my $class = shift;

2183

my $o = shift;

2184

my $pkgspc = shift;

2185

2186

# localize variables

2187

local $class->{connection}->{PrintError} if $class->printerror == 0;

2188

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2189

$class->{connection}->{PrintError}=$class->printerror;

2190

$class->{connection}->{RaiseError}=$class->raiseerror;

2191

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2192

$class-> _tracingB("spc()/EXECUTING STORED PROCEDURE:\n\t $pkgspc\n\n");

2193

my $tm0 = Time::HiRes::clock();

2194

2195

# if $o is a pseudo hash then go for the binding

2196

if ((ref $o eq 'ARRAY') && (ref $$o[0] eq 'HASH')) {

2197

my $b_canonical;

2198

my @ord = sort values %{$$o[0]};

2199

my %ord = reverse %{$$o[0]};

2200

for (my $i=1; $i<=@ord; $i++) {

2201

$b_canonical .= ':' . $ord{$i} . ',';

2202

}

2203

2204

chop($b_canonical);

2205

my $sql = "BEGIN $pkgspc($b_canonical); END;";

2206

my $cursor = $class->{connection}->prepare($sql) or die "Cannot prepare $sql\n";

2207

$class->{cursor} = $cursor;

2208

# go in order and bind the parameters, if a parameter is defined then bind_param otherwise bind_param_inout

2209

for (my $i=1; $i<=@ord; $i++) {

2210

if ($o->[$i]) {

2211

$cursor->bind_param(":$ord{$i}", $o->[$i]);

2212

}

2213

else {

2214

#$cursor->bind_param_inout(":$ord{$i}", \$o->[$i], 1) unless $o>;

2215

$cursor->bind_param_inout(":$ord{$i}", \$o->[$i], 10);

2216

}

2217

}

2218

# die if spc execute fails; users need to test that their spc packages are valids and functioning properly

2219

$cursor-> execute or die __PACKAGE__, "::spc Cannot execute $sql\n";

2220

$cursor-> finish();

2221

2222

if ($o->[1]) {

2223

# my $elap = time - $tm0;

2224

#$class->{cumu_conrun} += time - $tm0;

2225

my $tm1 = Time::HiRes::clock();

2226

$class->{cumu_conrun} += $tm1 - $tm0;

2227

if ($xprm{ENABLE_STATISTICS_ON_SPC}) {

2228

# Adjust statistics for arriving spc's

2229

$class->{_spcStat}{$pkgspc}{count} = (defined $class->{_spcStat}{$pkgspc}) ? $class->{_spcStat}{$pkgspc}{count}+1 : 1;

2230

$class->{_spcStat}{$pkgspc}{tm0} = $tm0;

2231

#$class->{_spcStat}{$pkgspc}{tm1} = time;

2232

$class->{_spcStat}{$pkgspc}{tm1} = Time::HiRes::clock();

2233

}

2234

$class-> _tracingE("spc() PASSED (DONE)\n\n");

2235

return 1;

2236

}

2237

#$o->[1] && return 1;

2238

}

2239

#elsif (ref $o eq 'ARRAY') { # simple array list, then simple binding with ?

2240

2241

else { # $o is a SCALAR

2242

my $sql = "BEGIN $pkgspc(?); END;";

2243

my $cursor = $class->{connection}->prepare($sql) or die "Cannot prepare $sql\n";

2244

$class->{cursor} = $cursor;

2245

2246

$cursor-> execute($o) or die __PACKAGE__, "::spc Cannot execute $sql\n";

2247

$cursor-> finish();

2248

2249

# my $elap = time - $tm0;

2250

#$class->{cumu_conrun} += time - $tm0;

2251

my $tm1 = Time::HiRes::clock();

2252

$class->{cumu_conrun} += $tm1 - $tm0;

2253

if ($xprm{ENABLE_STATISTICS_ON_SPC}) {

2254

# Adjust statistics for arriving spc's

2255

$class->{_spcStat}{$pkgspc}{count} = (defined $class->{_spcStat}{$pkgspc}) ? $class->{_spcStat}{$pkgspc}{count}+1 : 1;

2256

$class->{_spcStat}{$pkgspc}{tm0} = $tm0;

2257

#$class->{_spcStat}{$pkgspc}{tm1} = time;

2258

$class->{_spcStat}{$pkgspc}{tm1} = Time::HiRes::clock();

2259

}

2260

$class-> _tracingE("spc() PASSED (DONE)\n\n");

2261

return 1;

2262

}

2263

2264

return 0;

2265

}

2266

2267

2268

2269

########################################################################################

2270

#DEPRE

2271

#used in chopping cart!

2272

# select $s1 from $table where $s2;

2273

# go over elements from each fetched record, and form a colon ":" seperated string

2274

# push each colon seperated string on the list reference $L

2275

# *retrieve_inlist {

2276

sub fetchTda_inCoList {

2277

my $class = shift;

2278

2279

my $table = shift;

2280

my $s1 = shift;

2281

my $s2 = shift;

2282

2283

my $elements = shift;

2284

my $L = shift;

2285

2286

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2287

$class-> _tracingB("fetchTda_inCoList():\n\t $table\n$s1\n$s2\n\n");

2288

2289

my @flds = [];

2290

if ( ($elements =~ /,/) ) {

2291

@flds = split(/,/,$elements);

2292

}

2293

2294

my $q = "SELECT $s1 FROM $table WHERE $s2;";

2295

2296

2297

my $cursor = $class->{connection}->prepare( $q );

2298

2299

$class->{cursor} = $cursor;

2300

2301

$class->{cursor}->execute();

2302

$class->{rows} = $class->{cursor}->rows;

2303

my $temp;

2304

my $key;

2305

my $i = 0;

2306

while ($temp = $class->{cursor}->fetchrow_hashref()) {

2307

my %hr = %$temp;

2308

if ($elements =~ /,/) {

2309

my $s;

2310

my $t;

2311

foreach $t (@flds) {

2312

$s .= $hr{$t} . ':';

2313

2314

}

2315

chop($s) if $s =~ /:$/;

2316

push(@$L,$s);

2317

2318

}

2319

else {

2320

push(@$L,$hr{$elements});

2321

}

2322

$i++;

2323

}

2324

$class->{cursor}->finish();

2325

2326

$class-> _tracingE("fetchTda_inCoList() PASSED (DONE)\n\n");

2327

2328

return $i;

2329

}

2330

2331

2332

########################################################################################

2333

# DEPRE

2334

# Fetch data from a table that got an extra pseudo ordered column (i.e. ordre).

2335

# After retrieving the records from that table, these records are kept in a hash

2336

# that is reordered properly and pushed to a list. The final result is an ordered

2337

# list.

2338

# The current method work on a single column and is used by Varisphere.

2339

# *retrieve_inOrderedList

2340

sub fetchTda_inOrderedList {

2341

my $class = shift;

2342

2343

my $table = shift;

2344

my $s1 = shift;

2345

my $os2 = shift;

2346

my $s3 = shift;

2347

2348

my $L = shift;

2349

2350

my $q = "SELECT $s1,$os2 FROM $table WHERE $s3 order by $os2;";

2351

2352

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2353

$class-> _tracingB("retrieve_inOrderedList(): \n\tfrom TABLE $table\n\t$q\n\n");

2354

2355

my $cursor = $class->{connection}->prepare( $q );

2356

2357

$class->{cursor} = $cursor;

2358

2359

$class->{cursor}->execute();

2360

$class->{rows} = $class->{cursor}->rows;

2361

my $temp;

2362

my %hr;

2363

while ($temp = $class->{cursor}->fetchrow_hashref()) {

2364

$hr{ $$temp{$os2} } = $$temp{$s1};

2365

}

2366

foreach my $k (sort keys %hr) {

2367

push(@$L,$hr{$k});

2368

}

2369

2370

$class->{cursor}->finish();

2371

2372

$class-> _tracingE("retrieve_inOrderedList() PASSED (DONE)\n\n");

2373

2374

return scalar(@$L);

2375

}

2376

2377

2378

########################################################################################

2379

#DEPRE

2380

2381

#use it when records are unique, since it returns a single (first encountered) record

2382

#record result is in \%H

2383

#return 1 on success, 0 if no record is found, -1 if DBI error

2384

2385

#my @flds = (SKUARCHIVE,TOPICHEAD,TITLE,AUTHOR);

2386

#if ( ($dbhandle->fetchTda_inHash('ARCHIVE', ' SKUARCHIVE,TOPICHEAD,TITLE,AUTHOR,SYNOPSIS ' ," SKUARCHIVE=\'$skuarchive\' ",\%dbhash, \@flds)) ) {}

2387

2388

#if ( ($class->{_dbhandle}->fetchTda_inHash($DBTABLENAME," * " ," id=$i ",\%H) > 0) ) {

2389

# *retrieve_inhash

2390

2391

sub fetchTda_inHash {

2392

my $class = shift;

2393

my $table = shift;

2394

my $s1 = shift;

2395

my $s2 = shift;

2396

my $hh = shift;

2397

2398

my $list = @_ ? shift : [];

2399

2400

my $q = "SELECT $s1 FROM $table WHERE $s2"; # $s2;"

2401

2402

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2403

$class-> _tracingB("fetchTda_inHash(): \n\tfrom TABLE $table\n\t$q\n\n");

2404

2405

my $cursor = $class->{connection}->prepare( $q );

2406

2407

$class->{cursor} = $cursor;

2408

$class->{cursor}->execute();

2409

if ($DBI::err) {

2410

$class-> _tracingE("fetchTda_inHash() Failed: (CRISIS) $DBI::err -- $DBI::errstr\n returning FALSE (-1)\n");

2411

$class-> _internal_state(ISTATE_CRISIS);

2412

return -1;

2413

}

2414

2415

$class->{rows} = $class->{cursor}->rows;

2416

my $key;

2417

2418

if (my $temp = $class->{cursor}->fetchrow_hashref()) {

2419

my %hr = %$temp;

2420

if (@{$list}) {

2421

for (my $j=0; $j < @{$list}; $j++) {

2422

$key = $$list[$j];

2423

$$hh{$key} = $hr{$key};

2424

# $class->{debhook}->print("++++++++++++++++++++++++>>> $key ++ $$hh{$key} <<<\n");

2425

}

2426

}

2427

else {

2428

%$hh = %hr;

2429

}

2430

$class->{cursor}->finish();

2431

$class-> _tracingE("fetchTda_inHash(): returned TRUE \n");

2432

return 1;

2433

}

2434

else {

2435

$class->{cursor}->finish();

2436

$class-> _tracingE("fetchTda_inHash(): returned FALSE \n");

2437

return 0;

2438

}

2439

}

2440

2441

2442

2443

########################################################################################

2444

2445

sub fetchQdaO {

2446

my $class = shift;

2447

my $q = shift;

2448

#my $hrf = shift;

2449

my $hrf = (ref $_[0] eq 'HASH') ? shift : {};

2450

2451

#my $list = (@_ && ref $_[0] eq 'ARRAY') ? shift : undef; # [];

2452

my $list = (ref $_[0] eq 'ARRAY') ? shift : undef; # [];

2453

2454

my @bindparams = @_;

2455

2456

die "RETURNING AND DOING NOTHING FROM getdaO: CANNOT HAVE * AND SPECIFY LIST!\n" if ($list) && $q =~ /SELECT\s+\*\s+/i;

2457

2458

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2459

$class-> _tracingB("fetchQdaO(): \n\t$q\n\n");

2460

2461

2462

# localize these Lags

2463

local $class->{connection}->{PrintError} if $class->printerror == 0;

2464

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2465

$class->{connection}->{PrintError}=$class->printerror;

2466

$class->{connection}->{RaiseError}=$class->raiseerror;

2467

2468

#my $tm0 = time;

2469

my $tm0 = Time::HiRes::clock();

2470

#$class->{_qryStat}{$q}{tm0} = time;

2471

2472

2473

2474

my $cursor = $class->{connection}->prepare( $q );

2475

$class->{cursor} = $cursor;

2476

2477

my $i=1;

2478

foreach (@bindparams) {

2479

$class-> _traceln("\tfetchQdaO() BINDING: $i ---to---> $_\n");

2480

$class->{cursor}->bind_param($i++,$_);

2481

}

2482

2483

2484

$class->{cursor}->execute();

2485

if ($DBI::err) {

2486

$class-> _tracingE("getdaO Failure: (CRISIS) $DBI::err -- $DBI::errstr\n returning FALSE (-1)\n");

2487

$class-> _internal_state(ISTATE_CRISIS);

2488

return undef;

2489

}

2490

2491

$class->{rows} = $class->{cursor}->rows;

2492

2493

#if (@{$list}) {

2494

if ($list) {

2495

#print "1- In list context <<<<<<<<<<<<<<<<<<<<\n";

2496

my %temp;

2497

for (my $j=0; $j < @{$list}; $j++) {

2498

#print "........................................................... binding $j+1 --to--> hrf $$list[$j]\n";

2499

#DOES NOT WORK! $class->{cursor}-> bind_col($j+1, \$$hrf{ $$list[$j] });

2500

$class->{cursor}-> bind_col($j+1, \$temp{ $$list[$j] });

2501

}

2502

# eval {};

2503

$class->{cursor}-> fetch;

2504

$class->{cursor}-> finish();

2505

#if ($@) {}

2506

if ($class->{cursor}->rows) {

2507

foreach my $k (keys %temp) { $$hrf{$k} = \$temp{$k}; }

2508

2509

my $tm1 = Time::HiRes::clock();

2510

$class->{cumu_conrun} += $tm1 - $tm0;

2511

my $elapsed = $tm1 - $tm0;

2512

$class-> _tracingE("fetchQdaO(): returned A RECORD with BINDING (SYSTEM TIME=$elapsed)\n");

2513

return $hrf;

2514

#return 1;

2515

}

2516

else {

2517

#print "Eeeeeeeeeeeeeeeeeempttttttttttyyyyyyyyyyy\n";

2518

return $hrf;

2519

#return 0;

2520

}

2521

}

2522

elsif (my $temp = $class->{cursor}->fetchrow_hashref()) {

2523

#print "2- in default <<<<<<<<<<<<<<<<<<<<\n";

2524

##%$hrf = %$temp;

2525

# get the addresses not the values (not this %$hrf = %$temp;)

2526

foreach my $k (keys %$temp) { $$hrf{$k} = \$$temp{$k}; }

2527

$class->{cursor}->finish();

2528

my $tm1 = Time::HiRes::clock();

2529

$class->{cumu_conrun} += $tm1 - $tm0;

2530

my $elapsed = $tm1 - $tm0;

2531

$class-> _tracingE("fetchQdaO(): returned A RECORD without any BINDING (SYSTEM TIME=$elapsed)\n");

2532

return $hrf;

2533

#return 1;

2534

}

2535

else {

2536

#print "3- zero <<<<<<<<<<<<<<<<<<<<\n";

2537

$class->{cursor}->finish();

2538

my $tm1 = Time::HiRes::clock();

2539

$class->{cumu_conrun} += $tm1 - $tm0;

2540

my $elapsed = $tm1 - $tm0;

2541

$class-> _tracingE("fetchQdaO(): returned NO RECORD (SYSTEM TIME=$elapsed)\n");

2542

return $hrf;

2543

#return 0;

2544

}

2545

}

2546

2547

2548

2549

########################################################################################

2550

sub fetchQdaAA

2551

{

2552

my $class = shift;

2553

my $q = shift;

2554

2555

#$q = qq{begin $q; end;};

2556

#my $hash;

2557

#$hash = shift @params if ($#params >= 0 && ref($params[0]) eq 'HASH');

2558

#my %h = %{$hash} if $hash;

2559

2560

# recalling and passing an array ref allow to extend the referenced list, otherwise start fresh

2561

my $rows = (@_ && ref $_[0] eq 'ARRAY') ? shift : [];

2562

# have a recalled flag ready

2563

my $recalled = (@_ && ref $_[0] eq 'ARRAY' && defined ${$_[0]}[0]) ? 1 : 0;

2564

2565

#my $extras = shift if ref @_[0] eq 'HASH';

2566

my $extras = shift if ref $_[0] eq 'HASH';

2567

my @bindparams = @_;

2568

2569

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2570

$class-> _tracingB("fetchQdaAA():\n\t $q\n\n");

2571

2572

# localize these Lags

2573

local $class->{connection}->{PrintError} if $class->printerror == 0;

2574

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2575

$class->{connection}->{PrintError}=$class->printerror;

2576

$class->{connection}->{RaiseError}=$class->raiseerror;

2577

2578

#my $tm0 = time;

2579

my $tm0 = Time::HiRes::clock();

2580

#$class->{_qryStat}{$q}{tm0} = time;

2581

2582

#TODO: eval and report error!

2583

my $cursor = $class->{connection}->prepare($q); # or die "Cannot prepare $q\n";

2584

$class->{cursor} = $cursor;

2585

2586

my $i=1;

2587

foreach (@bindparams) {

2588

$class-> _traceln("\tfetchQdaAA() BINDING: $i ---to---> $_\n");

2589

$class->{cursor}->bind_param($i++,$_);

2590

}

2591

2592

eval{

2593

$class->{cursor}->execute();

2594

};

2595

($@) && die "ERROR: $@\n";

2596

2597

$class->{rows} = $class->{cursor}->rows;

2598

2599

if ( !$recalled && (($$extras{INCLUDE_HEADER}) || !(defined $$extras{INCLUDE_HEADER})) )

2600

{

2601

my @header = ();

2602

for (my $i=0;$i<$class->{cursor}->{NUM_OF_FIELDS};$i++)

2603

{

2604

push(@header,$class->{cursor}->{NAME}->[$i]);

2605

}

2606

push(@$rows,\@header);

2607

}

2608

#my $cnt = 0;

2609

my $cnt = -1;

2610

while (my @r = $class->{cursor}->fetchrow_array)

2611

#while(my $r = $class->{cursor}->fetchrow_arrayref)

2612

{

2613

#$class-> _traceln("\t RETRIEVED $cnt ROWS -- \n");

2614

#print STDERR "\t RETRIEVED $cnt ROWS -- \n";

2615

#push(@$rows,$r); # << FASTER push(@$rows,\@r);

2616

$cnt++;

2617

push(@$rows,\@r);

2618

#$cnt++;

2619

($cnt%100 == 0) && $class-> _traceln("\t RETRIEVED $cnt ROWS\n");

2620

($$extras{MAX_ROWS} && $cnt >= $$extras{MAX_ROWS}) &&

2621

$class->{cursor}->finish && last;

2622

}

2623

#$class->{cumu_conrun} += time - $tm0;

2624

my $tm1 = Time::HiRes::clock();

2625

$class->{cumu_conrun} += $tm1 - $tm0;

2626

my $elapsed = $tm1 - $tm0;

2627

2628

$class-> _tracingE("fetchQdaAA/SELECT_TO_ARRAY (with ROWS=$rows) (SYSTEM TIME=$elapsed)\n");

2629

2630

return undef if $cnt == -1;

2631

return $rows;

2632

}

2633

2634

2635

########################################################################################

2636

########################################################################################

2637

2638

sub fetchTdaAA

2639

{

2640

my $class = shift;

2641

# my $q = shift;

2642

# my $flags = shift if ref @_[0] eq 'HASH';

2643

# my @bindparams = @_;

2644

2645

my $table = shift;

2646

my $selection = shift;

2647

my $where = shift;

2648

2649

my $aarf = (@_ && ref $_[0] eq 'ARRAY') ? shift : []; # passing an array ref allow to extend the referenced list, otherwise start fresh

2650

my @bindparams = @_;

2651

2652

my $s1 = '';

2653

2654

my $seeked = 'all';

2655

my(@A) = ();

2656

2657

2658

# passing the attributes as an array ref. return a 2D array for the table pointed to by aarf

2659

if (ref($selection) eq 'ARRAY')

2660

{

2661

for (my $j=0; $j < @{$selection}; $j++)

2662

{

2663

push(@A,$$selection[$j]);

2664

$s1 .= $$selection[$j] . ',';

2665

}

2666

chop($s1); $s1 .= ' ';

2667

$seeked = 'array';

2668

}

2669

# a ref to a hash of attributes; (TODO: !!! return an array of hashes)

2670

elsif (ref($selection) eq 'HASH')

2671

{

2672

my $sel = '';

2673

foreach (keys %$selection) {

2674

#$sel .= $_ . ','

2675

$sel .= $$selection{$_} . ','

2676

}

2677

chop($sel);

2678

$s1 = $sel;

2679

$seeked = 'skeemamap';

2680

#@A = split(/,/,$selection);

2681

#foreach (@A) { s/^\s+//; s/\s+$//; } # trim starting and ending spaces

2682

#$s1 = $selection;

2683

#$seeked = 'listed';

2684

}

2685

# a wildcard * for everything; (TODO: !!! return an array of hashes)

2686

elsif ($selection =~ /^[\s]*\*[\s]*$/)

2687

{

2688

$seeked = 'all';

2689

$s1 = ' * ';

2690

}

2691

# a string of attributes; (TODO: !!! return an array of hashes)

2692

elsif ($selection =~ /\w/)

2693

{

2694

@A = split(/,/,$selection);

2695

foreach (@A) { s/^\s+//; s/\s+$//; } # trim starting and ending spaces

2696

$s1 = $selection;

2697

$seeked = 'listed';

2698

}

2699

2700

2701

my $q;

2702

if (defined($where) && (length($where)) && !($where =~ /^\s+$/)) {

2703

$q = "SELECT $s1 FROM $table WHERE $where";

2704

}

2705

else {

2706

$q = "SELECT $s1 FROM $table";

2707

}

2708

2709

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2710

$class-> _tracingB("fetchTdaAA():\n\t $q\n\n");

2711

2712

# localize these Lags

2713

local $class->{connection}->{PrintError} if $class->printerror == 0;

2714

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2715

$class->{connection}->{PrintError}=$class->printerror;

2716

$class->{connection}->{RaiseError}=$class->raiseerror;

2717

#my $tm0 = time;

2718

my $tm0 = Time::HiRes::clock();

2719

#$class->{_qryStat}{$q}{tm0} = time;

2720

2721

my $cursor = $class->{connection}->prepare( $q );

2722

$class->{cursor} = $cursor;

2723

for (my $i=0; $i<@bindparams; $i++) {

2724

$b = $i + 1;

2725

$class-> _traceln("\t BINDING:$b --to--> $bindparams[$i]\n");

2726

$class->{cursor}->bind_param($b ,$bindparams[$i]);

2727

}

2728

2729

eval{

2730

$class->{cursor}->execute();

2731

};

2732

($@) && die "ERROR: $@\n";

2733

2734

$class->{rows} = $class->{cursor}->rows;

2735

2736

my $temp;

2737

my $key;

2738

my $i = -1; # -1 if nothing returned, but incremented and therefore starting at 0

2739

2740

my $cnt = 0;

2741

2742

#my @rows;

2743

#if ($$flags{INCLUDE_HEADER})

2744

{

2745

my @header = ();

2746

for (my $i=0;$i<$class->{cursor}->{NUM_OF_FIELDS};$i++)

2747

{

2748

push(@header,$class->{cursor}->{NAME}->[$i]);

2749

}

2750

#push(@rows,\@header);

2751

push(@{$aarf},\@header);

2752

}

2753

2754

while(my @r = $class->{cursor}->fetchrow_array) {

2755

#while ($temp = $class->{cursor}->fetchrow_hashref()) {

2756

$i++; # start counting at 0

2757

#my %hr = %$temp;

2758

2759

if ( ($seeked eq 'all') || ($seeked eq 'array') || ($seeked eq 'listed') || ($seeked eq 'skeemamap') )

2760

{

2761

#foreach my $key (keys %hr) { $$aarf[$i]{$key} = $hr{$key}; }

2762

push(@{$aarf},\@r); # Equivalent

2763

}

2764

# $cnt++;

2765

# ($cnt%100 == 0) && $class->_tracing("\t RETRIEVED $cnt ROWS\n");

2766

# ($$flags{MAX_ROWS} && $cnt >= $$flags{MAX_ROWS}) &&

2767

# $class->{cursor}->finish && last;

2768

2769

#elsif ($seeked eq 'array')

2770

#{ # array are ordered following the listed attributes, get them (in order) from @A

2771

# foreach my $j (0..$#A) {

2772

# #AS 2D ARRAY FOR FASTER ACCESS

2773

# $$aarf[$i][$j]=$hr{$A[$j]};

2774

# }

2775

2776

}

2777

$class->{cursor}->finish();

2778

2779

#for (my $j=0; $j < $i; $j++){

2780

# print "$j ++ ";

2781

# foreach my $k (keys %{$$aarf[$j]}){

2782

# print "$k=", $$aarf[$j]{$k}, " + ";

2783

# }

2784

# print "\n";

2785

2786

#exit;

2787

2788

#$class->{cumu_conrun} += time - $tm0;

2789

my $tm1 = Time::HiRes::clock();

2790

$class->{cumu_conrun} += $tm1 - $tm0;

2791

$class-> _tracingE("fetchTdaAA():\n\tfrom TABLE $table -- ROWS OK = $class->{rows}\n");

2792

2793

#return $class->{rows};

2794

#return $i; # return number of records

2795

return undef if $i == -1; # return number of records

2796

return $aarf;

2797

}

2798

2799

2800

2801

########################################################################################

2802

2803

2804

# July 2005: changed the following to start with an array index at 0: $ahrf[0]{}

2805

# @ahrf is an array of hash that is returned for all records found. @ahrf start counting at 0

2806

# and that used to be undef before the change (see below)

2807

# *retrieve_in_aobj = *retrieve_inobjects = \&fetchTdaAO;

2808

sub fetchTdaAO {

2809

my $class = shift;

2810

2811

# start with a good state upon each entry

2812

$class-> _internal_state(ISTATE_GOOD);

2813

2814

my $table = shift;

2815

my $selection = shift;

2816

my $where = shift;

2817

2818

my $ahrf = @_ ? shift : []; # passing an array ref allow to extend the referenced list, otherwise start fresh

2819

2820

my $s1 = '';

2821

2822

my $seeked = 'all';

2823

my(@A) = ();

2824

2825

2826

# passing the attributes as an array ref. return a 2D array for the table pointed to by ahrf

2827

if (ref($selection) eq 'ARRAY')

2828

{

2829

for (my $j=0; $j < @{$selection}; $j++)

2830

{

2831

push(@A,$$selection[$j]);

2832

$s1 .= $$selection[$j] . ',';

2833

}

2834

chop($s1); $s1 .= ' ';

2835

$seeked = 'array';

2836

}

2837

# a ref to a hash of attributes; return an array of hashes

2838

elsif (ref($selection) eq 'HASH')

2839

{

2840

my $sel = '';

2841

foreach (keys %$selection) {

2842

#$sel .= $_ . ','

2843

$sel .= $$selection{$_} . ','

2844

}

2845

chop($sel);

2846

$s1 = $sel;

2847

$seeked = 'skeemamap';

2848

#@A = split(/,/,$selection);

2849

#foreach (@A) { s/^\s+//; s/\s+$//; } # trim starting and ending spaces

2850

#$s1 = $selection;

2851

#$seeked = 'listed';

2852

}

2853

# a wildcard * for everything; return an array of hashes

2854

elsif ($selection =~ /^[\s]*\*[\s]*$/)

2855

{

2856

$seeked = 'all';

2857

$s1 = ' * ';

2858

}

2859

# a string of attributes; return an array of hashes

2860

elsif ($selection =~ /\w/)

2861

{

2862

@A = split(/,/,$selection);

2863

foreach (@A) { s/^\s+//; s/\s+$//; } # trim starting and ending spaces

2864

$s1 = $selection;

2865

$seeked = 'listed';

2866

}

2867

2868

2869

my $q;

2870

if (defined($where) && (length($where)) && !($where =~ /^\s+$/)) {

2871

#MYSQL $q = "SELECT $s1 FROM $table WHERE $where;";

2872

$q = "SELECT $s1 FROM $table WHERE $where";

2873

}

2874

else {

2875

#MYSQL $q = "SELECT $s1 FROM $table;";

2876

$q = "SELECT $s1 FROM $table";

2877

}

2878

2879

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2880

$class-> _tracingB("fetchTdaAO/RETRIEVE_IN_AOBJ:\n\t $q\n\n");

2881

2882

# localize these Lags

2883

local $class->{connection}->{PrintError} if $class->printerror == 0;

2884

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2885

$class->{connection}->{PrintError}=$class->printerror;

2886

$class->{connection}->{RaiseError}=$class->raiseerror;

2887

#my $tm0 = time;

2888

my $tm0 = Time::HiRes::clock();

2889

#$class->{_qryStat}{$q}{tm0} = time;

2890

2891

my $cursor = $class->{connection}->prepare( $q );

2892

2893

$class->{cursor} = $cursor;

2894

2895

$class->{cursor}->execute();

2896

$class->{rows} = $class->{cursor}->rows;

2897

my $temp;

2898

my $key;

2899

my $i = -1; # -1 if nothing returned, but incremented and therefore starting at 0

2900

2901

while ($temp = $class->{cursor}->fetchrow_hashref()) {

2902

$i++; # start counting at 0, and old start counting at 1 IS DEPRECATED

2903

my %hr = %$temp;

2904

2905

if ( ($seeked eq 'all') || ($seeked eq 'listed') || ($seeked eq 'skeemamap') )

2906

{

2907

#foreach my $key (keys %hr)

2908

2909

# $$ahrf[$i]{$key} = $hr{$key};

2910

2911

push(@{$ahrf},\%hr); # Equivalent

2912

}

2913

elsif ($seeked eq 'array')

2914

{ # array are ordered following the listed attributes, get them (in order) from @A

2915

foreach my $j (0..$#A) {

2916

#AS 2D ARRAY FOR FASTER ACCESS

2917

$$ahrf[$i][$j]=$hr{$A[$j]};

2918

}

2919

}

2920

}

2921

$class->{cursor}->finish();

2922

2923

#for (my $j=0; $j < $i; $j++){

2924

# print "$j ++ ";

2925

# foreach my $k (keys %{$$ahrf[$j]}){

2926

# print "$k=", $$ahrf[$j]{$k}, " + ";

2927

# }

2928

# print "\n";

2929

2930

#exit;

2931

2932

# my $elap = time - $tm0;

2933

#$class->{cumu_conrun} += time - $tm0;

2934

my $tm1 = Time::HiRes::clock();

2935

$class->{cumu_conrun} += $tm1 - $tm0;

2936

$class-> _tracingE("fetchTdaAO/retrieve_in_aobj:\n\tfrom TABLE $table -- ROWS OK = $class->{rows}\n");

2937

2938

#return $class->{rows};

2939

#return $i; # return number of records

2940

return undef if $i == -1; # return number of records

2941

return $ahrf;

2942

}

2943

2944

########################################################################################

2945

########################################################################################

2946

########################################################################################

2947

########################################################################################

2948

2949

########################################################################################

2950

sub commit {

2951

my $class = shift;

2952

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2953

$class-> _tracingB("COMMIT (CALLED EXPLICITLY) \n\n");

2954

2955

# localize variables

2956

local $class->{connection}->{PrintError} if $class->printerror == 0;

2957

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2958

$class->{connection}->{PrintError}=$class->printerror;

2959

$class->{connection}->{RaiseError}=$class->raiseerror;

2960

# when $class->autocommit==0 STORE('AutoCommit' undef)= 1

2961

local $class->{connection}->{AutoCommit} if $class->autocommit == 0;

2962

# when $class->autocommit==0 STORE('AutoCommit' '0')= 1

2963

$class->{connection}->{AutoCommit}=$class->autocommit;

2964

2965

eval {

2966

$class->{connection}->commit;

2967

};

2968

if ($@) {

2969

$class-> status($DBI::errstr);

2970

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2971

$class-> _tracingE("COMMIT: ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

2972

return 0;

2973

}

2974

$class-> _tracingE("COMMIT ok\n");

2975

return 1;

2976

}

2977

2978

2979

2980

########################################################################################

2981

sub rollback {

2982

my $class = shift;

2983

2984

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

2985

$class-> _tracingB("***rollback() CALLED (DELEGATED TO DBI)*** \n\n");

2986

2987

# localize variables

2988

local $class->{connection}->{PrintError} if $class->printerror == 0;

2989

local $class->{connection}->{RaiseError} if $class->raiseerror == 0;

2990

$class->{connection}->{PrintError}=$class->printerror;

2991

$class->{connection}->{RaiseError}=$class->raiseerror;

2992

# when $class->autocommit==0 STORE('AutoCommit' undef)= 1

2993

local $class->{connection}->{AutoCommit} if $class->autocommit == 0;

2994

# when $class->autocommit==0 STORE('AutoCommit' '0')= 1

2995

$class->{connection}->{AutoCommit}=$class->autocommit;

2996

2997

2998

#if (!$class-> is_RaiseError && !$class-> is_AutoCommit && $class-> is_AutoRollback) {

2999

if (!$class-> is_AutoCommit && $class-> is_AutoRollback) {

3000

eval {

3001

$class->{connection}->rollback;

3002

};

3003

if ($@) {

3004

###NO state=CONNECTED|DISCONNETED|UNDEF $class-> state('ERROR');

3005

##$class-> _inside_state(CRISIS); # use constant CRISIS => 1

3006

$class-> status($DBI::errstr);

3007

$class-> _tracingE("rollback(): ERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

3008

return 0;

3009

}

3010

$class-> _tracingE("ROLLBACK ok\n");

3011

return 1;

3012

}

3013

else {

3014

$class-> _tracingE("rollback() -- CANNOT CALL ROLLBACK BECAUSE THE FOLLOWING CONDITION IS NOT SATISFIED: RaiseError=0 AutoCommit=0 AutoRollback=1\n");

3015

}

3016

}

3017

3018

3019

########################################################################################

3020

# to finish an opened cursor handle

3021

3022

sub finish {

3023

my $class = shift;

3024

3025

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3026

$class-> _tracing("FINISH");

3027

$class->{cursor}->finish();

3028

}

3029

3030

3031

########################################################################################

3032

sub disconnect {

3033

my $class = shift;

3034

3035

if ($PERSISTENT_OBJECT_ENABLED) {

3036

print STDERR

3037

3038

You should never call the disconnect on a persistent DBI::BabyConnect object, although

3039

it is possible to call this function, but because many DBI::BabyConnect objects may

3040

be cached by one or more child processes, then you won't be able to keep track of

3041

which one has disconnected, (unless you check the state of DBI::BabyConnect object ...)

3042

and this will lead to more confusion. Let's keep it simple, hence I will not disconnect

3043

this handle because PERSISTENT_OBJECT_ENABLED is 1.

3044

3045

}

3046

3047

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3048

$class-> _tracingB("DISCONNECT");

3049

3050

$xprm{PRT_CEND} && print STDOUT "ent-> disconnect() ***", $class-> state, "\n";

3051

3052

#$class->{connection}->disconnect() or die "CONNECTION MANAGER: disconnect() failed: $DBI::errstr\n";

3053

#return;

3054

#goto OOO;

3055

3056

die "

3057

disconnect() PROBLEM:

3058

CALLING disconnect() ON ALREADY DISCONNECTED HANDLER --

3059

ALTHOUGH THE CODE WILL NOT FAIL, BUT DISCONNECT MUST BE

3060

CALLED ONCE FOR PROPER CODING. (state= $class->state)

3061

" if ($xprm{CALLER_DISCONNECT} && ($class-> state eq 'DISCONNECTED'));

3062

3063

die "

3064

disconnect() PROBLEM:

3065

SHOULD NOT CALL DISCONNECT ON AN UNDEF.

3066

THERE HAS NEVER BEEN A CONNECTION ANYWAY!

3067

" if ($xprm{CALLER_DISCONNECT} && ($class-> state eq 'UNDEF'));

3068

3069

#$dbiconnection->disconnect();

3070

#commit ineffective with AutoCommit enabled:

3071

#$class->{connection}->commit();

3072

#OOO:

3073

$class-> state('DISCONNECTED');

3074

$class-> status('DISCONNECTED');

3075

3076

#TODO make sure that DBI:: disconnect() return false on failure

3077

#$class->{connection}->disconnect() or die "CONNECTION MANAGER: disconnect() failed: $DBI::errstr\n";

3078

if (! $class->{connection}->disconnect()) {

3079

$class-> _tracingE("DISCONNECT FAILED (AND PROGRAM EXITING)\nERROR in DBI !\n\t DBI FAILED ON:\t$DBI::err\n\t DBI REASON:\t$DBI::errstr\n\t DBI LED:\t$DBI::state\n\n");

3080

die "CONNECTION MANAGER: disconnect() failed: $DBI::errstr\n";

3081

}

3082

3083

$xprm{PRT_CEND} && print STDOUT "<-don disconnect() ***", $class-> state, "\n";

3084

$class-> _tracingE("DISCONNECT");

3085

3086

#do not undef the connection yet, DESTROY will do this:

3087

#$class->{connection} = undef;

3088

3089

}

3090

3091

3092

########################################################################################

3093

# DESTROY_HOOK() garbage collect the OO file handle if any has been requested

3094

# during the instantiation with new()

3095

sub DESTROY_HOOK

3096

{

3097

my $class = shift;

3098

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3099

$class-> _traceln("hstdlog-d> HOOK DESTROY: ALAS NO MORE WRITING!\n");

3100

return unless $class->{debhook};

3101

#$class->{debhook}->close();

3102

$class->{debhook}->DESTROY;

3103

$class->{debhook} = undef;

3104

}

3105

3106

3107

3108

3109

########################################################################################

3110

sub _persistent_exit

3111

{

3112

my $class = shift;

3113

3114

# It is possible to force the execution of the body of this sub DESTROY by calling

3115

# DESTROY(1), that is setting the $FORCE_USUAL_DESTRUCTION to 1, even if

3116

# the class has been loaded with DISABLE_DESTROY enabled (set to 1, typically

3117

# needed when persisting with Apache::BabyConnect).

3118

my $FORCE_USUAL_DESTRUCTION = @_ ? shift : 0;

3119

3120

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3121

$class-> _tracingB("ent-> DESTROY (CONNECTION STATUS=".$class-> state.")\n");

3122

$class-> _traceln("_persistent_exit (CONNECTION STATUS=".$class-> state.") FORCE_DESTRUCTION=$FORCE_USUAL_DESTRUCTION, DISABLE_DESTROY=$PERSISTENT_OBJECT_ENABLED\n");

3123

3124

3125

#return if ($PERSISTENT_OBJECT_ENABLED and !$FORCE_USUAL_DESTRUCTION);

3126

#return if $PERSISTENT_OBJECT_ENABLED;

3127

if ($PERSISTENT_OBJECT_ENABLED and !$FORCE_USUAL_DESTRUCTION) {

3128

if (!$class-> is_RaiseError &&

3129

!$class-> is_AutoCommit &&

3130

$class-> is_AutoRollback &&

3131

($class-> _internal_state eq ISTATE_CRISIS)) {

3132

print STDERR "!!!!!ERROR STATE IN CRISIS, MAY BE DUE TO A FAILING DO!!!!!\n";

3133

print STDERR "!!!!!WE ARE GOING TO ROLLBACK!!!!!\n";

3134

#($class-> rollback)

3135

# || die "STATUS IS IN ERROR AND CANNOT ROLLBACK: ", $class->{connection}->errstr, "\n";

3136

($class-> rollback)

3137

|| _traceln("DBI FAILED TO ROLLBACK WITH REASON: ". $class->{connection}->errstr . "\n");

3138

#$class->{connection}->disconnect || die "ERROR WHEN DESTROY>DISCONNECT: ", $class->{connection}->errstr, "\n";

3139

#$class->{connection}->DESTROY;

3140

$class-> _tracingE("<-don DESTROY/PERSISTENT_OBJECT_ENABLED ** (CRISIS) ENDED WITH ERROR (CONNECTION STATUS=".$class-> state.") ******** \n");

3141

#$class-> DESTROY_HOOK;

3142

#die "EXITING WITH ERROR: CRISIS, AND ENDING THIS HANDLER CLASS!\n";

3143

}

3144

#return;

3145

}

3146

# to get to this point you need to have ON_FAILED_DBIEXECUTE_ROLLBACK_AND_EXIT and PERSISTENT_OBJECT_ENABLED,

3147

# which is typical with mod_perl with Apache::BabyConnect, in which case the following exit() is redirected to

3148

# the Apache::exit() that will terminate the script only

3149

exit;

3150

}

3151

3152

3153

3154

3155

3156

3157

########################################################################################

3158

# When $PERSISTENT_OBJECT_ENABLED = 1 (i.e. when using Apache::BabyConnect), the DESTROY

3159

# will also be executed to cleanup the state of the handle. For instance, if

3160

# the ISTATE_CRISIS and Autorollback then the autorollback is called.

3161

# When $PERSISTENT_OBJECT_ENABLED = 1, the DESTROY will never call the disconnect.

3162

3163

# it is the reponsibility of the caller to disconnect the dbi handle; therefore,

3164

# the DESTROY of this class will never disconnect the dbhandle.

3165

#sub DESTROY {}

3166

#sub DUNNO_DESTROY

3167

sub DESTROY

3168

{

3169

my $class = shift;

3170

3171

# It is possible to force the execution of the body of this sub DESTROY by calling

3172

# DESTROY(1), that is setting the $FORCE_USUAL_DESTRUCTION to 1, even if

3173

# the class has been loaded with DISABLE_DESTROY enabled (set to 1, typically

3174

# needed when persisting with Apache::BabyConnect).

3175

my $FORCE_USUAL_DESTRUCTION = @_ ? shift : 0;

3176

3177

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3178

$class-> _tracingB("ent-> DESTROY (CONNECTION STATUS=".$class-> state.")\n");

3179

$class-> _traceln("DESTROY (CONNECTION STATUS=".$class-> state.") FORCE_DESTRUCTION=$FORCE_USUAL_DESTRUCTION, DISABLE_DESTROY=$PERSISTENT_OBJECT_ENABLED\n");

3180

3181

3182

#return if ($PERSISTENT_OBJECT_ENABLED and !$FORCE_USUAL_DESTRUCTION);

3183

#return if $PERSISTENT_OBJECT_ENABLED;

3184

if ($PERSISTENT_OBJECT_ENABLED and !$FORCE_USUAL_DESTRUCTION) {

3185

if (!$class-> is_RaiseError &&

3186

!$class-> is_AutoCommit &&

3187

$class-> is_AutoRollback &&

3188

($class-> _internal_state eq ISTATE_CRISIS)) {

3189

print STDERR "!!!!!ERROR STATE IN CRISIS, MAY BE DUE TO A FAILING DO!!!!!\n";

3190

print STDERR "!!!!!WE ARE GOING TO ROLLBACK!!!!!\n";

3191

#($class-> rollback)

3192

# || die "STATUS IS IN ERROR AND CANNOT ROLLBACK: ", $class->{connection}->errstr, "\n";

3193

($class-> rollback)

3194

|| _traceln("DBI FAILED TO ROLLBACK WITH REASON: ". $class->{connection}->errstr . "\n");

3195

#$class->{connection}->disconnect || die "ERROR WHEN DESTROY>DISCONNECT: ", $class->{connection}->errstr, "\n";

3196

#$class->{connection}->DESTROY;

3197

$class-> _tracingE("<-don DESTROY/PERSISTENT_OBJECT_ENABLED ** (CRISIS) ENDED WITH ERROR (CONNECTION STATUS=".$class-> state.") ******** \n");

3198

#$class-> DESTROY_HOOK;

3199

#die "EXITING WITH ERROR: CRISIS, AND ENDING THIS HANDLER CLASS!\n";

3200

}

3201

return;

3202

}

3203

3204

3205

3206

# when $xprm{CALLER_DISCONNECT}, it is mandatory to have the caller disconnecting ...

3207

#die "IT IS THE RESPONSIBILITY OF THE CALLER TO THIS HANDLER TO DISCONNECT (UNLESS RaiseError!!!)!!!!!!!!!!\n"

3208

# if ($xprm{CALLER_DISCONNECT} && ($class-> state ne 'DISCONNECTED'));

3209

3210

3211

# return if $class-> state eq 'DISCONNECTED';

3212

3213

#if ($class-> state eq 'DISCONNECTED') {

3214

if ($xprm{CALLER_DISCONNECT} && $class-> state eq 'DISCONNECTED') {

3215

#if (!$class-> is_RaiseError && !$class-> is_AutoCommit && $class-> is_AutoRollback && ($class-> _internal_state eq ISTATE_CRISIS)) {

3216

# ... in CRISIS but handle already disconnected, then we can do nothing. (should be that the caller is handling this error)

3217

3218

#else {

3219

$class->{connection}->DESTROY;

3220

$class-> _tracingE("<-don DESTROY ** ENDED CLEANLY WITH (CONNECTION STATUS=".$class-> state." _internal_state=".$class-> _internal_state.") ******** \n");

3221

# gone for good, alas, no more logging

3222

$class-> DESTROY_HOOK;

3223

}

3224

elsif ($class-> state eq 'UNDEF') {

3225

#die "STATE of connection is UNDEF!\n";

3226

}

3227

elsif ($xprm{CALLER_DISCONNECT} && $class-> state eq 'CONNECTED') {

3228

if ($class-> is_RaiseError && $DBI::err) { # due to DBI die, but also check ...

3229

$xprm{PRT_CEND} && print STDOUT "**Rollback**Rollback**Rollback**Rollback**Rollback**Rollback**Rollback** in DESTROY\n";

3230

($class-> is_AutoRollback && !$class-> is_AutoCommit)

3231

&& (($class-> rollback)

3232

|| die "STATUS IS IN ERROR AND CANNOT ROLLBACK: ", $class->{connection}->errstr);

3233

$class->{connection}->disconnect || die "ERROR WHEN DESTROY>DISCONNECT: ", $class->{connection}->errstr, "\n";

3234

$class->{connection}->DESTROY;

3235

# gone for good, alas, no more logging

3236

#if ( $class->{debhook} ) {

3237

# #$class->{debhook}->close();

3238

# $class->{debhook}->DESTROY;

3239

# $class->{debhook} = undef;

3240

3241

$class-> _tracingE("<-don DESTROY ** ENDED WITH DBI-RAISING ERROR ** ROLLBACK OK (CONNECTION STATUS=".$class-> state.") ******** \n");

3242

$class-> DESTROY_HOOK;

3243

die "FATAL ERROR: WE ARE IN ERROR DUE TO ROLLBACK, WE ROLLED BACK, AND DIE NOW!\n";

3244

}

3245

# TODO: CRISIS whenever _inside_state, i.e. check "sub do"

3246

# if still CONNECTED and Lags are properly set for rollback and the _inside_state is in CRISIS then rollback

3247

elsif (!$class-> is_RaiseError && !$class-> is_AutoCommit && $class-> is_AutoRollback && ($class-> _internal_state eq ISTATE_CRISIS)) {

3248

print STDERR "!!!!!ERROR STATE IN CRISIS, MAY BE DUE TO A FAILING DO!!!!!\n";

3249

print STDERR "!!!!!WE ARE GOING TO ROLLBACK, THEN DISCONNECT AND DIE!!!!!\n";

3250

$xprm{PRT_CEND} && print STDOUT "!!!!!ERROR STATE IN CRISIS, MAY BE DUE TO A FAILING DO!!!!!\n";

3251

$xprm{PRT_CEND} && print STDOUT "!!!!!WE ARE GOING TO ROLLBACK, THEN DISCONNECT AND DIE!!!!!\n";

3252

($class-> rollback)

3253

|| die "STATUS IS IN ERROR AND CANNOT ROLLBACK: ", $class->{connection}->errstr, "\n";

3254

$class->{connection}->disconnect || die "ERROR WHEN DESTROY>DISCONNECT: ", $class->{connection}->errstr, "\n";

3255

$class->{connection}->DESTROY;

3256

$class-> _tracingE("<-don DESTROY ** (CRISIS) ENDED WITH ERROR (CONNECTION STATUS=".$class-> state.") ******** \n");

3257

$class-> DESTROY_HOOK;

3258

die "EXITING WITH ERROR: CRISIS, AND ENDING THIS HANDLER CLASS!\n";

3259

}

3260

else {

3261

print STDERR "!!!!!IT IS THE RESPONSIBILITY OF THE CALLER TO THIS HANDLER TO DISCONNECT!!!!!\n";

3262

print STDERR "!!!!!WE ARE GOING TO DISCONNECT ANYWAY, AND DIE!!!!!\n";

3263

$xprm{PRT_CEND} && print STDOUT "!!!!!IT IS THE RESPONSIBILITY OF THE CALLER TO THIS HANDLER TO DISCONNECT!!!!!\n";

3264

$xprm{PRT_CEND} && print STDOUT "!!!!!WE ARE GOING TO DISCONNECT ANYWAY, AND DIE!!!!!\n";

3265

$class->{connection}->disconnect;

3266

$class->{connection}->DESTROY;

3267

# gone for good, alas, no more logging

3268

$class-> _tracingE("<-don DESTROY ** ENDED WITH ERROR (CONNECTION STATUS=".$class-> state.") ******** \n");

3269

$class-> DESTROY_HOOK;

3270

die "EXITING WITH ERROR: CALLER MUST DISCONNECT BEFORE ENDING THIS HANDLER CLASS!\n";

3271

}

3272

}

3273

3274

#my $c = [caller];

3275

#print STDOUT "@{$c} -- \n DESSSSSSSSSsssssssssssssssssssssstroyed \n\n";

3276

}

3277

3278

########################################################################################

3279

########################################################################################

3280

########################################################################################

3281

########################################################################################

3282

3283

3284

# STATISTICS Section

3285

########################################################################################

3286

########################################################################################

3287

########################################################################################

3288

########################################################################################

3289

3290

3291

sub _statCCreset {

3292

my $kprocess = shift;

3293

my $desc = shift;

3294

my $caconn = "$kprocess$desc";

3295

${$$statCC{$caconn}}{kprocess} = $kprocess;

3296

${$$statCC{$caconn}}{descriptor} = $desc;

3297

${$$statCC{$caconn}}{counter} = 1;

3298

#${$$statCC{$caconn}}{systime};

3299

#${$$statCC{$caconn}}{dbtime};

3300

#Time::HiRes::clock();

3301

#Time::HiRes::clock();

3302

3303

#my $TOTAL_ELAPSETIME = sprintf("%.2f", Time::HiRes::tv_interval($INVOTIME0));

3304

#${$$statCC{$caconn}}{starttime} = [Time::HiRes::gettimeofday];

3305

#${$$statCC{$caconn}}{starttime} = localtime;

3306

${$$statCC{$caconn}}{starttime} = iso_date();

3307

${$$statCC{$caconn}}{hires0} = [Time::HiRes::gettimeofday];

3308

${$$statCC{$caconn}}{clock0} = Time::HiRes::clock();

3309

}

3310

3311

sub _statCC {

3312

my $kprocess = shift;

3313

my $desc = shift;

3314

my $caconn = "$kprocess$desc";

3315

##${$$statCC{$caconn}}{kprocess} =

3316

#${$$statCC{$caconn}}{descriptor} =

3317

++${$$statCC{$caconn}}{counter};

3318

#${$$statCC{$caconn}}{systime};

3319

#${$$statCC{$caconn}}{dbtime};

3320

#${$$statCC{$caconn}}{starttime} = ;

3321

}

3322

3323

sub getStatCC {

3324

#my $caconn = shift;

3325

my $class = shift;

3326

my $rshr = @_ ? shift : undef;

3327

3328

foreach my $caconn (keys %$statCC) {

3329

#my $elapse = sprintf("%.2f", Time::HiRes::tv_interval(${$$statCC{$caconn}}{starttime}));

3330

${$$statCC{$caconn}}{clock1} = Time::HiRes::clock();

3331

#my $clock = ${$$statCC{$caconn}}{clock1} - ${$$statCC{$caconn}}{clock0};

3332

${$$statCC{$caconn}}{clock} = ${$$statCC{$caconn}}{clock1} - ${$$statCC{$caconn}}{clock0};

3333

3334

#my ${$$statCC{$caconn}}{hires1} = [Time::HiRes::gettimeofday];

3335

#my $elapse = sprintf("%.2f", Time::HiRes::tv_interval(${$$statCC{$caconn}}{hires0}));

3336

${$$statCC{$caconn}}{elapse} = sprintf("%.2f", Time::HiRes::tv_interval(${$$statCC{$caconn}}{hires0}));

3337

}

3338

3339

(ref $rshr eq 'HASH') && (%$rshr = map{$_=>$$statCC{$_}} (keys %$statCC)) && (return $rshr);

3340

my $th={};

3341

(length($rshr) > 2) && (%$th = map{$_=>$$statCC{$_}}(keys %{$$statCC{$rshr}})) && (return $th);

3342

3343

#return $statCC;

3344

3345

my $info;

3346

foreach my $caconn (keys %$statCC) {

3347

$info .= "

3348

$caconn

3349

${$$statCC{$caconn}}{kprocess}

3350

${$$statCC{$caconn}}{descriptor}

3351

${$$statCC{$caconn}}{counter}

3352

${$$statCC{$caconn}}{starttime}

3353

elapse: ${$$statCC{$caconn}}{elapse}

3354

time: ${$$statCC{$caconn}}{clock}

3355

3356

3357

}

3358

return $info;

3359

}

3360

3361

sub htmlStatCC {

3362

#my $caconn = shift;

3363

my $class = shift;

3364

3365

foreach my $caconn (keys %$statCC) {

3366

#my $elapse = sprintf("%.2f", Time::HiRes::tv_interval(${$$statCC{$caconn}}{starttime}));

3367

${$$statCC{$caconn}}{clock1} = Time::HiRes::clock();

3368

#my $clock = ${$$statCC{$caconn}}{clock1} - ${$$statCC{$caconn}}{clock0};

3369

${$$statCC{$caconn}}{clock} = ${$$statCC{$caconn}}{clock1} - ${$$statCC{$caconn}}{clock0};

3370

3371

#my ${$$statCC{$caconn}}{hires1} = [Time::HiRes::gettimeofday];

3372

#my $elapse = sprintf("%.2f", Time::HiRes::tv_interval(${$$statCC{$caconn}}{hires0}));

3373

${$$statCC{$caconn}}{elapse} = sprintf("%.2f", Time::HiRes::tv_interval(${$$statCC{$caconn}}{hires0}));

3374

}

3375

3376

3377

print "

3378

3379

The table below shows the cached connection of this http server process. The columns designation

3380

summary is as follow:

3381

3382

id -- unique ID of the connection object formed of kernel process ID + database descriptor

3383

kprocess -- kernel process ID

3384

counter -- number of times the DBI::BabyObject has been requested

3385

starttime -- start time is ISO date format

3386

elapse -- number of seconds since the DBI::BabyObject object has been created

3387

clock -- system+user system time consumed by the specified cached DBI::BabyObject object

3388

3389

3390

' , map("", @fields) , ""; ", map("",@fields) , "";

$_
3391
3392			";
3393	0	0	my @fields = qw(id kprocess counter starttime elapse clock);
3394	0	0	print '
3395	0	0	shift @fields;
3396
3397	0	0	foreach my $caconn (keys %$statCC) {
3398	0	0	print "
$caconn	${$$statCC{$caconn}}{$_}
	0	0
3399			}
3400
3401	0	0	print "

3402

3403

}

3404

3405

3406

3407

sub iso_date {

3408

my $date = (localtime->year() + 1900).'-'._two_digit(localtime->mon() + 1).'-'._two_digit(localtime->mday());

3409

my $time = _two_digit(localtime->hour()).':'._two_digit(localtime->min()).':'._two_digit(localtime->sec());

3410

return "$date $time";

3411

}

3412

3413

sub _two_digit {

3414

2145

my $value = $_[0];

3415

100

$value = '0'.$value if( length($value) == 1 );

3416

return $value;

3417

}

3418

3419

3420

3421

sub get_running_time {

3422

my $class = shift;

3423

3424

my $clock1 = Time::HiRes::clock();

3425

my $totclock = $clock1 - $class->{clock0};

3426

3427

#my $totrun = time - $class->{time0};

3428

#[Time::HiRes::gettimeofday];

3429

#my $totrun = Time::HiRes::tv_interval($class->{time0});

3430

my $totrun = sprintf("%.2f", Time::HiRes::tv_interval($class->{time0}));

3431

my $conrun = $class->{cumu_conrun};

3432

return "$conrun / $totclock / $totrun";

3433

}

3434

3435

3436

########################################################################################

3437

3438

sub get_do_stat {

3439

my $class = shift;

3440

my $rshr = @_ ? shift : undef;

3441

3442

my $th={};

3443

(ref $rshr eq 'HASH') && (%$rshr = map{$_=>$class-> {_qryStat}{$_}}(keys %{$class-> {_qryStat}})) && (return $rshr);

3444

(length($rshr) > 2) && (%$th = map{$_=>$class-> {_qryStat}{$_}}(keys %{${$class-> {_qryStat}}{$rshr}})) && (return $th);

3445

3446

my $info;

3447

foreach my $k (keys %{$class-> {_qryStat}}) {

3448

my $elap = $class-> {_qryStat}{$k}{tm1} - $class-> {_qryStat}{$k}{tm0};

3449

$info .= "

3450

Query: $k

3451

count: ". $class-> {_qryStat}{$k}{count}."

3452

tm0: ". $class-> {_qryStat}{$k}{tm0}."

3453

tm1: ". $class-> {_qryStat}{$k}{tm1}."

3454

elapse: ". $elap."

3455

3456

3457

}

3458

3459

return $info;

3460

}

3461

3462

########################################################################################

3463

sub get_spc_stat {

3464

my $class = shift;

3465

my $rshr = @_ ? shift : undef;

3466

3467

my $th={};

3468

(ref $rshr eq 'HASH') && (%$rshr = map{$_=>$class-> {_spcStat}{$_}}(keys %{$class-> {_spcStat}})) && (return $rshr);

3469

(length($rshr) > 2) && (%$th = map{$_=>$class-> {_spcStat}{$_}}(keys %{${$class-> {_spcStat}}{$rshr}})) && (return $th);

3470

3471

my $info;

3472

foreach my $k (keys %{$class-> {_spcStat}}) {

3473

my $elap = $class-> {_spcStat}{$k}{tm1} - $class-> {_spcStat}{$k}{tm0};

3474

$info .= "

3475

Spc: $k

3476

count: ". $class-> {_spcStat}{$k}{count}."

3477

tm0: ". $class-> {_spcStat}{$k}{tm0}."

3478

tm1: ". $class-> {_spcStat}{$k}{tm1}."

3479

elapse: ". $elap."

3480

3481

3482

}

3483

3484

return $info;

3485

}

3486

3487

########################################################################################

3488

########################################################################################

3489

########################################################################################

3490

########################################################################################

3491

3492

3493

# META Section

3494

########################################################################################

3495

########################################################################################

3496

########################################################################################

3497

########################################################################################

3498

sub snapTableDescription {

3499

my $class = shift;

3500

my $table = shift;

3501

3502

return unless ($class-> dbdriver =~ /Mysql/i);

3503

3504

#my $tabinfo = $class->{connection}->table_info();

3505

3506

# Use the cursor to get a description of the 'onusers' table

3507

#my $cursor = $class->{connection}->prepare( $q );

3508

my $cursor = $class->{connection}->prepare("DESCRIBE $table");

3509

$cursor->execute();

3510

my $info = sprintf "%s", DBI::dump_results($cursor);

3511

$cursor->finish();

3512

#print DBI::dump_results($cursor);

3513

3514

#open(FILE,">foo");

3515

#print DBI::dump_results($cursor,undef,undef,undef,*FILE);

3516

#close(FILE);

3517

#$cursor->finish();

3518

3519

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3520

$class->_tracingB("(snapTableDescription) RETRIEVE TABLE DESCRIPTION FOR $table:\n\tTABLE $info\n\n");

3521

$class->_tracingE("\n");

3522

3523

return $info;

3524

}

3525

3526

########################################################################################

3527

3528

sub snapTablesInfo {

3529

my $class = shift;

3530

3531

return unless ($class-> dbdriver =~ /Mysql/i);

3532

3533

my $tabinfo = $class->{connection}->table_info();

3534

3535

my $info = "\n\n";

3536

$info .= "Table Name Type Qualifier Owner Remarks\n";

3537

$info .= "============================ ======= ========= ============ ================\n";

3538

while (my ($qual,$owner,$name,$type,$remarks) = $tabinfo->fetchrow_array() ) {

3539

foreach ($qual,$owner,$name,$type,$remarks) {

3540

$_ = "NULL" unless defined $_;

3541

}

3542

#$info .= sprintf "%-28s %-7s %-9s %-12s %-16s\n", $name,$type,$qual,$owner,$remarks;

3543

$info .= sprintf "%-28s %7s %9s %12s %16s\n", $name,$type,$qual,$owner,$remarks;

3544

#$info .= "$qual $owner $name $type $remarks \n";

3545

}

3546

3547

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3548

$class->_tracingB("(snapTablesInfo) RETRIEVE ALL TABLES INFO:\n\tTABLE $info\n\n");

3549

$class->_tracingE("");

3550

3551

return $info;

3552

}

3553

3554

my %SQLTY_COMMON_MAP = (

3555

SQL_CHAR => 1,

3556

SQL_NUMERIC => 2,

3557

SQL_DECIMAL => 3,

3558

SQL_INTEGER => 4,

3559

SQL_SMALLINT => 5,

3560

SQL_FLOAT => 6,

3561

SQL_REAL => 7,

3562

SQL_DOUBLE => 8,

3563

SQL_DATE => 9,

3564

SQL_TIME => 10,

3565

SQL_TIMESTAMP => 11,

3566

SQL_VARCHAR => 12,

3567

SQL_LONGVARCHAR => -1,

3568

SQL_BINARY => -2,

3569

SQL_VARBINARY => -3,

3570

SQL_LONGVARBINARY => -4,

3571

SQL_BIGINT => -5,

3572

SQL_TINYINT => -6,

3573

SQL_BIT => -7,

3574

SQL_WCHAR => -8,

3575

SQL_WVARCHAR => -9,

3576

SQL_WLONGVARCHAR => -10,

3577

);

3578

3579

my %SQLTY_INV = _inverse_hash (%SQLTY_COMMON_MAP);

3580

3581

sub _inverse_hash

3582

{

3583

my (%hash) = @_;

3584

my (%inv);

3585

foreach my $key (keys %hash)

3586

{

3587

my $val = $hash{$key};

3588

die "Double mapping for key value $val ($inv{$val}, $key)!"

3589

if (defined $inv{$val});

3590

$inv{$val} = $key;

3591

}

3592

return %inv;

3593

}

3594

# Refer to t_const.pl

3595

3596

# /usr/lib/perl5/vendor_perl/5.8.8/i386-linux-thread-multi/DBI.pm

3597

# /usr/lib/perl5/vendor_perl/5.8.8/i386-linux-thread-multi/DBD/File.pm

3598

# /usr/lib/perl5/vendor_perl/5.8.8/i386-linux-thread-multi/DBI/PurePerl.pm

3599

# /usr/lib/perl5/vendor_perl/5.8.8/i386-linux-thread-multi/auto/DBI/dbi_sql.h

3600

# /usr/lib/perl5/vendor_perl/5.8.8/i386-linux-thread-multi/DBD/Sponge.pm

3601

# in File.pm: sub quote , sub type_info_all

3602

3603

########################################################################################

3604

3605

sub snapTableMetadata {

3606

my $class = shift;

3607

my $table = shift;

3608

3609

return unless ($class-> dbdriver =~ /Mysql/i);

3610

3611

my $info = "\nMETADATA FOR TABLE $table\n\n";

3612

$info .= "ATTRIBUTE NAME TYPE PREC SCALE NULLABLE\n";

3613

$info .= "============================ ================= ===== ===== ========\n";

3614

3615

my $q = "SELECT * FROM $table;";

3616

3617

my $cursor = $class->{connection}->prepare( $q );

3618

$cursor->execute();

3619

my $fields = $cursor->{NUM_OF_FIELDS};

3620

3621

my ($name,$scale,$precision,$type,$nullable);

3622

for (my $i=0; $i<$fields; $i++) {

3623

$name = $cursor->{NAME}->[$i];

3624

$scale = $cursor->{SCALE}->[$i];

3625

$precision = $cursor->{PRECISION}->[$i];

3626

$type = $SQLTY_INV{ $cursor->{TYPE}->[$i] }; # %5d or %-17s

3627

$nullable = ('No','NULL','Unknown')[$cursor->{NULLABLE}->[$i]];

3628

$info .= sprintf "%-28s %17s %5d %5d %8s\n", $name,$type,$precision,$scale,$nullable;

3629

# %32s %4d %4d %-17s %-7s

3630

}

3631

$info .= "\n\n";

3632

$cursor->finish();

3633

3634

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3635

$class-> _tracingB("(snapTableMetadata) RETRIEVE TABLE META DATA FOR:\n\tTABLE $table\n\n");

3636

$class-> _tracingE("");

3637

3638

return $info;

3639

}

3640

3641

########################################################################################

3642

# To retrieve the meta data of a table info

3643

3644

sub strucTableMetadata {

3645

my $class = shift;

3646

my $table = shift;

3647

my @TI;

3648

3649

my $q = "SELECT * FROM $table;";

3650

3651

my $cursor = $class->{connection}->prepare( $q );

3652

$cursor->execute();

3653

my $fields = $cursor->{NUM_OF_FIELDS};

3654

3655

for (my $i=0; $i<$fields; $i++) {

3656

$TI[$i]{NAME} = $cursor->{NAME}->[$i];

3657

$TI[$i]{SCALE} = $cursor->{SCALE}->[$i];

3658

$TI[$i]{PRECISION} = $cursor->{PRECISION}->[$i];

3659

$TI[$i]{TYPE} = $SQLTY_INV{ $cursor->{TYPE}->[$i] }; # %5d or %-17s

3660

#$TI[$i]{NULLABLE} = ('NoNULL','NULL','Unknown')[$cursor->{NULLABLE}->[$i]];

3661

$TI[$i]{NULLABLE} = $cursor->{NULLABLE}->[$i];

3662

# %32s %4d %4d %-17s %-7s

3663

}

3664

$cursor->finish();

3665

3666

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3667

$class-> _tracingB("(getstruct_tableMetadata) RETRIEVE TABLE META DATA FOR:\n\tTABLE $table\n\n");

3668

$class-> _tracingE("");

3669

3670

return \@TI;

3671

}

3672

3673

3674

########################################################################################

3675

########################################################################################

3676

# TODO: move this function from OraPool.

3677

#oraDBMS_getDLL

3678

#C works only with Oracle. This method uses Oracle DBMS to

3679

#get the DLL of a specific table.

3680

3681

#*oraDBMS=\&oraDBMS_getDLL;

3682

#*dbms=\&oraDBMS_getDLL;

3683

sub oraDBMS_getDLL {

3684

my $class = shift;

3685

my $table = shift;

3686

3687

return unless ($class-> dbdriver =~ /Oracle/i);

3688

3689

my $username = uc $class-> dbusername;

3690

my $qry = qq{select dbms_metadata.get_ddl('TABLE','$table','$username') from dual};

3691

#$class->{connection}-> do($qry);

3692

3693

my $cursor = $class->{connection}->prepare( $qry );

3694

3695

$class->{cursor} = $cursor;

3696

3697

$class->{cursor}->execute();

3698

$class->{rows} = $class->{cursor}->rows;

3699

my $temp;

3700

my $key;

3701

my $i = -1; # -1 is nothing fetched

3702

3703

while ($temp = $class->{cursor}->fetchrow_hashref()) {

3704

$i++; # start counting at 0

3705

my %hr = %$temp;

3706

3707

###push(@{$hh},\%hr); # Equivalent

3708

#foreach my $k (keys %hr) {

3709

# print "$k <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n $hr{$k} ----\n\n";

3710

3711

}

3712

$class->{cursor}->finish();

3713

3714

#my $info = "\n\n";

3715

#$info .= "TABLE_SCHEMA TABLE_NAME TABLE_ROWS CREATE_TIME UPDATE_TIME\n";

3716

#$info .= "============== ======================================== ========== ==================== ====================\n";

3717

#for (my $i=0; $i < @$hh; $i++) {

3718

# $info .= sprintf "%-14s %-40s %-10s %-20s %-20s\n", $$hh[$i]{TABLE_SCHEMA}, $$hh[$i]{TABLE_NAME},$$hh[$i]{TABLE_ROWS},$$hh[$i]{CREATE_TIME} ,$$hh[$i]{UPDATE_TIME};

3719

3720

3721

#$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3722

#$class->_tracing("RETRIEVE_INOBJECTS:\n\tfrom TABLE $infotable -- ROWS OK = $class->{rows} \n\t$q\n\n");

3723

3724

}

3725

3726

##############################################################################

3727

3728

# schema1.txt

3729

3730

#*dbstatus {

3731

sub dbschema {

3732

my $class = shift;

3733

3734

#TODO: die unless $dbb eq 'mysql' ... CHECK AS WELL THE VERSION!

3735

return unless ($class-> dbdriver =~ /Mysql/i);

3736

3737

my $infotable = 'INFORMATION_SCHEMA.TABLES';

3738

3739

my $dbname = shift;

3740

3741

my $tablelike = shift;

3742

3743

my $s2 = "TABLE_SCHEMA = '$dbname' AND TABLE_NAME LIKE '$tablelike\%'";

3744

3745

my $hh = shift;

3746

3747

my $seeked = 'all';

3748

my(@A) = ();

3749

3750

my $s1 = '';

3751

my @infoelms = qw(TABLE_SCHEMA TABLE_NAME CREATE_TIME UPDATE_TIME TABLE_ROWS);

3752

for (my $j=0; $j < @infoelms; $j++)

3753

{

3754

push(@A,$infoelms[$j]);

3755

$s1 .= $infoelms[$j] . ',';

3756

}

3757

chop($s1); $s1 .= ' ';

3758

3759

my $q = "SELECT $s1 FROM $infotable WHERE $s2;";

3760

3761

my $cursor = $class->{connection}->prepare( $q );

3762

3763

$class->{cursor} = $cursor;

3764

3765

$class->{cursor}->execute();

3766

$class->{rows} = $class->{cursor}->rows;

3767

my $temp;

3768

my $key;

3769

my $i = -1; # -1 is nothing fetched

3770

3771

while ($temp = $class->{cursor}->fetchrow_hashref()) {

3772

$i++; # start counting at 0

3773

my %hr = %$temp;

3774

3775

push(@{$hh},\%hr); # Equivalent

3776

}

3777

$class->{cursor}->finish();

3778

3779

my $info = "\n\n";

3780

$info .= "TABLE_SCHEMA TABLE_NAME TABLE_ROWS CREATE_TIME UPDATE_TIME\n";

3781

$info .= "============== ============================== ========== ==================== ====================\n";

3782

for (my $i=0; $i < @$hh; $i++) {

3783

$info .= sprintf "%-14s %-30s %-10s %-20s %-20s\n", $$hh[$i]{TABLE_SCHEMA}, $$hh[$i]{TABLE_NAME},$$hh[$i]{TABLE_ROWS},$$hh[$i]{CREATE_TIME} ,$$hh[$i]{UPDATE_TIME};

3784

}

3785

3786

$class->{src} = [caller]; push(@{$class->{src}},(caller 1)[3] || '');

3787

$class-> _tracingB("RETRIEVE_INOBJECTS:\n\tfrom TABLE $infotable -- ROWS OK = $class->{rows} \n\t$q\n\n");

3788

3789

return $info;

3790

}

3791

3792

##############################################################################

3793

3794

# schema2.txt

3795

3796

sub getInfoSchema {

3797

my $class = shift;

3798

3799

#mysql> describe INFORMATION_SCHEMA.statistics;

3800

# select SEQ_IN_INDEX,TABLE_SCHEMA,TABLE_NAME,CARDINALITY,COLUMN_NAME from INFORMATION_SCHEMA.statistics WHERE TABLE_SCHEMA='VARIGENE' AND TABLE_NAME='VS00000001_PROCESSORS_RSLTPARAMS';

3801

my @infsch_statistics = qw(

3802

TABLE_CATALOG

3803

TABLE_SCHEMA

3804

TABLE_NAME

3805

NON_UNIQUE

3806

INDEX_SCHEMA

3807

INDEX_NAME

3808

SEQ_IN_INDEX

3809

COLUMN_NAME

3810

COLLATION

3811

CARDINALITY

3812

SUB_PART

3813

PACKED

3814

NULLABLE

3815

INDEX_TYPE

3816

COMMENT

3817

);

3818

3819

#mysql> describe INFORMATION_SCHEMA.columns;

3820

my @infsch_columns = qw(

3821

TABLE_CATALOG

3822

TABLE_SCHEMA

3823

TABLE_NAME

3824

COLUMN_NAME

3825

ORDINAL_POSITION

3826

COLUMN_DEFAULT

3827

IS_NULLABLE

3828

DATA_TYPE

3829

CHARACTER_MAXIMUM_LENGTH

3830

CHARACTER_OCTET_LENGTH

3831

NUMERIC_PRECISION

3832

NUMERIC_SCALE

3833

CHARACTER_SET_NAME

3834

COLLATION_NAME

3835

COLUMN_TYPE

3836

COLUMN_KEY

3837

EXTRA

3838

PRIVILEGES

3839

COLUMN_COMMENT

3840

);

3841

3842

die "ConnectionManager > getInfoSchema IS NOT IMPLEMENTED!\n";

3843

}

3844

########################################################################################

3845

########################################################################################

3846

########################################################################################

3847

########################################################################################

3848

sub textFormattedAO {

3849

my $class = shift;

3850

my $ah = shift;

3851

my $_titlen = shift;

3852

my $labmap = @_ ? shift : undef;

3853

3854

my @_titlen = $_titlen ? @$_titlen : ();

3855

#my @_titlen = @$_titlen;

3856

my $titlen = \@_titlen;

3857

3858

# to keep order and for any reason nothing is given, then ...

3859

my @realmap;

3860

my @reallen;

3861

foreach my $k (sort keys %{$$ah[0]}) {

3862

push(@realmap,$k);

3863

my $len = 18;

3864

push(@reallen,$len);

3865

}

3866

3867

my @titmap;

3868

my @titlen;

3869

while (my($tit,$len)=splice @$titlen, 0, 2) {

3870

push(@titmap,$tit);

3871

push(@titlen,$len);

3872

}

3873

# If for any reason nothing is given, then ...

3874

if (!@titmap) { @titmap=@realmap; @titlen=@reallen; }

3875

3876

my @labmap = $labmap ? map($$labmap{ $titmap[$_] },(0..@titmap)) : @titmap;

3877

3878

my @sprt;

3879

my $underline = '';

3880

my $info = "\n\n";

3881

for (my $i=0; $i< @titmap; $i++) {

3882

# my $tit = $titmap[$i];

3883

my $tit = $labmap[$i];

3884

my $len = $titlen[$i];

3885

my $clab = (length($tit) <= $len) ? $tit : substr $tit,0,$len;

3886

$info .= $clab;

3887

my $hump = $len - length($tit) + 1;

3888

$info .= ' ' x $hump;

3889

$underline .= '*' x $len;

3890

$underline .= ' ';

3891

push(@sprt, "%-" . $len . 's');

3892

}

3893

$info .= "\n";

3894

$info .= $underline;

3895

$info .= "\n";

3896

# $info .= "Processorid Author Prss Type\n";

3897

# $info .= "********************** ********************* ****************\n";

3898

3899

#my @a = qw(processorid author prsstype);

3900

#my @a = @$titmap;

3901

#my $ah = $prrg->listProcessors();

3902

#my $count = @$ah;

3903

for (my $i=0; $i < @$ah; $i++) {

3904

my(@a) = @{ %{$$ah[$i]} } { @titmap };

3905

#$info .= sprintf "%-22s %-22s %-16s \n", $processorid,$author,$prsstype;

3906

for (my $i=0; $i<@a; $i++) {

3907

my $sprt = $sprt[$i];

3908

my $val = $a[$i];

3909

#$info .= sprintf "%-22s ",$_;

3910

$info .= sprintf "$sprt ",$val;

3911

}

3912

$info .= "\n";

3913

}

3914

return @$ah ? $info : '';

3915

#print $info if @$ah;

3916

}

3917

3918

3919

########################################################################################

3920

########################################################################################

3921

sub datalinesFormattedAO {

3922

my $class = shift;

3923

my $ah = shift;

3924

my $_titlen = shift;

3925

my $labmap = @_ ? shift : undef;

3926

3927

my @_titlen = $_titlen ? @$_titlen : ();

3928

#my @_titlen = @$_titlen;

3929

my $titlen = \@_titlen;

3930

3931

my $lninfo = {

3932

TITLE_LINE => '',

3933

UNDERLINE => '',

3934

DATA_LINES => [],

3935

};

3936

3937

# to keep order and for any reason nothing is given, then ...

3938

my @realmap;

3939

my @reallen;

3940

foreach my $k (sort keys %{$$ah[0]}) {

3941

push(@realmap,$k);

3942

my $len = 18;

3943

push(@reallen,$len);

3944

}

3945

3946

my @titmap;

3947

my @titlen;

3948

while (my($tit,$len)=splice @$titlen, 0, 2) {

3949

push(@titmap,$tit);

3950

push(@titlen,$len);

3951

}

3952

# If for any reason nothing is given, then ...

3953

if (!@titmap) { @titmap=@realmap; @titlen=@reallen; }

3954

3955

my @labmap = $labmap ? map($$labmap{ $titmap[$_] },(0..@titmap)) : @titmap;

3956

3957

my @sprt;

3958

my $underline = '';

3959

my $info = "\n\n";

3960

for (my $i=0; $i< @titmap; $i++) {

3961

# my $tit = $titmap[$i];

3962

my $tit = $labmap[$i];

3963

my $len = $titlen[$i];

3964

my $clab = (length($tit) <= $len) ? $tit : substr $tit,0,$len;

3965

$info .= $clab;

3966

my $hump = $len - length($tit) + 1;

3967

$info .= ' ' x $hump;

3968

$underline .= '*' x $len;

3969

$underline .= ' ';

3970

push(@sprt, "%-" . $len . 's');

3971

}

3972

$info .= "\n";

3973

$$lninfo{TITLE_LINE} = $info;

3974

$info .= $underline;

3975

$info .= "\n";

3976

$$lninfo{UNDERLINE} = "$underline\n";

3977

#$info .= "Processorid Author Prss Type\n";

3978

#$info .= "********************** ********************* ****************\n";

3979

3980

#my @a = qw(processorid author prsstype);

3981

#my @a = @$titmap;

3982

#my $ah = $prrg->listProcessors();

3983

#my $count = @$ah;

3984

for (my $i=0; $i < @$ah; $i++) {

3985

my $ln;

3986

my(@a) = @{ %{$$ah[$i]} } { @titmap };

3987

#$info .= sprintf "%-22s %-22s %-16s \n", $processorid,$author,$prsstype;

3988

for (my $i=0; $i<@a; $i++) {

3989

my $sprt = $sprt[$i];

3990

my $val = $a[$i];

3991

#$info .= sprintf "%-22s ",$_;

3992

$info .= sprintf "$sprt ",$val;

3993

$ln .= sprintf "$sprt ",$val;

3994

}

3995

$info .= "\n";

3996

$ln .= "\n";

3997

push(@{$$lninfo{DATA_LINES}},$ln);

3998

}

3999

return @$ah ? $lninfo : undef;

4000

#return @$ah ? $info : '';

4001

#print $info if @$ah;

4002

}

4003

4004

4005

########################################################################################

4006

########################################################################################

4007

sub textFormattedAA {

4008

my $class = shift;

4009

my $aa = shift;

4010

my $_titlen = shift;

4011

my $labmap = @_ ? shift : undef;

4012

4013

my @_titlen = $_titlen ? @$_titlen : ();

4014

#my @_titlen = @$_titlen;

4015

my $titlen = \@_titlen;

4016

4017

# to keep order and for any reason nothing is given, then ...

4018

my @realmap;

4019

my @reallen;

4020

my $i=0;

4021

my(@a) = @{ $$aa[$i] };

4022

for (my $i=0; $i<@a; $i++) {

4023

push(@realmap,$a[$i]);

4024

my $len = 18;

4025

push(@reallen,$len);

4026

}

4027

4028

my @titmap;

4029

my @titlen;

4030

while (my($tit,$len)=splice @$titlen, 0, 2) {

4031

push(@titmap,$tit);

4032

push(@titlen,$len);

4033

}

4034

# If for any reason nothing is given, then ...

4035

if (!@titmap) { @titmap=@realmap; @titlen=@reallen; }

4036

4037

4038

my @labmap = $labmap ? map($$labmap{ $titmap[$_] },(0..@titmap)) : @titmap;

4039

4040

my @sprt;

4041

my $underline = '';

4042

my $info = "\n\n";

4043

for (my $i=0; $i< @titmap; $i++) {

4044

# my $tit = $titmap[$i];

4045

my $tit = $labmap[$i];

4046

my $len = $titlen[$i];

4047

my $clab = (length($tit) <= $len) ? $tit : substr $tit,0,$len;

4048

$info .= $clab;

4049

my $hump = $len - length($tit) + 1;

4050

$info .= ' ' x $hump;

4051

$underline .= '*' x $len;

4052

$underline .= ' ';

4053

push(@sprt, "%-" . $len . 's');

4054

}

4055

$info .= "\n";

4056

$info .= $underline;

4057

$info .= "\n";

4058

4059

#for (my $i=0; $i < @$aa; $i++) {

4060

for (my $i=1; $i < @$aa; $i++) {

4061

#my(@a) = @{ %{$$aa[$i]} } { @titmap };

4062

my(@a) = @{ $$aa[$i] };

4063

my %rec = map{$realmap[$_]=>$a[$_]}(0..@realmap);

4064

my @z = @{ %rec } { @titmap };

4065

#for (my $i=0; $i<@a; $i++) {

4066

for (my $i=0; $i<@z; $i++) {

4067

my $sprt = $sprt[$i];

4068

#my $val = $a[$i];

4069

my $val = $z[$i];

4070

$info .= sprintf "$sprt ",$val; # "%-22s ",$_

4071

}

4072

$info .= "\n";

4073

}

4074

return @$aa ? $info : '';

4075

}

4076

4077

4078

########################################################################################

4079

########################################################################################

4080

sub datalinesFormattedAA {

4081

my $class = shift;

4082

my $aa = shift;

4083

my $_titlen = shift;

4084

my $labmap = @_ ? shift : undef;

4085

4086

#PERL 6!: return $class-> textFormattedAA($aa,$_titlen,$labmap) unless wanthash();

4087

4088

4089

my @_titlen = $_titlen ? @$_titlen : ();

4090

my $titlen = \@_titlen;

4091

4092

my $lninfo = {

4093

TITLE_LINE => '',

4094

UNDERLINE => '',

4095

DATA_LINES => [],

4096

};

4097

4098

# to keep order and for any reason nothing is given, then ...

4099

my @realmap;

4100

my @reallen;

4101

my $i=0;

4102

my(@a) = @{ $$aa[$i] };

4103

for (my $i=0; $i<@a; $i++) {

4104

push(@realmap,$a[$i]);

4105

my $len = 18;

4106

push(@reallen,$len);

4107

}

4108

4109

my @titmap;

4110

my @titlen;

4111

while (my($tit,$len)=splice @$titlen, 0, 2) {

4112

push(@titmap,$tit);

4113

push(@titlen,$len);

4114

}

4115

# If for any reason nothing is given, then ...

4116

if (!@titmap) { @titmap=@realmap; @titlen=@reallen; }

4117

4118

my @labmap = $labmap ? map($$labmap{ $titmap[$_] },(0..@titmap)) : @titmap;

4119

4120

my @sprt;

4121

my $underline = '';

4122

my $info = "\n\n";

4123

for (my $i=0; $i< @titmap; $i++) {

4124

# my $tit = $titmap[$i];

4125

my $tit = $labmap[$i];

4126

my $len = $titlen[$i];

4127

my $clab = (length($tit) <= $len) ? $tit : substr $tit,0,$len;

4128

$info .= $clab;

4129

my $hump = $len - length($tit) + 1;

4130

$info .= ' ' x $hump;

4131

$underline .= '*' x $len;

4132

$underline .= ' ';

4133

push(@sprt, "%-" . $len . 's');

4134

}

4135

$info .= "\n";

4136

$$lninfo{TITLE_LINE} = $info;

4137

$info .= $underline;

4138

$info .= "\n";

4139

$$lninfo{UNDERLINE} = "$underline\n";

4140

4141

#for (my $i=0; $i < @$aa; $i++) {

4142

for (my $i=1; $i < @$aa; $i++) {

4143

my $ln;

4144

#my(@a) = @{ %{$$aa[$i]} } { @titmap };

4145

my(@a) = @{ $$aa[$i] };

4146

my %rec = map{$realmap[$_]=>$a[$_]}(0..@realmap);

4147

my @z = @{ %rec } { @titmap };

4148

#for (my $i=0; $i<@a; $i++) {

4149

for (my $i=0; $i<@z; $i++) {

4150

my $sprt = $sprt[$i];

4151

#my $val = $a[$i];

4152

my $val = $z[$i];

4153

$info .= sprintf "$sprt ",$val; # "%-22s ",$_

4154

$ln .= sprintf "$sprt ",$val;

4155

}

4156

$info .= "\n";

4157

$ln .= "\n";

4158

push(@{$$lninfo{DATA_LINES}},$ln);

4159

}

4160

#return @$aa ? $info : '';

4161

return @$aa ? $lninfo : undef;

4162

}

4163

4164

########################################################################################

4165

########################################################################################

4166

########################################################################################

4167

########################################################################################

4168

4169

4170

4171

########################################################################################

4172

{

4173

package DBI::BabyConnect::Deb;

4174

4175

# IO::Socket needed for the autoflush() in the PRINT sub

4176

# we will include this once and for all, instead of including

4177

# it in the caller packages (in particular need by the author

4178

# application to debug Varisphere multithread DVARs)

4179

1187

use IO::Socket;

41123

4180

4181

666

use strict;

4182

#use Carp;

4183

use Symbol;

664

4184

4185

sub _no_filter { return $_[0]; }

4186

4187

sub TIEHANDLE

4188

{

4189

my ($class, %args) = @_;

4190

my $handle = gensym();

4191

4192

my $impl = bless {handle => gensym() }, $class;

4193

$impl->OPEN(%args);

4194

return $impl;

4195

}

4196

4197

sub OPEN {

4198

my ($impl, %args) = @_;

4199

#open $impl->{handle}, $args{file} or croak "Could not open that '$args{file}'";

4200

open $impl->{handle}, $args{file} or die "Could not open that '$args{file}'";

4201

$impl->{in_filter} = $args{in} || \&_no_filter,

4202

$impl->{out_filter} = $args{out} || \&_no_filter,

4203

}

4204

4205

sub SEEK {

4206

my ($impl, $position, $whence) = @_;

4207

return sysseek($impl->{handle}, $position, $whence);

4208

}

4209

4210

sub WRITE {

4211

my ($impl, $buffer, $length, $offset) = @_;

4212

$buffer = $impl->{out_filter}->($buffer);

4213

syswrite($impl->{handle}, $buffer, $length, $offset||0);

4214

}

4215

4216

sub PRINT {

4217

my ($impl, @data) = @_;

4218

my $filter = $impl->{out_filter};

4219

@data = map { $filter->($_) } @data;

4220

print { $impl->{handle} } @data;

4221

#$|=1;

4222

$impl->{handle}->autoflush();

4223

}

4224

4225

sub PRINTF {

4226

my ($impl, $format, @data) = @_;

4227

my $filter = $impl->{out_filter};

4228

print { $impl->{handle} } $filter->(sprintf $format, @data);

4229

#$impl->{handle}->autoflush();

4230

}

4231

4232

sub READ {

4233

my ($impl, $data, $length, $offset) = @_;

4234

my $result = sysread($impl->{handle}, $data, $length);

4235

substr($_[1],$offset||0,$length) = $impl->{in_filter}->($data);

4236

return $result;

4237

}

4238

4239

sub GETC {

4240

my ($impl) = @_;

4241

$impl->{in_filter}->(getc $impl->{handle});

4242

}

4243

4244

sub READLINE {

4245

my $impl = @_;

4246

$impl->{in_filter}->(scalar readline *{$impl->{handle}});

4247

}

4248

4249

sub CLOSE {

4250

my $impl = @_;

4251

close $impl->{handle};

4252

}

4253

4254

4255

sub new {

4256

my ($class, %args) = @_;

4257

my $self = gensym();

4258

tie *{$self}, $class, %args;

4259

bless $self, $class;

4260

}

4261

4262

sub AUTOLOAD {

4263

use vars qw( $AUTOLOAD ); # keep use strict

237

4264

my ($self, @args) = @_;

4265

return if $AUTOLOAD =~ /::DESTROY$/;

4266

$AUTOLOAD =~ s/.*:://;

4267

$AUTOLOAD =~ tr/a-z/A-Z/;

4268

tied(*{$self})->$AUTOLOAD(@args);

4269

}

4270

4271

4272

4273

}

4274

4275

4276

########################################################################################

4277

# Pooling, package DBI::BabyConnect::BabiesPool

4278

4279

# DBI::BabyConnect::BabiesPool

4280

# DBI::BabyConnect::BabiesPool::InitAndLoad

4281

# DBI::BabyConnect::BabiesPool::Free

4282

# DBI::BabyConnect::BabiesPool::ReconnectConnector

4283

# DBI::BabyConnect::BabiesPool::DupConnector

4284

# DBI::BabyConnect::BabiesPool::AddConnector

4285

# DBI::BabyConnect::BabiesPool::FreeConnector

4286

# DBI::BabyConnect::BabiesPool::StatConnector

4287

# DBI::BabyConnect::BabiesPool::ChildConnector

4288

# DBI::BabyConnect::BabiesPool::Stat

4289

4290

4291

__END__