WHERE $expr ORDERBY $order
1290
##
1291
## $expr = SQL Where condition (optional, defaults to no condition)
1292
## $fields = fields to select (optional, default to *)
1293
## $order = fields for sql order by or undef for no sorting (optional, defaults to no order)
1294
## $group = fields for sql group by or undef (optional, defaults to no grouping)
1295
## $append = append that string to the select statemtn for other options (optional)
1296
## \@bind_values = values which should be inserted for placeholders
1297
## \@bind_types = data types of bind_values
1298
##
1299
1300
sub SQLSelect ($;$$$$$$$)
1301
{
1302
0
0
0
my ($self, $expr, $fields, $order, $group, $append, $bind_values, $bind_types, $makesql, ) = @_ ;
1303
1304
0
my $sth ; # statement handle
1305
my $where ; # where or nothing
1306
0
my $orderby ; # order by or nothing
1307
0
my $groupby ; # group by or nothing
1308
0
my $rc ; #
1309
0
my $table ;
1310
1311
0
0
if (defined ($self->{'*StHdl'}))
1312
{
1313
0
$self->{'*StHdl'} -> finish () ;
1314
0
0
print LOG "DB: Call DBI finish (id=$self->{'*Id'}, Last = $self->{'*LastSQLStatement'})\n" if ($self->{'*Debug'} > 3) ;
1315
}
1316
0
undef $self->{'*StHdl'} ;
1317
0
$self->ReleaseRecords ;
1318
0
undef $self->{'*LastKey'} ;
1319
0
$self->{'*FetchStart'} = 0 ;
1320
0
$self->{'*StartRecordNo'} = 0 ;
1321
0
$self->{'*FetchMax'} = undef ;
1322
0
$self->{'*EOD'} = undef ;
1323
0
$self->{'*SelectFields'} = undef ;
1324
0
$self->{'*LastRecord'} = undef ;
1325
1326
0
0
$order ||= '' ;
1327
0
0
$expr ||= '' ;
1328
0
0
$group ||= '' ;
1329
0
0
$append ||= '' ;
1330
0
0
$orderby = $order?'ORDER BY':'' ;
1331
0
0
$groupby = $group?'GROUP BY':'' ;
1332
0
0
$where = $expr?'WHERE':'' ;
1333
0
0
$fields ||= '*';
1334
0
0
$table = $self->{'*TabJoin'} || $self->{'*Table'} ;
1335
1336
0
my $statement;
1337
0
0
if ($self->{'*Query'}) {
1338
0
$statement = $self->{'*Query'} . " " . $append;
1339
} else {
1340
0
$statement = "SELECT $fields FROM $table $where $expr $groupby $group $orderby $order $append" ;
1341
}
1342
1343
1344
1345
0
0
if ($self->{'*Debug'} > 1)
1346
{
1347
0
0
my $bv = $bind_values || [] ;
1348
0
0
my $bt = $bind_types || [] ;
1349
0
print LOG "DB: '$statement' bind_values=<@$bv> bind_types=<@$bt>\n" ;
1350
}
1351
1352
0
$self -> {'*LastSQLStatement'} = $statement ;
1353
1354
0
0
return $statement if $makesql;
1355
1356
0
$self->{'*Stats'}{'select'}++ ;
1357
1358
0
$sth = $self->{'*DBHdl'} -> prepare ($statement) ;
1359
1360
0
0
if (defined ($sth))
1361
{
1362
0
my @x ;
1363
0
my $ni = 0 ;
1364
1365
0
my $Numeric = $self->{'*NumericTypes'} ;
1366
0
local $^W = 0 ; # avoid warnings
1367
0
for (my $i = 0 ; $i < @$bind_values; $i++)
1368
{
1369
#print LOG "bind $i bv=<$bind_values->[$i]> bvcnv=" . ($Numeric -> {$bind_types -> [$i]}?$bind_values -> [$i]+0:$bind_values -> [$i]) . " bt=$bind_types->[$i] n=$Numeric->{$bind_types->[$i]}\n" ;
1370
0
0
0
$bind_values -> [$i] += 0 if (defined ($bind_values -> [$i]) && defined ($bind_types -> [$i]) && $Numeric -> {$bind_types -> [$i]}) ;
0
1371
#my $bti = $bind_types -> [$i]+0 ;
1372
#$sth -> bind_param ($i+1, $bind_values -> [$i], {TYPE => $bti}) ;
1373
#$sth -> bind_param ($i+1, $bind_values -> [$i], $bind_types -> [$i] == DBI::SQL_CHAR()?DBI::SQL_CHAR():undef) ;
1374
0
my $bt = $bind_types -> [$i] ;
1375
0
0
0
$sth -> bind_param ($i+1, $bind_values -> [$i], (defined ($bt) && $bt <= DBI::SQL_CHAR())?{TYPE => $bt}:undef ) ;
1376
}
1377
0
$rc = $sth -> execute ;
1378
0
$self->{'*SelectedRows'} = $sth->rows;
1379
}
1380
1381
0
$LastErr = $self->{'*LastErr'} = $DBI::err ;
1382
0
$LastErrstr = $self->{'*LastErrstr'} = $DBI::errstr ;
1383
1384
0
my $names ;
1385
0
0
if ($rc)
1386
{
1387
0
0
$names = $sth -> FETCH (($PreserveCase?'NAME':'NAME_lc')) ;
1388
0
$self->{'*NumFields'} = $#{$names} + 1 ;
0
1389
}
1390
else
1391
{
1392
0
0
print LOG "DB: ERROR $DBI::errstr\n" if ($self->{'*Debug'}) ;
1393
0
0
print LOG "DB: in '$statement' bind_values=<@$bind_values> bind_types=<@$bind_types>\n" if ($self->{'*Debug'} == 1) ;
1394
1395
0
$self->{'*NumFields'} = 0 ;
1396
1397
0
undef $sth ;
1398
}
1399
1400
0
$self->{'*CurrRow'} = 0 ;
1401
0
$self->{'*LastRow'} = 0 ;
1402
0
$self->{'*StHdl'} = $sth ;
1403
1404
0
my @ofunca ;
1405
0
my $ofunc = $self -> {'*OutputFunctions'} ;
1406
1407
0
0
0
if ($ofunc && $names)
1408
{
1409
0
my $i = 0 ;
1410
1411
0
foreach (@$names)
1412
{
1413
0
$ofunca [$i++] = $ofunc -> {$_} ;
1414
}
1415
}
1416
1417
0
$self -> {'*OutputFuncArray'} = \@ofunca ;
1418
1419
1420
1421
0
0
if ($self->{'*LongNames'})
1422
{
1423
0
0
if ($fields eq '*')
1424
{
1425
0
$self->{'*SelectFields'} = $self->{'*FullNames'} ;
1426
}
1427
else
1428
{
1429
0
my $tab4f = $self -> {'*Table4Field'} ;
1430
#my @allfields = map { (/\./)?$_:"$tab4f->{$_}.$_" } split (/\s*,\s*/, $fields) ;
1431
0
0
my @allfields = map { (/\./)?$_:"$tab4f->{$_}.$_" } quotewords ('\s*,\s*', 0, $fields) ;
0
1432
0
0
shift @allfields if (lc($allfields[0]) eq 'distinct') ;
1433
0
$self->{'*SelectFields'} = \@allfields ;
1434
}
1435
}
1436
else
1437
{
1438
0
$self->{'*SelectFields'} = $names ;
1439
}
1440
1441
1442
0
return $rc ;
1443
}
1444
1445
## ----------------------------------------------------------------------------
1446
##
1447
## FECTHSIZE - returns the number of rows form the last SQLSelect
1448
##
1449
## WARNING: Not all DBD drivers returns the correct number of rows
1450
## so we issue a warning/error message when this function is used
1451
##
1452
1453
1454
1455
sub FETCHSIZE
1456
1457
{
1458
0
0
my ($self) = @_;
1459
1460
0
0
die "FETCHSIZE may not supported by your DBD driver, set \$FetchsizeWarn to zero if you are sure it works. Read about \$FetchsizeWarn in the docs!" if ($FetchsizeWarn == 2) ;
1461
0
0
warn "FETCHSIZE may not supported by your DBD driver, set \$FetchsizeWarn to zero if you are sure it works. Read about \$FetchsizeWarn in the docs!" if ($FetchsizeWarn == 1) ;
1462
1463
0
my $sel = $self->{'*SelectedRows'} ;
1464
0
0
return $sel if (!defined ($self->{'*FetchMax'})) ;
1465
1466
0
my $max = $self->{'*FetchMax'} - $self->{'*FetchStart'} + 1 ;
1467
0
0
return $max<$sel?$max:$sel ;
1468
}
1469
1470
1471
## ----------------------------------------------------------------------------
1472
##
1473
## Fetch the data from a previous SQL Select
1474
##
1475
## $fetch = Row to fetch
1476
##
1477
## fetchs the nth row and return a ref to an hash containing the entire row data
1478
##
1479
1480
1481
sub FETCH
1482
{
1483
0
0
my ($self, $fetch) = @_ ;
1484
1485
0
0
print LOG "DB: FETCH \[$fetch\]\n" if ($self->{'*Debug'} > 3) ;
1486
1487
0
$fetch += $self->{'*FetchStart'} ;
1488
1489
0
0
0
return $self->{'*LastRecord'} if (defined ($self->{'*LastRecordFetch'}) && $fetch == $self->{'*LastRecordFetch'} && $self->{'*LastRecord'}) ;
0
1490
1491
0
my $max ;
1492
my $key ;
1493
0
my $dat ; # row data
1494
1495
1496
0
$max = $self->{'*FetchMax'} ;
1497
1498
0
my $row = $self->{'*CurrRow'} ; # row next to fetch from db
1499
0
my $sth = $self->{'*StHdl'} ; # statement handle
1500
0
my $data = $Data{$self->{'*Id'}} ; # data storage (Data is stored in a seperate hash to avoid circular references)
1501
1502
0
0
0
if ($row <= $fetch && !$self->{'*EOD'} && defined ($sth))
0
1503
{
1504
1505
# successfull select has happend before ?
1506
0
0
return undef if (!defined ($sth)) ;
1507
0
0
0
return undef if (defined ($max) && $row > $max) ;
1508
1509
0
my $fld = $self->{'*SelectFields'} ;
1510
0
my $arr ;
1511
my $i ;
1512
1513
0
0
if ($self -> {'*StoreAll'})
1514
{
1515
0
while ($row < $fetch)
1516
{
1517
0
0
if (!($arr = $sth -> fetchrow_arrayref ()))
1518
{
1519
0
$self->{'*EOD'} = 1 ;
1520
0
$sth -> finish ;
1521
0
0
print LOG "DB: Call DBI finish (id=$self->{'*Id'}, LastRow = $row, Last = $self->{'*LastSQLStatement'})\n" if ($self->{'*Debug'} > 3) ;
1522
0
undef $self->{'*StHdl'} ;
1523
0
last ;
1524
}
1525
1526
0
$i = 0 ;
1527
0
$data->[$row] = [ @$arr ] ;
1528
0
$row++ ;
1529
1530
0
0
0
last if (defined ($max) && $row > $max) ;
1531
}
1532
}
1533
else
1534
{
1535
0
while ($row < $fetch)
1536
{
1537
0
0
if (!$sth -> fetchrow_arrayref ())
1538
{
1539
0
$self->{'*EOD'} = 1 ;
1540
0
$sth -> finish ;
1541
0
0
print LOG "DB: Call DBI finish (id=$self->{'*Id'}, Last = $self->{'*LastSQLStatement'})\n" if ($self->{'*Debug'} > 3) ;
1542
0
undef $self->{'*StHdl'} ;
1543
0
last ;
1544
}
1545
0
$row++ ;
1546
0
0
0
last if (defined ($max) && $row > $max) ;
1547
}
1548
}
1549
1550
1551
0
$self->{'*LastRow'} = $row ;
1552
0
0
0
if ($row == $fetch && !$self->{'*EOD'})
1553
{
1554
1555
0
$arr = $sth -> fetchrow_arrayref () ;
1556
1557
0
0
if ($arr)
1558
{
1559
0
$row++ ;
1560
0
$dat = {} ;
1561
0
0
if ($self -> {'*TieRow'})
1562
{
1563
0
my $obj = tie %$dat, 'DBIx::Recordset::Row', $self, $fld, $arr ;
1564
0
$self->{'*LastKey'} = $obj -> FETCH ($self -> {'*PrimKey'}) ;
1565
}
1566
else
1567
{
1568
0
@$dat{@$fld} = @$arr ;
1569
1570
1571
0
0
my $nf = $self -> {'*NameField'} || $self -> TableAttr ('!NameField') ;
1572
0
0
if ($nf)
1573
{
1574
0
0
if (!ref $nf)
1575
{
1576
0
0
$dat -> {'!Name'} = $dat -> {uc($nf)} || $dat -> {$nf} ;
1577
}
1578
else
1579
{
1580
0
0
$dat -> {'!Name'} = join (' ', map { $dat -> {uc ($_)} || $dat -> {$_} } @$nf) ;
0
1581
}
1582
}
1583
1584
0
0
$self->{'*LastKey'} = $dat -> {$self -> {'*PrimKey'}} if ($self -> {'*PrimKey'}) ;
1585
}
1586
1587
0
$data -> [$fetch] = $dat ;
1588
}
1589
else
1590
{
1591
0
$dat = $data -> [$fetch] = undef ;
1592
#print LOG "new dat undef\n" ;
1593
0
$self->{'*EOD'} = 1 ;
1594
0
$sth -> finish ;
1595
0
0
print LOG "DB: Call DBI finish (id=$self->{'*Id'}, Last = $self->{'*LastSQLStatement'})\n" if ($self->{'*Debug'} > 3) ;
1596
0
undef $self->{'*StHdl'} ;
1597
}
1598
}
1599
0
$self->{'*CurrRow'} = $row ;
1600
}
1601
else
1602
{
1603
0
my $obj ;
1604
1605
0
0
0
$dat = $data -> [$fetch] if (!defined ($max) || $fetch <= $max);
1606
0
0
if (ref $dat eq 'ARRAY')
1607
{ # just an Array so tie it now
1608
0
my $arr = $dat ;
1609
0
$dat = {} ;
1610
0
$obj = tie %$dat, 'DBIx::Recordset::Row', $self, $self->{'*SelectFields'} , $arr ;
1611
0
$data -> [$fetch] = $dat ;
1612
0
$self->{'*LastRow'} = $fetch ;
1613
0
$self->{'*LastKey'} = $obj -> FETCH ($self -> {'*PrimKey'}) ;
1614
}
1615
else
1616
{
1617
#my $v ;
1618
#my $k ;
1619
#print LOG "old dat\n" ; # = $dat ref = " . ref ($dat) . " tied = " . ref (tied(%$dat)) . " fetch = $fetch\n" ;
1620
#while (($k, $v) = each (%$dat))
1621
# {
1622
# print "$k = $v\n" ;
1623
# }
1624
1625
1626
0
0
my $obj = tied(%$dat) if ($dat) ;
1627
0
$self->{'*LastRow'} = $fetch ;
1628
0
0
$self->{'*LastKey'} = $obj?($obj -> FETCH ($self -> {'*PrimKey'})):undef ;
1629
}
1630
}
1631
1632
1633
0
0
0
if ($row == $fetch + 1 && !$self->{'*EOD'})
1634
{
1635
# check if there are more records, if not close the statement handle
1636
0
my $arr ;
1637
1638
0
0
$arr = $sth -> fetchrow_arrayref () if ($sth) ;
1639
0
my $orgrow = $row ;
1640
1641
0
0
if ($arr)
1642
{
1643
0
$data->[$row] = [ @$arr ] ;
1644
0
$row++ ;
1645
0
$self->{'*CurrRow'} = $row ;
1646
}
1647
0
0
0
if ((defined ($max) && $orgrow > $max) || !$arr)
0
1648
{
1649
0
$self->{'*EOD'} = 1 ;
1650
0
0
$sth -> finish if ($sth) ;
1651
0
0
print LOG "DB: Call DBI finish (id=$self->{'*Id'}, LastRow = $row, Last = $self->{'*LastSQLStatement'})\n" if ($self->{'*Debug'} > 3) ;
1652
0
undef $self->{'*StHdl'} ;
1653
}
1654
}
1655
1656
0
$self->{'*LastRecord'} = $dat ;
1657
0
$self->{'*LastRecordFetch'} = $fetch ;
1658
1659
0
0
print LOG 'DB: FETCH return ' . (defined ($dat)?$dat:'') . "\n" if ($self->{'*Debug'} > 3) ;
0
1660
0
return $dat ;
1661
}
1662
1663
1664
## ----------------------------------------------------------------------------
1665
##
1666
## Reset ...
1667
##
1668
## position the record pointer before the first row, just as same as after Search
1669
##
1670
1671
sub Reset ($)
1672
{
1673
0
0
1
my $self = shift ;
1674
1675
0
$self->{'*LastRecord'} = undef ;
1676
0
$self ->{'*LastRow'} = 0 ;
1677
}
1678
1679
## ----------------------------------------------------------------------------
1680
##
1681
## First ...
1682
##
1683
## position the record pointer to the first row and return it
1684
##
1685
1686
sub First ($;$)
1687
1688
{
1689
0
0
1
my ($self, $new) = @_ ;
1690
0
my $rec = $self -> FETCH (0) ;
1691
0
0
0
return $rec if (defined ($rec) || !$new) ;
1692
# create new record
1693
0
return $self -> {'*LastRecord'} = $self -> STORE (0) ;
1694
}
1695
1696
1697
## ----------------------------------------------------------------------------
1698
##
1699
## Last ...
1700
##
1701
## position the record pointer to the last row
1702
## DOES NOT WORK!!
1703
##
1704
##
1705
1706
sub Last ($)
1707
{
1708
0
0
0
$_[0] -> FETCH (0x7fffffff) ; # maxmimun postiv integer
1709
0
0
return undef if ($_[0] -> {'*LastRow'} == 0) ;
1710
0
return $_[0] -> Prev ;
1711
}
1712
1713
1714
## ----------------------------------------------------------------------------
1715
##
1716
## Next ...
1717
##
1718
## position the record pointer to the next row and return it
1719
##
1720
1721
sub Next ($;$)
1722
{
1723
0
0
1
my ($self, $new) = @_ ;
1724
0
my $lr = $self -> {'*LastRow'} ;
1725
1726
0
$lr -= $self -> {'*FetchStart'} ;
1727
0
0
$lr = 0 if ($lr < 0) ;
1728
0
0
$lr++ if (defined ($self -> {'*LastRecord'})) ;
1729
1730
##$lr++ if ($_[0] ->{'*CurrRow'} > 0 || $_[0] ->{'*EOD'}) ;
1731
0
my $rec = $self -> FETCH ($lr) ;
1732
0
0
0
return $rec if (defined ($rec) || !$new) ;
1733
1734
# create new record
1735
0
return $self -> {'*LastRecord'} = $self -> STORE ($lr) ;
1736
}
1737
1738
1739
## ----------------------------------------------------------------------------
1740
##
1741
## Prev ...
1742
##
1743
## position the record pointer to the previous row and return it
1744
##
1745
1746
sub Prev ($)
1747
{
1748
0
0
0
1
$_[0] -> {'*LastRow'} = 0 if (($_[0] -> {'*LastRow'})-- == 0) ;
1749
0
return $_[0] -> FETCH ($_[0] ->{'*LastRow'} - $_[0] -> {'*FetchStart'}) ;
1750
}
1751
1752
1753
## ----------------------------------------------------------------------------
1754
##
1755
## Fetch the data from current row
1756
##
1757
1758
1759
sub Curr ($;$)
1760
{
1761
0
0
1
my ($self, $new) = @_ ;
1762
1763
0
my $lr ;
1764
0
0
return $lr if ($lr = $self->{'*LastRecord'}) ;
1765
1766
0
my $n = $self ->{'*LastRow'} - $self -> {'*FetchStart'} ;
1767
0
my $rec = $self -> FETCH ($n) ;
1768
0
0
0
return $rec if (defined ($rec) || !$new) ;
1769
1770
# create new record
1771
0
return $self -> STORE ($n) ;
1772
}
1773
1774
## ----------------------------------------------------------------------------
1775
##
1776
## BuildFields ...
1777
##
1778
1779
sub BuildFields
1780
1781
{
1782
0
0
0
my ($self, $fields, $table, $tabrel) = @_ ;
1783
1784
1785
0
my @fields ;
1786
0
my $tab4f = $self -> {'*Table4Field'} ;
1787
0
my $fnames = $self -> {'*FullNames'} ;
1788
0
my $debug = $self -> {'*Debug'} ;
1789
0
my $drv = $self->{'*Driver'} ;
1790
0
my %tables ;
1791
my %fields ;
1792
0
my %tabrel ;
1793
0
my @replace ;
1794
0
my $linkname ;
1795
0
my $link ;
1796
0
my $nf ;
1797
0
my $fn ;
1798
0
my @allfields ;
1799
0
my @orderedfields ;
1800
0
my $i ;
1801
0
my $n ;
1802
0
my $m ;
1803
0
my %namefields ;
1804
1805
0
my $leftjoin = DBIx::Compat::GetItem ($drv, 'SupportSQLJoin') ;
1806
0
my $numtabs = 99 ;
1807
1808
0
local $^W = 0 ;
1809
1810
0
0
$numtabs = 2 if (DBIx::Compat::GetItem ($drv, 'SQLJoinOnly2Tabs')) ;
1811
1812
1813
#%tables = map { $_ => 1 } split (/\s*,\s*/, $table) ;
1814
0
%tables = map { $_ => 1 } quotewords ('\s*,\s*', 0, $table) ;
0
1815
0
$numtabs -= keys %tables ;
1816
1817
#print LOG "###--> numtabs = $numtabs\n" ;
1818
0
0
0
if (defined ($fields) && !($fields =~ /^\s*\*\s*$/))
1819
{
1820
#@allfields = map { (/\./)?$_:"$tab4f->{$_}.$_" } split (/\s*,\s*/, $fields) ;
1821
# @allfields = map { (/\./)?$_:"$tab4f->{$_}.$_" } quotewords ('\s*,\s*', 0, $fields) ;
1822
0
0
0
@allfields = map { (/\./ || !$tab4f->{$_})?$_:"$tab4f->{$_}.$_" } quotewords ('\s*,\s*', 0, $fields) ;
0
1823
#print LOG "###allfields = @allfields\n" ;
1824
}
1825
else
1826
{
1827
0
@allfields = @$fnames ;
1828
}
1829
1830
0
0
$nf = $self -> {'*NameField'} || $self -> TableAttr ('!NameField') ;
1831
0
0
if ($nf)
1832
{
1833
0
0
if (ref ($nf) eq 'ARRAY')
1834
{
1835
0
%namefields = map { ($fn = "$tab4f->{$_}\.$_") => 1 } @$nf ;
0
1836
}
1837
else
1838
{
1839
0
%namefields = ( "$tab4f->{$nf}.$nf" => 1 ) ;
1840
}
1841
1842
0
@orderedfields = keys %namefields ;
1843
0
foreach $fn (@allfields)
1844
{
1845
0
0
push @orderedfields, $fn if (!$namefields{$fn}) ;
1846
}
1847
}
1848
else
1849
{
1850
0
@orderedfields = @allfields ;
1851
}
1852
1853
0
$i = 0 ;
1854
0
%fields = map { $_ => $i++ } @orderedfields ;
0
1855
1856
0
$n = $#orderedfields ;
1857
0
$m = $n + 1;
1858
0
for ($i = 0; $i <=$n; $i++)
1859
{
1860
#print LOG "###loop numtabs = $numtabs\n" ;
1861
0
$fn = $orderedfields[$i] ;
1862
0
$replace[$i] = [$i] ;
1863
0
0
next if ($numtabs <= 0) ;
1864
0
0
next if (!($linkname = $self -> Link4Field ($fn))) ;
1865
0
0
next if (!($link = $self -> Link ($linkname))) ;
1866
# does not work with another Datasource or with an link to the table itself
1867
0
0
0
next if ($link -> {'!DataSource'} || $link -> {'!Table'} eq $self -> {'!Table'}) ;
1868
1869
0
0
$nf = $link->{'!NameField'} || $self -> TableAttr ('!NameField', undef, $link->{'!Table'}) ;
1870
1871
0
0
0
if (!$link -> {'!LinkedBy'} && $nf)
0
0
1872
{
1873
0
$replace[$i] = [] ;
1874
0
0
if (ref $nf)
1875
{
1876
0
foreach (@$nf)
1877
{
1878
0
0
if (!exists $fields{"$link->{'!Table'}.$_"})
1879
{
1880
0
push @orderedfields, "$link->{'!Table'}.$_" ;
1881
0
push @allfields, "$link->{'!Table'}.$_" ;
1882
0
$fields{"$link->{'!Table'}.$_"} = $m ;
1883
0
push @{$replace[$i]}, $m ;
0
1884
1885
0
0
print LOG "[$$] DB: Add to $self->{'*Table'} linked name field $link->{'!Table'}.$_ (i=$i, n=$n, m=$m)\n" if ($debug > 2) ;
1886
0
$m++ ;
1887
}
1888
}
1889
}
1890
else
1891
{
1892
0
0
if (!exists $fields{"$link->{'!Table'}.$nf"})
1893
{
1894
0
push @orderedfields, "$link->{'!Table'}.$nf" ;
1895
0
push @allfields, "$link->{'!Table'}.$nf" ;
1896
0
$fields{"$link->{'!Table'}.$nf"} = $m ;
1897
0
push @{$replace[$i]}, $m ;
0
1898
1899
0
0
print LOG "[$$] DB: Add to $self->{'*Table'} linked name field $link->{'!Table'}.$nf (i=$i, n=$n, m=$m)\n" if ($debug > 2) ;
1900
0
$m++ ;
1901
}
1902
}
1903
1904
0
0
$numtabs-- if (!exists $tables{$link->{'!Table'}}) ;
1905
0
$tables{$link->{'!Table'}} = "$fn = $link->{'!Table'}.$link->{'!LinkedField'}" ;
1906
}
1907
elsif ($debug > 2 && !$link -> {'!LinkedBy'})
1908
0
{ print LOG "[$$] DB: No name, so do not add to $self->{'*Table'} linked name field $link->{'!Table'}.$fn\n" ;}
1909
}
1910
1911
#my $rfields = join (',', @allfields) ;
1912
0
my $rfields = join (',', @orderedfields) ;
1913
0
my $rtables = join (',', keys %tables) ;
1914
1915
0
delete $tables{$table} ;
1916
0
my $rtabrel ;
1917
1918
0
0
if ($leftjoin == 1)
0
0
0
1919
{
1920
0
my @tabs = keys %tables ;
1921
0
$rtabrel = ('(' x scalar(@tabs)) . $table . ' ' . join (' ', map { "LEFT JOIN $_ on $tables{$_})" } @tabs) ;
0
1922
}
1923
elsif ($leftjoin == 2)
1924
{
1925
0
my $v ;
1926
1927
0
0
$tabrel = ($tabrel?"$tabrel and ":'') . join (' and ', map { $v = $tables{$_} ; $v =~ s/=/*=/ ; $v } keys %tables) ;
0
0
0
1928
}
1929
elsif ($leftjoin == 3)
1930
{
1931
0
my $v ;
1932
1933
0
0
$tabrel = ($tabrel?"$tabrel and ":'') . join (' and ', map { "$tables{$_} (+)" } keys %tables) ;
0
1934
}
1935
elsif ($leftjoin == 4)
1936
{
1937
0
my @tabs = keys %tables ;
1938
0
$rtabrel = $table . ' ' . join ' ', map { "LEFT JOIN $_ on $tables{$_}" } @tabs ;
0
1939
}
1940
else
1941
{
1942
0
my $v ;
1943
1944
0
$rtabrel = $table . ',' . join (',', map { "OUTER $_ " } keys %tables) ;
0
1945
0
0
$tabrel = ($tabrel?"$tabrel and ":'') . join (' and ', values %tables) ;
1946
}
1947
1948
0
return ($rfields, $rtables, $rtabrel, $tabrel, \@replace) ;
1949
}
1950
1951
1952
## ----------------------------------------------------------------------------
1953
##
1954
## BuildWhere ...
1955
##
1956
## \%where/$where = hash of which the SQL Where condition is build
1957
## or SQL Where condition as text
1958
## \@bind_values = returns the bind_value array for placeholder supported
1959
## \@bind_types = returns the bind_type array for placeholder supported
1960
##
1961
##
1962
## Builds the WHERE condition for SELECT, UPDATE, DELETE
1963
## upon the data which is given in the hash \%where or string $where
1964
##
1965
## Key Value
1966
## Value for field (automatily quote if necessary)
1967
## ' Value for field (always quote)
1968
## # Value for field (never quote, convert to number)
1969
## \ Value for field (leave value as it is)
1970
## +|.. Value for fields (value must be in one/all fields
1971
## depending on $compconj
1972
## $compconj 'or' or 'and' (default is 'or')
1973
##
1974
## $valuesplit regex for spliting a field value in mulitply value
1975
## per default one of the values must match the field
1976
## could be changed via $valueconj
1977
## $valueconj 'or' or 'and' (default is 'or')
1978
##
1979
## $conj 'or' or 'and' (default is 'and') conjunction between
1980
## fields
1981
##
1982
## $operator Default operator
1983
## * Operator for the named field
1984
##
1985
## $primkey primary key
1986
##
1987
## $where where as string
1988
##
1989
1990
sub BuildWhere ($$$$)
1991
1992
{
1993
0
0
0
my ($self, $where, $xbind_values, $bind_types, $sub) = @_ ;
1994
1995
1996
0
my $expr = '' ;
1997
0
my $primkey ;
1998
0
my $Quote = $self->{'*Quote'} ;
1999
0
my $Debug = $self->{'*Debug'} ;
2000
0
my $ignore = $self->{'*IgnoreEmpty'} ;
2001
0
my $nullop = $self->{'*NullOperator'} ;
2002
0
my $hasIn = $self->{'*HasInOperator'} ;
2003
0
my $linkname = $self->{'*LinkName'} ;
2004
0
my $tab4f = $self->{'*Table4Field'} ;
2005
0
my $type4f = $self->{'*Type4Field'} ;
2006
0
my $ifunc = $self->{'*InputFunctions'} ;
2007
0
0
my $bind_values = ref ($xbind_values) eq 'ARRAY'?$xbind_values:$$xbind_values ;
2008
2009
0
0
0
if (!ref($where))
0
0
0
0
0
2010
{ # We have the where as string
2011
0
$expr = $where ;
2012
0
0
if ($Debug > 2) { print LOG "DB: Literal where -> $expr\n" ; }
0
2013
}
2014
elsif (exists $where -> {'$where'})
2015
{ # We have the where as string
2016
0
$expr = $where -> {'$where'} ;
2017
0
0
if (exists $where -> {'$values'})
2018
{
2019
0
0
if (ref ($xbind_values) eq 'ARRAY')
2020
{
2021
0
push @$xbind_values, @{$where -> {'$values'}} ;
0
2022
}
2023
else
2024
{
2025
0
$$xbind_values = $where -> {'$values'} ;
2026
}
2027
}
2028
0
0
if ($Debug > 2) { print LOG "DB: Literal where -> $expr\n" ; }
0
2029
}
2030
elsif (defined ($primkey = $self->{'*PrimKey'}) && defined ($where -> {$primkey}) &&
2031
(!defined ($where -> {"\*$primkey"}) || $where -> {"\*$primkey"} eq '=') &&
2032
!ref ($where -> {$primkey}))
2033
{ # simplify where when ask for = ?
2034
0
0
my $oper = $$where{"\*$primkey"} || '=' ;
2035
2036
0
my $pkey = $primkey ;
2037
0
0
0
$pkey = "$tab4f->{$primkey}.$primkey" if ($linkname && !($primkey =~ /\./)) ;
2038
2039
# any input conversion ?
2040
0
my $val = $where -> {$primkey} ;
2041
0
my $if = $ifunc -> {$primkey} ;
2042
0
0
$val = &{$if} ($val) if ($if) ;
0
2043
2044
0
$expr = "$pkey$oper ? "; push @$bind_values, $val ; push @$bind_types, $type4f -> {$primkey} ;
0
0
2045
0
0
if ($Debug > 2) { print LOG "DB: Primary Key $primkey found -> $expr\n" ; }
0
2046
}
2047
else
2048
{
2049
0
my $key ;
2050
my $lkey ;
2051
0
my $val ;
2052
2053
0
my @mvals ;
2054
2055
0
my $field ;
2056
0
my @fields ;
2057
2058
0
my $econj ;
2059
0
my $vconj ;
2060
0
my $fconj ;
2061
2062
0
my $vexp ;
2063
0
my $fieldexp ;
2064
2065
0
my $type ;
2066
0
0
my $oper = $$where{'$operator'} || '=' ;
2067
0
my $op ;
2068
2069
0
0
my $mvalsplit = $$where{'$valuesplit'} || "\t" ;
2070
2071
0
my $lexpr = '' ;
2072
0
my $multcnt ;
2073
my $uright ;
2074
2075
0
$econj = '' ;
2076
2077
2078
0
while (($key, $val) = each (%$where))
2079
{
2080
0
my @multtypes ;
2081
my @multval ;
2082
0
my $if ;
2083
2084
0
0
$type = substr ($key, 0, 1) || ' ' ;
2085
0
0
0
$val = undef if ($ignore > 1 && defined ($val) && $val eq '') ;
0
2086
2087
0
0
if ($Debug > 2) { print LOG "DB: SelectWhere <$key>=<" . (defined ($val)?$val:'') ."> type = $type\n" ; }
0
0
2088
2089
0
$vexp = '' ;
2090
0
0
if (substr ($key, 0, 5) eq '$expr')
2091
{
2092
0
0
$vexp = $self -> BuildWhere ($val, $bind_values, $bind_types, 1) if ($val) ;
2093
}
2094
else
2095
{
2096
0
0
0
if (($type =~ /^(\w|\\|\+|\'|\#|\s)$/) && !($ignore && !defined ($val)))
0
2097
{
2098
0
0
if ($type eq '+')
2099
{ # composite field
2100
2101
0
0
if ($Debug > 3) { print LOG "DB: Composite Field $key\n" ; }
0
2102
2103
0
$fconj = '' ;
2104
0
$fieldexp = '' ;
2105
0
@fields = split (/\&|\|/, substr ($key, 1)) ;
2106
2107
0
$multcnt = 0 ;
2108
0
foreach $field (@fields)
2109
{
2110
0
0
if ($Debug > 3) { print LOG "DB: Composite Field processing $field\n" ; }
0
2111
2112
0
0
if (!defined ($$Quote{$PreserveCase?$field:lc ($field)}))
0
2113
{
2114
0
0
if ($Debug > 2) { print LOG "DB: Ignore non existing Composite Field $field\n" ; }
0
2115
0
next ;
2116
} # ignore no existent field
2117
2118
0
0
$op = $$where{"*$field"} || $oper ;
2119
2120
0
0
0
$field = "$tab4f->{$field}.$field" if ($linkname && !($field =~ /\./)) ;
2121
2122
0
0
if (($uright = $unaryoperators{lc($op)}))
0
0
0
2123
{
2124
0
0
if ($uright == 1)
2125
0
{ $fieldexp = "$fieldexp $fconj $field $op" }
2126
else
2127
0
{ $fieldexp = "$fieldexp $fconj $op $field" }
2128
}
2129
elsif ($type eq '\\')
2130
0
{ $fieldexp = "$fieldexp $fconj $field $op $val" ; }
2131
elsif (defined ($val))
2132
{
2133
0
$fieldexp = "$fieldexp $fconj $field $op ?" ;
2134
0
push @multtypes, $type4f -> {$field} ;
2135
0
$multcnt++ ;
2136
}
2137
elsif ($op eq '<>')
2138
0
{ $fieldexp = "$fieldexp $fconj $field $nullop not NULL" ; }
2139
else
2140
0
{ $fieldexp = "$fieldexp $fconj $field $nullop NULL" ; }
2141
2142
2143
0
0
$fconj ||= $$where{'$compconj'} || ' or ' ;
0
2144
2145
0
0
if ($Debug > 3) { print LOG "DB: Composite Field get $fieldexp\n" ; }
0
2146
2147
}
2148
0
0
if ($fieldexp eq '')
2149
0
{ next ; } # ignore no existent field
2150
2151
}
2152
else
2153
{ # single field
2154
0
$multcnt = 0 ;
2155
# any input conversion ?
2156
0
0
$if = $ifunc -> {$PreserveCase?$key:lc ($key)} ;
2157
## see bvelow ## $val = &{$if} ($val) if ($if && !ref($val)) ;
2158
2159
0
0
0
if ($type eq '\\' || $type eq '#' || $type eq "'")
0
2160
{ # remove leading backslash, # or '
2161
0
$key = substr ($key, 1) ;
2162
}
2163
2164
0
0
$lkey = $PreserveCase?$key:lc ($key) ;
2165
2166
2167
0
0
if ($type eq "'")
0
2168
{
2169
0
$$Quote{$lkey} = 1 ;
2170
}
2171
elsif ($type eq '#')
2172
{
2173
0
$$Quote{$lkey} = 0 ;
2174
}
2175
2176
2177
{
2178
0
local $^W = 0 ; # avoid warnings
0
2179
2180
#$val += 0 if ($$Quote{$lkey}) ; # convert value to a number if necessary
2181
}
2182
2183
0
0
0
if (!defined ($$Quote{$lkey}) && $type ne '\\')
2184
{
2185
0
0
if ($Debug > 3) { print LOG "DB: Ignore Single Field $key\n" ; }
0
2186
0
next ; # ignore no existent field
2187
}
2188
2189
0
0
if ($Debug > 3) { print LOG "DB: Single Field $key\n" ; }
0
2190
2191
0
0
$op = $$where{"*$key"} || $oper ;
2192
2193
0
0
0
$key = "$tab4f->{$lkey}.$key" if ($linkname && $type ne '\\' && !($key =~ /\./)) ;
0
2194
2195
0
0
if (($uright = $unaryoperators{lc($op)}))
0
0
0
2196
{
2197
0
0
if ($uright == 1)
2198
0
{ $fieldexp = "$key $op" }
2199
else
2200
0
{ $fieldexp = "$op $key" }
2201
}
2202
elsif ($type eq '\\')
2203
0
{ $fieldexp = "$key $op $val" ; }
2204
elsif (defined ($val))
2205
{
2206
0
$fieldexp = "$key $op ?" ;
2207
0
push @multtypes, $type4f -> {$lkey} ;
2208
0
$multcnt++ ;
2209
}
2210
elsif ($op eq '<>')
2211
0
{ $fieldexp = "$key $nullop not NULL" ; }
2212
else
2213
0
{ $fieldexp = "$key $nullop NULL" ; }
2214
2215
2216
0
0
if ($Debug > 3) { print LOG "DB: Single Field gives $fieldexp\n" ; }
0
2217
}
2218
2219
0
my @multop ;
2220
0
0
@multop = @$op if (ref ($op) eq 'ARRAY') ;
2221
2222
2223
0
0
if (!defined ($val))
0
2224
0
{ @mvals = (undef) }
2225
elsif ($val eq '')
2226
0
{ @mvals = ('') }
2227
else
2228
{
2229
0
0
if (ref ($val) eq 'ARRAY')
2230
{
2231
0
0
if ($if)
2232
0
{ @mvals = map { &{$if} ($_) } @$val }
0
0
2233
else
2234
0
{ @mvals = @$val ; }
2235
}
2236
else
2237
{
2238
0
0
if ($if)
2239
0
{ @mvals = map { &{$if} ($_) } split (/$mvalsplit/, $val) ; }
0
0
2240
else
2241
0
{ @mvals = split (/$mvalsplit/, $val) ; }
2242
}
2243
}
2244
0
$vconj = '' ;
2245
0
my $i ;
2246
2247
0
0
0
if ($hasIn && @mvals > 1 && !@multop && $op eq '=' && !$$where{'$valueconj'} && $type ne '+')
0
0
0
0
2248
{
2249
0
my $j = 0 ;
2250
0
$vexp = "$key IN (" ;
2251
0
foreach $val (@mvals)
2252
{
2253
0
$i = $multcnt ;
2254
0
push @$bind_values, $val while ($i-- > 0) ;
2255
0
push @$bind_types, @multtypes ;
2256
0
0
$vexp .= $j++?',?':'?' ;
2257
}
2258
0
$vexp .= ')' ;
2259
}
2260
else
2261
{
2262
0
foreach $val (@mvals)
2263
{
2264
0
$i = $multcnt ;
2265
0
push @$bind_values, $val while ($i-- > 0) ;
2266
0
push @$bind_types, @multtypes ;
2267
0
0
if (@multop)
2268
0
{ $vexp = "$vexp $vconj ($key " . (shift @multop) . ' ?)' ; }
2269
else
2270
0
{ $vexp = "$vexp $vconj ($fieldexp)" ; }
2271
0
0
$vconj ||= $$where{'$valueconj'} || ' or ' ;
0
2272
}
2273
2274
}
2275
}
2276
}
2277
2278
0
0
if ($vexp)
2279
{
2280
0
0
if ($Debug > 3) { local $^W = 0 ; print LOG "DB: Key $key gives $vexp bind_values = <@$bind_values> bind_types=<@$bind_types>\n" ; }
0
0
2281
2282
0
$expr = "$expr $econj ($vexp)" ;
2283
2284
0
0
$econj ||= $$where{'$conj'} || ' and ' ;
0
2285
}
2286
2287
0
0
0
if ($Debug > 3 && $lexpr ne $expr) { $lexpr = $expr ; print LOG "DB: expr is $expr\n" ; }
0
0
2288
}
2289
}
2290
2291
2292
# Now we add the Table relations, if any
2293
2294
0
my $tabrel = $self->{'*TabRelation'} ;
2295
2296
0
0
0
if ($tabrel && !$sub)
2297
{
2298
0
0
if ($expr)
2299
{
2300
0
$expr = "($tabrel) and ($expr)" ;
2301
}
2302
else
2303
{
2304
0
$expr = $tabrel ;
2305
}
2306
}
2307
2308
0
return $expr ;
2309
}
2310
2311
2312
## ----------------------------------------------------------------------------
2313
##
2314
## Dirty - see if there is at least one dirty row
2315
##
2316
##
2317
2318
sub Dirty
2319
{
2320
0
0
1
my $self = shift;
2321
0
my $data = $Data{ $self->{'*Id'} };
2322
2323
0
0
return undef unless ( ref($data) eq 'ARRAY');
2324
2325
0
foreach my $rowdata (@$data)
2326
{
2327
0
0
print LOG "DIRTY: rowref " . (defined ($rowdata)?$rowdata:'') . "\n" if $self->{'*Debug'} > 4;
0
2328
next unless ((ref($rowdata) eq 'HASH')
2329
0
0
0
and eval { tied(%$rowdata)->isa('DBIx::Recordset::Row') } );
0
2330
0
0
return 1 if tied(%$rowdata)->Dirty ;
2331
};
2332
0
return 0; # clean
2333
}
2334
2335
2336
## ----------------------------------------------------------------------------
2337
##
2338
## Fush ...
2339
##
2340
## Write all dirty rows to the database
2341
##
2342
2343
sub Flush
2344
2345
{
2346
0
0
1
my $self = shift ;
2347
2348
0
0
return if ($self -> {'*InFlush'}) ; # avoid endless recursion
2349
2350
0
my $release = shift ;
2351
0
my $dat ;
2352
my $obj ;
2353
0
my $dbg = $self->{'*Debug'} ;
2354
0
my $id = $self->{'*Id'} ;
2355
0
my $data = $Data{$id} ;
2356
0
my $rc = 1 ;
2357
2358
0
0
print LOG "DB: FLUSH Recordset id = $id $self \n" if ($dbg > 2) ;
2359
2360
0
$self -> {'*InFlush'} = 1 ;
2361
0
$self -> {'*UndefKey'} = undef ; # invalidate record for undef hashkey
2362
0
$self->{'*LastRecord'} = undef ;
2363
0
$self->{'*LastRecordFetch'} = undef ;
2364
0
0
if (defined ($self->{'*StHdl'}))
2365
{
2366
0
$self->{'*StHdl'} -> finish () ;
2367
0
0
print LOG "DB: Call DBI finish (id=$self->{'*Id'}, Last = $self->{'*LastSQLStatement'})\n" if ($self->{'*Debug'} > 3) ;
2368
0
undef $self->{'*StHdl'} ;
2369
}
2370
2371
2372
eval
2373
0
{
2374
0
my $err ;
2375
2376
0
foreach $dat (@$data)
2377
{
2378
0
0
$obj = (ref ($dat) eq 'HASH')?tied (%$dat):undef ;
2379
0
0
if (defined ($obj))
2380
{
2381
# isolate row update errors
2382
eval
2383
0
0
{
2384
0
local $SIG{__DIE__};
2385
0
$obj -> Flush ();
2386
} or $rc = undef ;
2387
2388
0
0
$err ||= $@ ;
2389
0
0
$obj -> {'*Recordset'} = undef if ($release) ;
2390
}
2391
}
2392
0
0
die $err if ($err) ;
2393
} ;
2394
2395
0
$self -> {'*InFlush'} = 0 ;
2396
2397
0
0
$self -> savecroak ($@) if ($@) ;
2398
2399
0
return $rc ;
2400
}
2401
2402
2403
2404
2405
## ----------------------------------------------------------------------------
2406
##
2407
## Insert ...
2408
##
2409
## \%data = hash of fields for new record
2410
##
2411
2412
sub Insert ($\%)
2413
2414
{
2415
0
0
1
my ($self, $data) = @_ ;
2416
2417
0
local *newself ;
2418
0
0
if (!ref ($self))
2419
{
2420
0
*newself = Setup ($self, $data) ;
2421
0
0
($self = $newself) or return undef ;
2422
}
2423
2424
0
my @bind_values ;
2425
my @bind_types ;
2426
0
my @qvals ;
2427
0
my @keys ;
2428
0
my $key ;
2429
0
my $val ;
2430
0
my $q ;
2431
2432
0
my $type4f = $self->{'*Type4Field'} ;
2433
0
my $Quote = $self->{'*Quote'} ;
2434
0
my $ifunc = $self->{'*InputFunctions'} ;
2435
0
my $irfunc = $self->{'*InputFunctionsRequiredOnInsert'} ;
2436
0
my $insertserial ;
2437
2438
0
0
if ($self -> {'*GetSerialPreInsert'})
0
2439
{
2440
0
my $val = $data -> {$self -> {'*Serial'}} ;
2441
0
0
$val = $$val if (ref ($val) eq 'SCALAR') ;
2442
0
0
if (!defined ($val))
2443
{
2444
0
$data -> {$self -> {'*Serial'}} = &{$self -> {'*GetSerialPreInsert'}} ($self -> {'*DBHdl'},
0
2445
$self -> {'*Table'},
2446
$self -> {'*Sequence'}) ;
2447
0
$insertserial = $self -> {'*Serial'} ;
2448
}
2449
0
$self -> {'*LastSerial'} = $data -> {$self -> {'*Serial'}} ;
2450
}
2451
elsif ($self -> {'*SeqObj'})
2452
{
2453
0
my $val = $data -> {$self -> {'*Serial'}} ;
2454
0
0
$val = $$val if (ref ($val) eq 'SCALAR') ;
2455
0
0
if (!defined ($val))
2456
{
2457
0
$data -> {$self -> {'*Serial'}} = $self -> {'*SeqObj'} -> NextVal ($self -> {'*Sequence'}) ;
2458
0
$insertserial = $self -> {'*Serial'} ;
2459
}
2460
0
$self -> {'*LastSerial'} = $data -> {$self -> {'*Serial'}} ;
2461
}
2462
2463
2464
0
while (($key, $val) = each (%$data))
2465
{
2466
0
0
$val = $$val if (ref ($val) eq 'SCALAR') ;
2467
# any input conversion ?
2468
0
my $if = $ifunc -> {$key} ;
2469
0
0
$val = &{$if} ($val, 'insert', $data) if ($if) ;
0
2470
0
0
next if (!defined ($val)) ; # skip NULL values
2471
0
0
if ($key =~ /^\\(.*?)$/)
0
0
2472
{
2473
0
push @qvals, $val ;
2474
0
push @keys, $1 ;
2475
}
2476
elsif (defined ($$Quote{$PreserveCase?$key:lc ($key)}))
2477
{
2478
0
push @bind_values ,$val ;
2479
0
push @qvals, '?' ;
2480
0
push @keys, $key ;
2481
0
0
push @bind_types, $type4f -> {$PreserveCase?$key:lc ($key)} ;
2482
}
2483
}
2484
2485
0
0
0
if (@qvals == 1 && $insertserial && exists ($data -> {$insertserial}))
0
2486
{ # if the serial is the only value remove if and make no insert
2487
0
@qvals = () ;
2488
}
2489
2490
0
0
if ($#qvals > -1)
2491
{
2492
0
foreach $key (@$irfunc)
2493
{
2494
0
0
next if (exists ($data -> {$key})) ; # input function alread applied
2495
0
my $if = $ifunc -> {$key} ;
2496
0
0
$val = &{$if} (undef, 'insert', $data) if ($if) ;
0
2497
0
0
next if (!defined ($val)) ; # skip NULL values
2498
0
0
if ($key =~ /^\\(.*?)$/)
0
0
2499
{
2500
0
push @qvals, $val ;
2501
0
push @keys, $1 ;
2502
}
2503
elsif (defined ($$Quote{$PreserveCase?$key:lc ($key)}))
2504
{
2505
0
push @bind_values ,$val ;
2506
0
push @qvals, '?' ;
2507
0
push @keys, $key ;
2508
0
0
push @bind_types, $type4f -> {$PreserveCase?$key:lc ($key)} ;
2509
}
2510
}
2511
}
2512
2513
0
my $rc ;
2514
2515
0
0
if ($#qvals > -1)
2516
{
2517
0
my $valstr = join (',', @qvals) ;
2518
0
my $keystr = join (',', @keys) ;
2519
2520
0
$rc = $self->SQLInsert ($keystr, $valstr, \@bind_values, \@bind_types) ;
2521
2522
0
0
$self -> {'*LastSerial'} = &{$self -> {'*GetSerialPostInsert'}} ($self -> {'*DBHdl'},
0
2523
$self -> {'*Table'},
2524
$self -> {'*Sequence'}) if ($self -> {'*GetSerialPostInsert'}) ;
2525
2526
}
2527
else
2528
{
2529
0
$self -> {'*LastSerial'} = undef ;
2530
}
2531
2532
0
0
return $newself?*newself:$rc ;
2533
}
2534
2535
## ----------------------------------------------------------------------------
2536
##
2537
## Update ...
2538
##
2539
## \%data = hash of fields for new record
2540
## $where/\%where = SQL Where condition
2541
##
2542
##
2543
2544
sub Update ($\%$)
2545
2546
{
2547
0
0
1
my ($self, $data, $where) = @_ ;
2548
2549
0
local *newself ;
2550
0
0
if (!ref ($self))
2551
{
2552
0
*newself = Setup ($self, $data) ;
2553
0
0
($self = $newself) or return undef ;
2554
}
2555
2556
0
my $expr ;
2557
my @bind_values ;
2558
0
my @bind_types ;
2559
0
my $key ;
2560
0
my $val ;
2561
0
my @vals ;
2562
0
my $q ;
2563
2564
0
my $type4f = $self->{'*Type4Field'} ;
2565
0
my $primkey ;
2566
0
my $Quote = $self->{'*Quote'} ;
2567
0
my $ifunc = $self->{'*InputFunctions'} ;
2568
0
my $irfunc = $self->{'*InputFunctionsRequiredOnUpdate'} ;
2569
0
my $dbg = $self -> {'*Debug'} > 2 ;
2570
2571
0
0
if ($irfunc)
2572
{
2573
0
0
map { $data -> {$_} = undef if (!exists ($data -> {$_})) } @$irfunc ;
0
2574
}
2575
2576
2577
0
0
if (defined ($primkey = $self->{'*PrimKey'}))
2578
{
2579
0
$val = $data -> {$primkey} ;
2580
0
0
$val = $$val if (ref ($val) eq 'SCALAR') ;
2581
#print LOG "1 primkey = $primkey d=$data->{$primkey} w=" . ($where?$where->{$primkey}:'') . " v=$val\n" ;
2582
0
0
0
if (defined ($val) && !$where)
0
0
2583
{
2584
0
$where = {$primkey => $val} ;
2585
}
2586
elsif (ref ($where) eq 'HASH' && $val eq $where -> {$primkey})
2587
{
2588
0
delete $data -> {$primkey} ;
2589
}
2590
else
2591
{
2592
0
$primkey = '' ;
2593
}
2594
}
2595
else
2596
{
2597
0
$primkey = '' ;
2598
}
2599
2600
#print LOG "2 primkey = $primkey d=$data->{$primkey} w=" . ($where?$where->{$primkey}:'') . " v=$val\n" ;
2601
0
my $datacnt = 0 ;
2602
2603
0
while (($key, $val) = each (%$data))
2604
{
2605
0
0
next if ($key eq $primkey) ;
2606
0
0
$val = $$val if (ref ($val) eq 'SCALAR') ;
2607
# any input conversion ?
2608
0
my $if = $ifunc -> {$key} ;
2609
0
0
print LOG "DB: UPDATE: $key = " . (defined ($val)?$val:'') . " " . ($if?"input filter = $if":'') . "\n" if ($dbg) ;
0
0
2610
0
0
$val = &{$if} ($val, 'update', $data, $where) if ($if) ;
0
2611
0
0
if ($key =~ /^\\(.*?)$/)
0
0
2612
{
2613
0
push @vals, "$1=$val" ;
2614
0
$datacnt++ ;
2615
}
2616
elsif (defined ($$Quote{$PreserveCase?$key:lc ($key)}))
2617
{
2618
0
push @vals, "$key=?" ;
2619
0
push @bind_values, $val ;
2620
0
0
push @bind_types, $type4f -> {$PreserveCase?$key:lc ($key)} ;
2621
0
$datacnt++ ;
2622
}
2623
}
2624
2625
0
my $rc = '' ;
2626
0
0
if ($datacnt)
2627
{
2628
0
my $valstr = join (',', @vals) ;
2629
2630
0
0
if (defined ($where))
2631
0
{ $expr = $self->BuildWhere ($where, \@bind_values, \@bind_types) ; }
2632
else
2633
0
{ $expr = $self->BuildWhere ($data, \@bind_values, \@bind_types) ; }
2634
2635
2636
0
$rc = $self->SQLUpdate ($valstr, $expr, \@bind_values, \@bind_types) ;
2637
}
2638
2639
0
0
return $newself?*newself:$rc ;
2640
}
2641
2642
2643
2644
## ----------------------------------------------------------------------------
2645
##
2646
## UpdateInsert ...
2647
##
2648
## First try an update, if this fail insert an new record
2649
##
2650
## \%data = hash of fields for record
2651
##
2652
2653
sub UpdateInsert ($\%)
2654
2655
{
2656
0
0
0
my ($self, $fdat) = @_ ;
2657
2658
0
my $rc ;
2659
2660
0
local *newself ;
2661
0
0
if (!ref ($self))
2662
{
2663
0
*newself = Setup ($self, $fdat) ;
2664
0
0
($self = $newself) or return undef ;
2665
}
2666
2667
0
$rc = $self -> Update ($fdat) ;
2668
0
0
print LOG "DB: UpdateInsert update returns: $rc affected rows: $DBI::rows\n" if ($self->{'*Debug'} > 2) ;
2669
2670
0
0
0
if (!$rc || $DBI::rows <= 0)
2671
{
2672
0
$rc = $self -> Insert ($fdat) ;
2673
}
2674
0
0
return $newself?*newself:$rc ;
2675
}
2676
2677
2678
2679
2680
## ----------------------------------------------------------------------------
2681
##
2682
## Delete ...
2683
##
2684
## $where/\%where = SQL Where condition
2685
##
2686
##
2687
2688
sub Delete ($$)
2689
2690
{
2691
0
0
1
my ($self, $where) = @_ ;
2692
2693
0
local *newself ;
2694
0
0
if (!ref ($self))
2695
{
2696
0
*newself = Setup ($self, $where) ;
2697
0
0
($self = $newself) or return undef ;
2698
}
2699
2700
0
my @bind_values ;
2701
my @bind_types ;
2702
0
my $expr = $self->BuildWhere ($where,\@bind_values,\@bind_types) ;
2703
2704
0
$self->{'*LastKey'} = undef ;
2705
2706
0
my $rc = $self->SQLDelete ($expr, \@bind_values, \@bind_types) ;
2707
0
0
return $newself?*newself:$rc ;
2708
}
2709
2710
## ----------------------------------------------------------------------------
2711
##
2712
## DeleteWithLinks ...
2713
##
2714
## $where/\%where = SQL Where condition
2715
##
2716
##
2717
2718
sub DeleteWithLinks ($$;$)
2719
2720
{
2721
0
0
1
my ($self, $where, $seen) = @_ ;
2722
2723
0
0
$seen = {} if (ref ($seen) ne 'HASH') ;
2724
2725
0
local *newself ;
2726
0
0
if (!ref ($self))
2727
{
2728
0
*newself = Setup ($self, $where) ;
2729
0
0
($self = $newself) or return undef ;
2730
}
2731
2732
0
0
$self -> savecroak ("Delete disabled for table $self->{'*Table'}") if (!($self->{'*WriteMode'} & wmDELETE)) ;
2733
2734
0
my @bind_values ;
2735
my @bind_types ;
2736
0
my $expr = $self->BuildWhere ($where,\@bind_values,\@bind_types) ;
2737
2738
0
my $clear_disabled_diag =
2739
"(!$expr && !($self->{'*WriteMode'} & wmCLEAR))";
2740
0
0
0
$self -> savecroak ("Clear (Delete all) disabled for table $self->{'*Table'}: $clear_disabled_diag") if (!$expr && !($self->{'*WriteMode'} & wmCLEAR)) ;
2741
2742
0
my $links = $self -> {'*Links'} ;
2743
2744
0
my $k ;
2745
my $link ;
2746
0
my $od ;
2747
0
my $selected = 0 ;
2748
2749
0
foreach $k (keys %$links)
2750
{
2751
0
$link = $links -> {$k} ;
2752
0
0
if ($od = $link -> {'!OnDelete'})
2753
{
2754
0
0
if (!$selected)
2755
{
2756
0
my $rc = $self->SQLSelect ($expr, '*', undef, undef, undef, \@bind_values, \@bind_types) ;
2757
0
$selected = 1 ;
2758
}
2759
2760
0
$self -> Reset ;
2761
0
my $lf = $link -> {'!LinkedField'} ;
2762
0
my $rec ;
2763
0
while ($rec = $self -> Next)
2764
{
2765
0
my $setup = {%$link} ;
2766
0
my $mv ;
2767
0
0
if (exists ($rec -> {$link -> {'!MainField'}}))
2768
{
2769
0
$mv = $rec -> {$link -> {'!MainField'}} ;
2770
}
2771
else
2772
{
2773
0
$mv = $rec -> {"$link->{'!MainTable'}.$link->{'!MainField'}"} ;
2774
}
2775
0
0
$setup -> {'!DataSource'} = $self if (!defined ($link -> {'!DataSource'})) ;
2776
0
0
print LOG "DB: DeleteLinks link = $k Setup New Recordset for table $link->{'!Table'}, $lf = " . (defined ($mv)?$mv:'') . "\n" if ($self->{'*Debug'} > 1) ;
0
2777
0
my $updset = DBIx::Recordset -> Setup ($setup) ;
2778
2779
0
0
if ($od & odDELETE)
0
2780
{
2781
0
my $seenkey = "$link->{'!Table'}::$lf::$mv" ;
2782
0
0
if (!$seen -> {$seenkey})
2783
{
2784
0
$seen -> {$seenkey} = 1 ; # avoid endless recursion
2785
0
$$updset -> DeleteWithLinks ({$lf => $mv}, $seen) ;
2786
}
2787
else
2788
{
2789
0
0
print LOG "DB: DeleteLinks detected recursion, do not follow link (key=$seenkey)\n" if ($self->{'*Debug'} > 1) ;
2790
}
2791
}
2792
elsif ($od & odCLEAR)
2793
{
2794
0
$$updset -> Update ({$lf => undef}, {$lf => $mv}) ;
2795
}
2796
}
2797
}
2798
}
2799
2800
0
$self->{'*LastKey'} = undef ;
2801
2802
0
my $rc = $self->SQLDelete ($expr, \@bind_values, \@bind_types) ;
2803
0
0
return $newself?*newself:$rc ;
2804
}
2805
2806
2807
## ----------------------------------------------------------------------------
2808
##
2809
## Select
2810
##
2811
## Does an SQL Select of the form
2812
##
2813
## SELECT $fields FROM WHERE $expr ORDERBY $order
2814
##
2815
## $where/%where = SQL Where condition (optional, defaults to no condition)
2816
## $fields = fields to select (optional, default to *)
2817
## $order = fields for sql order by or undef for no sorting (optional, defaults to no order)
2818
## $group = fields for sql group by or undef (optional, defaults to no grouping)
2819
## $append = append that string to the select statemtn for other options (optional)
2820
##
2821
2822
2823
sub Select (;$$$$$)
2824
{
2825
0
0
1
my ($self, $where, $fields, $order, $group, $append, $makesql) = @_ ;
2826
2827
0
local *newself ;
2828
0
0
if (!ref ($self))
2829
{
2830
0
*newself = Setup ($self, $where) ;
2831
0
0
($self = $newself) or return undef ;
2832
}
2833
2834
0
my $bind_values = [] ;
2835
0
my @bind_types ;
2836
0
my $expr = $self->BuildWhere ($where, \$bind_values, \@bind_types) ;
2837
2838
0
0
my $rc = $self->SQLSelect ($expr, $self->{'*Fields'} || $fields, $self->{'*Order'} || $order, $group, $append, $bind_values, \@bind_types, $makesql, ) ;
0
2839
0
0
return $newself?*newself:$rc ;
2840
}
2841
2842
2843
## ----------------------------------------------------------------------------
2844
##
2845
## Search data
2846
##
2847
## \%fdat = hash of form data
2848
##
2849
## Special keys in hash:
2850
## $start: first row to fetch
2851
## $max: maximum number of rows to fetch
2852
## $next: next n records
2853
## $prev: previous n records
2854
## $order: fieldname(s) for ordering (could also contain USING)
2855
## $group: fields for sql group by or undef (optional, defaults to no grouping)
2856
## $append:append that string to the select statemtn for other options (optional)
2857
## $fields:fieldnams(s) to retrieve
2858
##
2859
2860
2861
2862
sub Search ($\%)
2863
2864
{
2865
0
0
1
my ($self, $fdat) = @_ ;
2866
2867
0
local *newself ;
2868
0
0
if (!ref ($self))
2869
{
2870
0
*newself = Setup ($self, $fdat) ;
2871
0
0
($self = $newself) or return undef;
2872
}
2873
2874
0
my $Quote = $self->{'*Quote'} ;
2875
2876
0
0
my $start = $$fdat{'$start'} || 0 ;
2877
0
my $max = $$fdat{'$max'} ;
2878
2879
0
0
0
$start = 0 if (defined ($$fdat{'$first'}) || (defined ($start) && $start < 0)) ;
0
2880
0
0
0
$max = 1 if (defined ($max) && $max < 1) ;
2881
2882
0
0
if (defined ($$fdat{'$prev'}))
0
0
2883
{
2884
0
$start -= $max ;
2885
0
0
if ($start < 0) { $start = 0 ; }
0
2886
}
2887
elsif (defined ($$fdat{'$next'}))
2888
0
{ $start += $max ; }
2889
elsif (defined ($$fdat{'$goto'}))
2890
{
2891
0
$start = $$fdat{'$gotorow'} - 1 ;
2892
0
0
if ($start < 0) { $start = 0 ; }
0
2893
}
2894
2895
0
my $startrecno = $start ;
2896
0
my $append = '' ;
2897
0
0
0
if (defined ($max) && !$$fdat{'$last'})
2898
{
2899
0
my $LimitOffset = DBIx::Compat::GetItem ($self->{'*Driver'}, 'LimitOffset') ;
2900
0
0
if ($LimitOffset)
2901
{
2902
0
0
$append = &{$LimitOffset}($start,$$fdat{'$last'}?0:$max+1);
0
2903
0
0
$start = 0 if ($append) ;
2904
}
2905
}
2906
2907
0
my $rc ;
2908
2909
{
2910
0
local $^W = 0 ;
0
2911
0
$rc = $self->Select($fdat, $$fdat{'$fields'}, $$fdat{'$order'}, $$fdat{'$group'}, "$$fdat{'$append'} $append", $fdat->{'$makesql'} ) ;
2912
}
2913
2914
0
0
0
if ($rc && $$fdat{'$last'})
2915
{ # read all until last row
2916
0
my $storeall = $self->{'*StoreAll'} ;
2917
0
$self->{'*StoreAll'} = 1 ;
2918
0
$self -> FETCH (0x7ffffff) ;
2919
0
0
$startrecno = $start = $self->{'*LastRow'} - ($max || 1) ;
2920
0
$self->{'*StoreAll'} = $storeall ;
2921
}
2922
2923
0
$self->{'*StartRecordNo'} = $startrecno ;
2924
0
$self->{'*FetchStart'} = $start ;
2925
0
0
$self->{'*FetchMax'} = $start + $max - 1 if (defined ($max)) ;
2926
2927
2928
0
0
return $newself?*newself:$rc ;
2929
}
2930
2931
2932
2933
2934
## ----------------------------------------------------------------------------
2935
##
2936
## Execute
2937
##
2938
##
2939
## \%fdat = hash of form data
2940
##
2941
## =search = search data
2942
## =update = update record(s)
2943
## =insert = insert record
2944
## =delete = delete record(s)
2945
## =empty = setup empty object
2946
##
2947
2948
2949
sub Execute ($\%)
2950
2951
{
2952
0
0
1
my ($self, $fdat) = @_ ;
2953
2954
0
local *newself ;
2955
0
0
if (!ref ($self))
2956
{
2957
0
*newself = Setup ($self, $fdat) ;
2958
0
0
($self = $newself) or return undef ;
2959
}
2960
2961
2962
0
0
if ($self->{'*Debug'} > 2)
2963
0
0
{ print LOG 'DB: Execute ' . ($$fdat{'=search'}?'=search ':'') .
0
0
0
0
2964
($$fdat{'=update'}?'=update ':'') . ($$fdat{'=insert'}?'=insert ':'') .
2965
($$fdat{'=empty'}?'=empty':'') . ($$fdat{'=delete'}?'=delete':'') . "\n" ; }
2966
2967
0
my $rc = '-' ;
2968
0
0
if (defined ($$fdat{'=search'}))
2969
{
2970
0
$rc = $self -> Search ($fdat)
2971
}
2972
else
2973
{
2974
0
my $serial ;
2975
#$rc = $self -> UpdateInsert ($fdat) if (defined ($$fdat{'=update'}) && defined ($$fdat{'=insert'}) && !defined($rc)) ;
2976
0
0
0
$rc = $self -> Update ($fdat) if (defined ($$fdat{'=update'}) && $rc eq '-') ;
2977
0
0
0
if (defined ($$fdat{'=insert'}) && $rc eq '-')
2978
{
2979
0
$rc = $self -> Insert ($fdat) ;
2980
0
0
0
if (defined ($rc) && $self -> {'*LastSerial'})
2981
{
2982
0
$serial = $self -> {'*LastSerial'} ;
2983
0
$rc = $self -> Search ({$self->{'*Serial'} => $serial}) ;
2984
0
0
return $newself?*newself:$rc ;
2985
}
2986
}
2987
0
0
0
$rc = $self -> DeleteWithLinks ($fdat) if (defined ($$fdat{'=delete'}) && $rc eq '-') ;
2988
0
0
0
$rc = $self -> Search ($fdat) if (!defined ($$fdat{'=empty'}) && defined ($rc)) ;
2989
0
0
0
$rc = 1 if (defined ($$fdat{'=empty'}) && $rc eq '-') ;
2990
}
2991
2992
0
0
return $newself?*newself:$rc ;
2993
}
2994
2995
## ----------------------------------------------------------------------------
2996
##
2997
## PushCurrRec
2998
##
2999
3000
sub PushCurrRec
3001
3002
{
3003
0
0
0
my ($self) = @_ ;
3004
3005
# Save Current Record
3006
0
my $sp = $self->{'*CurrRecStack'} ;
3007
0
push @$sp, $self->{'*LastRow'} ;
3008
0
push @$sp, $self->{'*LastKey'} ;
3009
0
push @$sp, $self->{'*FetchMax'} ;
3010
}
3011
3012
3013
3014
## ----------------------------------------------------------------------------
3015
##
3016
## PopCurrRec
3017
##
3018
3019
sub PopCurrRec
3020
3021
{
3022
0
0
0
my ($self) = @_ ;
3023
3024
#Restore pointers
3025
0
my $sp = $self->{'*CurrRecStack'} ;
3026
0
$self->{'*FetchMax'} = pop @$sp ;
3027
0
$self->{'*LastKey'} = pop @$sp ;
3028
0
$self->{'*LastRow'} = pop @$sp ;
3029
}
3030
3031
## ----------------------------------------------------------------------------
3032
##
3033
## MoreRecords
3034
##
3035
3036
sub MoreRecords
3037
3038
{
3039
0
0
1
my ($self, $ignoremax) = @_ ;
3040
3041
0
$self -> PushCurrRec ;
3042
0
0
$self->{'*FetchMax'} = undef if ($ignoremax) ;
3043
3044
0
my $more = $self -> Next () ;
3045
3046
0
$self -> PopCurrRec ;
3047
3048
0
return $more ; # && (ref $more) && keys (%$more) > 0 ;
3049
}
3050
3051
3052
## ----------------------------------------------------------------------------
3053
##
3054
## PrevNextForm
3055
##
3056
##
3057
## $textprev = Text for previous button
3058
## $textnext = Text for next button
3059
## \%fdat = fields/values for select where
3060
##
3061
##
3062
3063
3064
sub PrevNextForm
3065
3066
{
3067
0
0
1
my ($self, $textprev, $textnext, $fdat) = @_ ;
3068
3069
3070
0
my $param = $textprev ;
3071
0
my $textfirst ;
3072
my $textlast ;
3073
0
my $textgoto ;
3074
3075
0
0
if (ref $textprev eq 'HASH')
3076
{
3077
0
$fdat = $textnext ;
3078
0
$textprev = $param -> {'-prev'} ;
3079
0
$textnext = $param -> {'-next'} ;
3080
0
$textfirst = $param -> {'-first'} ;
3081
0
$textlast = $param -> {'-last'} ;
3082
0
$textgoto = $param -> {'-goto'} ;
3083
}
3084
3085
3086
3087
0
my $more = $self -> MoreRecords (1) ;
3088
0
my $start = $self -> {'*StartRecordNo'} ;
3089
0
my $max = $self -> {'*FetchMax'} - $self -> {'*FetchStart'} + 1 ;
3090
3091
3092
0
my $esc = '' ;
3093
0
0
0
$esc = '\\' if ((defined ($HTML::Embperl::escmode) && ($HTML::Embperl::escmode & 1)) || (defined ($Embperl::escmode) && ($Embperl::escmode & 1))) ;
0
0
3094
0
my $buttons = "$esc
3095
0
my $k ;
3096
my $v ;
3097
3098
0
0
if ($fdat)
3099
{
3100
0
while (($k, $v) = each (%$fdat))
3101
{
3102
0
0
if (substr ($k, 0, 1) eq '\\')
3103
{
3104
0
$k = '\\' . $k ;
3105
}
3106
0
0
0
if ($k ne '$start' && $k ne '$max' && $k ne '$prev' && $k ne '$next' && $k ne '$goto' && $k ne '$gotorow'
0
0
0
0
0
0
3107
&& $k ne '$first' && $k ne '$last')
3108
{
3109
0
$buttons .= "$esc
3110
}
3111
}
3112
}
3113
3114
0
0
0
if ($start > 0 && $textfirst)
3115
{
3116
0
$buttons .= "$esc
3117
}
3118
0
0
0
if ($start > 0 && $textprev)
3119
{
3120
0
$buttons .= "$esc
3121
}
3122
0
0
if ($textgoto)
3123
{
3124
0
$buttons .= "$esc
3125
0
$buttons .= "$esc
3126
}
3127
0
0
0
if ($more > 0 && $textnext)
3128
{
3129
0
$buttons .= "$esc
3130
}
3131
0
0
0
if ($more > 0 && $textlast)
3132
{
3133
0
$buttons .= "$esc
3134
}
3135
0
$buttons .= "$esc" ;
3136
3137
0
return $buttons ;
3138
}
3139
3140
3141
3142
3143
##########################################################################################
3144
3145
1;
3146
3147
package DBIx::Recordset::CurrRow ;
3148
3149
3150
1
1
13
use Carp ;
1
2
1
709
3151
3152
## ----------------------------------------------------------------------------
3153
##
3154
## TIEHASH
3155
##
3156
## tie an hash to the object, object must be aready blessed
3157
##
3158
## tie %self, 'DBIx::Recordset::CurrRow', $self ;
3159
##
3160
3161
sub TIEHASH
3162
{
3163
0
0
my ($class, $arg) = @_ ;
3164
0
my $rs ;
3165
3166
0
0
if (ref ($arg) eq 'HASH')
0
3167
{
3168
0
0
$rs = DBIx::Recordset -> SetupObject ($arg) or return undef ;
3169
}
3170
elsif (ref ($arg) eq 'DBIx::Recordset')
3171
{
3172
0
$rs = $arg ;
3173
}
3174
else
3175
{
3176
0
croak ("Need DBIx::Recordset or setup parameter") ;
3177
}
3178
3179
3180
0
my $self = {'*Recordset' => $rs} ;
3181
3182
0
bless ($self, $class) ;
3183
3184
0
return $self ;
3185
}
3186
3187
3188
3189
3190
## ----------------------------------------------------------------------------
3191
##
3192
## Fetch the data from a previous SQL Select
3193
##
3194
## $fetch = Column to fetch
3195
##
3196
##
3197
3198
3199
sub FETCH ()
3200
{
3201
# if (wantarray)
3202
# {
3203
# my @result ;
3204
# my $rs = $_[0] -> {'*Recordset'} ;
3205
# $rs -> PushCurrRec ;
3206
# my $rec = $rs -> First () ;
3207
# while ($rec)
3208
# {
3209
## push @result, tied (%$rec) -> FETCH ($_[1]) ;
3210
# push @result, $rec -> {$_[1]} ;
3211
# $rec = $rs -> Next () ;
3212
# }
3213
# $rs -> PopCurrRec ;
3214
# return @result ;
3215
# }
3216
# else
3217
{
3218
0
0
my $rec = $_[0] -> {'*Recordset'} -> Curr ;
0
3219
0
0
if (defined ($rec))
3220
{
3221
0
my $obj ;
3222
0
0
return $obj -> FETCH ($_[1]) if ($obj = tied (%$rec)) ;
3223
0
return $rec -> {$_[1]} ;
3224
}
3225
0
return undef ;
3226
}
3227
}
3228
3229
3230
## ----------------------------------------------------------------------------
3231
3232
sub STORE ()
3233
{
3234
0
0
0
if (ref $_[2] eq 'ARRAY')
3235
{ # array
3236
0
my ($self, $key, $dat) = @_ ;
3237
0
my $rs = $self -> {'*Recordset'} ;
3238
0
$rs -> PushCurrRec ;
3239
0
my $rec = $rs -> First (1) ;
3240
0
my $i = 0 ;
3241
0
while ($rec)
3242
{
3243
0
tied (%$rec) -> STORE ($key, $$dat[$i++]) ;
3244
0
0
last if ($i > $#$dat) ;
3245
0
$rec = $rs -> Next (1) ;
3246
}
3247
0
$rs -> PopCurrRec ;
3248
}
3249
else
3250
{
3251
0
tied (%{$_[0] -> {'*Recordset'} -> Curr (1)}) -> STORE ($_[1], $_[2]) ;
0
3252
}
3253
}
3254
3255
3256
## ----------------------------------------------------------------------------
3257
3258
sub FIRSTKEY
3259
{
3260
0
0
my $rec = $_[0] -> {'*Recordset'} -> Curr ;
3261
0
my $obj = tied (%{$rec}) ;
0
3262
3263
0
0
return tied (%{$rec}) -> FIRSTKEY if ($obj) ;
0
3264
3265
0
my $k = keys %$rec ;
3266
0
return each %$rec ;
3267
}
3268
3269
3270
## ----------------------------------------------------------------------------
3271
3272
sub NEXTKEY
3273
{
3274
0
0
my $rec = $_[0] -> {'*Recordset'} -> Curr ;
3275
0
my $obj = tied (%{$rec}) ;
0
3276
3277
0
0
return tied (%{$rec}) -> NEXTKEY if ($obj) ;
0
3278
0
return each %$rec ;
3279
}
3280
3281
## ----------------------------------------------------------------------------
3282
3283
sub EXISTS
3284
{
3285
0
0
return exists ($_[0] -> {'*Recordset'} -> Curr -> {$_[1]}) ;
3286
}
3287
3288
## ----------------------------------------------------------------------------
3289
3290
sub DELETE
3291
{
3292
0
0
carp ("Cannot DELETE a field from a database record") ;
3293
}
3294
3295
## ----------------------------------------------------------------------------
3296
3297
sub CLEAR ($)
3298
3299
0
0
{
3300
#carp ("Cannot DELETE all fields from a database record") ;
3301
}
3302
3303
## ----------------------------------------------------------------------------
3304
3305
sub DESTROY
3306
3307
{
3308
0
0
my $self = shift ;
3309
0
my $orgerr = $@ ;
3310
0
local $@ ;
3311
3312
eval
3313
0
{
3314
3315
0
0
$self -> {'*Recordset'} -> ReleaseRecords () if (defined ($self -> {'*Recordset'})) ;
3316
3317
{
3318
0
local $^W = 0 ;
0
3319
0
0
print DBIx::Recordset::LOG "DB: ::CurrRow::DESTROY\n" if ($self -> {'*Recordset'} -> {'*Debug'} > 3) ;
3320
}
3321
} ;
3322
0
0
0
$self -> savecroak ($@) if (!$orgerr && $@) ;
3323
0
0
0
warn $@ if ($orgerr && $@) ;
3324
}
3325
3326
##########################################################################################
3327
3328
package DBIx::Recordset::Hash ;
3329
3330
1
1
6
use Carp ;
1
2
1
1608
3331
3332
3333
## ----------------------------------------------------------------------------
3334
##
3335
## PreFetch
3336
##
3337
## Prefetch data
3338
##
3339
##
3340
3341
sub PreFetch
3342
3343
{
3344
0
0
my ($self, $rs) = @_ ;
3345
0
my $where = $self -> {'*PreFetch'} ;
3346
0
my %keyhash ;
3347
my $rec ;
3348
0
my $merge = $self -> {'*MergeFunc'} ;
3349
0
my $pk ;
3350
3351
0
0
$rs -> Search ($where eq '*'?undef:$where) or return undef ;
0
3352
0
0
my $primkey = $rs -> {'*PrimKey'} or $rs -> savecroak ('Need !PrimKey') ;
3353
0
while ($rec = $rs -> Next)
3354
{
3355
0
$pk = $rec -> {$primkey} ;
3356
0
0
0
if ($merge && exists ($keyhash{$pk}))
3357
{
3358
0
0
if (tied (%{$keyhash{$pk}}))
0
3359
{
3360
0
my %data = %{$keyhash{$pk}} ;
0
3361
0
$keyhash{$pk} = \%data ;
3362
}
3363
3364
0
&$merge ($keyhash{$pk}, $rec) ;
3365
}
3366
else
3367
{
3368
0
$keyhash{$pk} = $rec ;
3369
}
3370
}
3371
0
$self -> {'*KeyHash'} = \%keyhash ;
3372
0
0
$self -> {'*ExpiresTime'} = time + $self -> {'*Expires'} if ($self -> {'*Expires'} > 0) ;
3373
}
3374
3375
## ----------------------------------------------------------------------------
3376
##
3377
## PreFetchIfExpires
3378
##
3379
## Prefetch data
3380
##
3381
##
3382
3383
sub PreFetchIfExpires
3384
3385
{
3386
3387
0
0
my ($self, $rs) = @_ ;
3388
3389
0
my $prefetch;
3390
3391
0
0
if (ref ($self -> {'*Expires'}) eq 'CODE') {
0
3392
0
$prefetch = $self -> {'*Expires'}->($self);
3393
} elsif (defined ($self -> {'*ExpiresTime'})) {
3394
0
$prefetch = $self -> {'*ExpiresTime'} < time
3395
}
3396
3397
0
0
$self -> PreFetch ($rs) if $prefetch;
3398
3399
}
3400
3401
## ----------------------------------------------------------------------------
3402
##
3403
## TIEHASH
3404
##
3405
## tie an hash to the object, object must be aready blessed
3406
##
3407
## tie %self, 'DBIx::Recordset::Hash', $self ;
3408
##
3409
3410
sub TIEHASH
3411
{
3412
0
0
my ($class, $arg) = @_ ;
3413
0
my $rs ;
3414
my $keyhash ;
3415
3416
0
my $self ;
3417
3418
0
0
if (ref ($arg) eq 'HASH')
0
3419
{
3420
0
$self =
3421
{
3422
'*Expires' => $arg -> {'!Expires'},
3423
'*PreFetch' => $arg -> {'!PreFetch'},
3424
'*MergeFunc' => $arg -> {'!MergeFunc'},
3425
} ;
3426
3427
0
0
$rs = DBIx::Recordset -> SetupObject ($arg) or return undef ;
3428
}
3429
elsif (ref ($arg) eq 'DBIx::Recordset')
3430
{
3431
0
$rs = $arg ;
3432
0
$self = {} ;
3433
}
3434
else
3435
{
3436
0
croak ("Need DBIx::Recordset or setup parameter") ;
3437
}
3438
3439
3440
0
$self -> {'*Recordset'} = $rs ;
3441
3442
0
bless ($self, $class) ;
3443
3444
0
0
$self -> PreFetch ($rs) if ($self -> {'*PreFetch'}) ;
3445
3446
0
return $self ;
3447
}
3448
3449
3450
## ----------------------------------------------------------------------------
3451
##
3452
## Fetch the data from a previous SQL Select
3453
##
3454
## $fetch = PrimKey for Row to fetch
3455
##
3456
##
3457
3458
3459
sub FETCH
3460
{
3461
0
0
my ($self, $fetch) = @_ ;
3462
0
my $rs = $self->{'*Recordset'} ;
3463
3464
0
0
return $rs-> {'*UndefKey'} if (!defined ($fetch)) ; # undef could be used as key for autoincrement values
3465
3466
0
my $h ;
3467
3468
0
0
if ($self -> {'*PreFetch'})
3469
{
3470
0
$self -> PreFetchIfExpires ($rs) ;
3471
3472
0
$h = $self -> {'*KeyHash'} -> {$fetch} ;
3473
}
3474
else
3475
{
3476
0
0
print DBIx::Recordset::LOG "DB: Hash::FETCH \{" . (defined ($fetch)?$fetch:'') ."\}\n" if ($rs->{'*Debug'} > 3) ;
0
3477
3478
0
0
0
if (!defined ($rs->{'*LastKey'}) || $fetch ne $rs->{'*LastKey'})
3479
{
3480
0
0
$rs->SQLSelect ("$rs->{'*PrimKey'} = ?", undef, undef, undef, undef, [$fetch], [$rs->{'*Type4Field'}{$rs->{'*PrimKey'}}]) or return undef ;
3481
3482
0
$h = $rs -> FETCH (0) ;
3483
0
my $merge = $self -> {'*MergeFunc'} ;
3484
0
$self -> {'*LastMergeRec'} = undef ;
3485
0
0
0
if ($merge && $rs -> MoreRecords)
3486
{
3487
0
my %data = %$h ;
3488
0
my $rec ;
3489
0
my $i = 1 ;
3490
0
while ($rec = $rs -> FETCH($i++))
3491
{
3492
0
&$merge (\%data, $rec) ;
3493
}
3494
0
$self -> {'*LastMergeRec'} = $h = \%data ;
3495
}
3496
}
3497
else
3498
{
3499
0
0
if ($self -> {'*LastMergeRec'})
3500
0
{ $h = $self -> {'*LastMergeRec'} }
3501
else
3502
0
{ $h = $rs -> Curr ; }
3503
}
3504
}
3505
3506
0
0
print DBIx::Recordset::LOG "DB: Hash::FETCH return " . (defined ($h)?$h:'') . "\n" if ($rs->{'*Debug'} > 3) ;
0
3507
3508
0
return $h ;
3509
}
3510
3511
## ----------------------------------------------------------------------------
3512
##
3513
## store something in the hash
3514
##
3515
## $key = PrimKey for Row to fetch
3516
## $value = Hashref with row data
3517
##
3518
3519
sub STORE
3520
3521
{
3522
0
0
my ($self, $key, $value) = @_ ;
3523
0
my $rs = $self -> {'*Recordset'} ;
3524
3525
0
0
print DBIx::Recordset::LOG "DB: ::Hash::STORE \{" . (defined ($key)?$key:'') . "\} = " . (defined ($value)?$value:'') . "\n" if ($rs->{'*Debug'} > 3) ;
0
0
3526
3527
0
0
$rs -> savecroak ("Hash::STORE need hashref as value") if (!ref ($value) eq 'HASH') ;
3528
3529
#$rs -> savecroak ("Hash::STORE doesn't work with !PreFetch") if ($self -> {'*PreFetch'}) ;
3530
0
0
return if ($self -> {'*PreFetch'}) ;
3531
3532
0
my %dat = %$value ; # save values, if any
3533
0
$dat{$rs -> {'*PrimKey'}} = $key ; # setup primary key value
3534
0
%$value = () ; # clear out data in tied hash
3535
0
my $r = tie %$value, 'DBIx::Recordset::Row', $rs, \%dat, undef, 1 ;
3536
3537
#$r -> STORE ($rs -> {'*PrimKey'}, $key) ;
3538
#$r -> {'*new'} = 1 ;
3539
3540
# setup recordset
3541
0
$rs-> ReleaseRecords ;
3542
0
$DBIx::Recordset::Data{$rs-> {'*Id'}}[0] = $value ;
3543
0
0
$rs-> {'*UndefKey'} = defined($key)?undef:$value ;
3544
0
$rs-> {'*LastKey'} = $key ;
3545
0
$rs-> {'*CurrRow'} = 1 ;
3546
0
$rs-> {'*LastRow'} = 0 ;
3547
}
3548
3549
## ----------------------------------------------------------------------------
3550
3551
sub FIRSTKEY
3552
{
3553
0
0
my $self = shift ;
3554
3555
0
my $rs = $self->{'*Recordset'} ;
3556
0
my $primkey = $rs->{'*PrimKey'} ;
3557
3558
3559
0
0
if ($self -> {'*PreFetch'})
3560
{
3561
0
$self -> PreFetchIfExpires ($rs) ;
3562
3563
0
my $keyhash = $self -> {'*KeyHash'} ;
3564
0
my $foo = keys %$keyhash ; # reset iterator
3565
3566
0
return each %$keyhash ;
3567
}
3568
3569
0
0
$rs->SQLSelect () or return undef ;
3570
3571
0
0
my $dat = $rs -> First (0) or return undef ;
3572
0
my $key = $dat -> {$rs->{'*PrimKey'}} ;
3573
3574
0
0
if ($rs->{'*Debug'} > 3)
3575
{
3576
0
0
print DBIx::Recordset::LOG "DB: Hash::FIRSTKEY \{" . (defined ($key)?$key:'') . "\}\n" ;
3577
}
3578
3579
0
return $key ;
3580
}
3581
3582
## ----------------------------------------------------------------------------
3583
3584
sub NEXTKEY
3585
{
3586
0
0
my $self = shift ;
3587
0
my $rs = $self->{'*Recordset'} ;
3588
3589
0
0
if ($self -> {'*PreFetch'})
3590
{
3591
##$self -> PreFetchIfExpires ($rs) ;
3592
3593
0
my $keyhash = $self -> {'*KeyHash'} ;
3594
0
return each %$keyhash ;
3595
}
3596
3597
0
0
my $dat = $rs -> Next () or return undef ;
3598
0
my $key = $dat -> {$rs->{'*PrimKey'}} ;
3599
3600
0
0
if ($rs->{'*Debug'} > 3)
3601
{
3602
0
0
print DBIx::Recordset::LOG "DB: Hash::NEXTKEY \{" . (defined ($key)?$key:'') . "\}\n" ;
3603
}
3604
3605
0
return $key ;
3606
}
3607
3608
## ----------------------------------------------------------------------------
3609
3610
sub EXISTS
3611
{
3612
0
0
my ($self, $key) = @_ ;
3613
3614
0
0
if ($self -> {'*PreFetch'})
3615
{
3616
0
my $rs = $self->{'*Recordset'} ;
3617
0
$self -> PreFetchIfExpires ($rs) ;
3618
3619
0
my $keyhash = $self -> {'*KeyHash'} ;
3620
0
return exists ($keyhash -> {$key}) ;
3621
}
3622
3623
0
return defined ($self -> FETCH ($key)) ;
3624
}
3625
3626
## ----------------------------------------------------------------------------
3627
3628
sub DELETE
3629
{
3630
0
0
my ($self, $key) = @_ ;
3631
0
my $rs = $self -> {'*Recordset'} ;
3632
3633
0
$rs->{'*LastKey'} = undef ;
3634
3635
0
0
$rs->SQLDelete ("$rs->{'*PrimKey'} = ?", [$key], [$rs->{'*Type4Field'}{$rs->{'*PrimKey'}}]) or return undef ;
3636
3637
0
return 1 ;
3638
}
3639
3640
## ----------------------------------------------------------------------------
3641
3642
sub CLEAR
3643
3644
{
3645
0
0
my ($self, $key) = @_ ;
3646
0
my $rs = $self -> {'*Recordset'} ;
3647
3648
0
0
$rs->SQLDelete ('') or return undef ;
3649
}
3650
3651
## ----------------------------------------------------------------------------
3652
##
3653
## Dirty - see if there are unsaved changes
3654
##
3655
3656
0
0
sub Dirty { return $_[0]->{'*Recordset'}->Dirty() }
3657
3658
## ----------------------------------------------------------------------------
3659
3660
sub Flush
3661
3662
{
3663
0
0
$_[0]->{'*Recordset'} -> Flush () ;
3664
}
3665
3666
## ----------------------------------------------------------------------------
3667
3668
sub DESTROY
3669
3670
{
3671
0
0
my $self = shift ;
3672
0
my $orgerr = $@ ;
3673
0
local $@ ;
3674
3675
eval
3676
0
{
3677
3678
0
0
$self -> {'*Recordset'} -> ReleaseRecords () if (defined ($self -> {'*Recordset'})) ;
3679
3680
{
3681
0
local $^W = 0 ;
0
3682
0
0
print DBIx::Recordset::LOG "DB: ::Hash::DESTROY\n" if ($self -> {'*Recordset'} -> {'*Debug'} > 3) ;
3683
}
3684
} ;
3685
0
0
0
$self -> savecroak ($@) if (!$orgerr && $@) ;
3686
0
0
0
warn $@ if ($orgerr && $@) ;
3687
}
3688
3689
##########################################################################################
3690
3691
package DBIx::Recordset::Access ;
3692
3693
1
1
5
use overload 'bool' => sub { 1 }, '%{}' => \&gethash, '@{}' => \&getarray ; #, '${}' => \&getscalar ;
1
0
23
1
21
0
0
3694
3695
sub new
3696
{
3697
0
0
my $class = shift;
3698
0
my $arg = shift ;
3699
0
bless $arg, $class;
3700
}
3701
3702
3703
sub gethash
3704
{
3705
0
0
my $self = shift ;
3706
0
return \%$$self ;
3707
}
3708
3709
sub getarray
3710
{
3711
0
0
my $self = shift ;
3712
0
return \@$$self ;
3713
}
3714
3715
sub getscalar
3716
{
3717
0
0
my $self = shift ;
3718
0
return \$$$self ;
3719
}
3720
3721
##########################################################################################
3722
3723
package DBIx::Recordset::Row ;
3724
3725
1
1
239
use Carp ;
1
1
1
2093
3726
3727
sub TIEHASH
3728
3729
{
3730
0
0
my ($class, $rs, $names, $dat, $new) = @_ ;
3731
3732
0
my $self = {'*Recordset' => $rs} ;
3733
0
my $data = $self -> {'*data'} = {} ;
3734
0
my $upd = $self -> {'*upd'} = {} ;
3735
3736
0
bless ($self, $class) ;
3737
3738
0
0
if (ref ($names) eq 'HASH')
3739
{
3740
0
my $v ;
3741
my $k ;
3742
3743
0
0
if ($new)
3744
{
3745
0
my $dirty = 0 ;
3746
0
$self->{'*new'} = 1 ; # mark it as new record
3747
3748
0
my $lk ;
3749
0
while (($k, $v) = each (%$names))
3750
{
3751
0
0
$lk = $DBIx::Recordset::PreserveCase?$k:lc ($k) ;
3752
# store the value and remeber it for later update
3753
0
$upd ->{$lk} = \($data->{$lk} = $v) ;
3754
0
$dirty = 1 ;
3755
}
3756
0
$self->{'*dirty'} = $dirty ; # mark it as dirty only if data exists
3757
}
3758
else
3759
{
3760
0
while (($k, $v) = each (%$names))
3761
{
3762
0
0
$data -> {$DBIx::Recordset::PreserveCase?$k:lc ($k)} = $v ;
3763
}
3764
}
3765
}
3766
else
3767
{
3768
0
my $i = 0 ;
3769
0
my $of ;
3770
0
0
my $ofunc = $rs -> {'*OutputFuncArray'} || [] ;
3771
0
my $linkname = $rs -> {'*LinkName'} ;
3772
0
0
if ($rs -> {'*KeepFirst'})
0
0
3773
{
3774
0
$i = -1 ;
3775
0
%$data = () ;
3776
0
0
if ($dat)
3777
{
3778
0
foreach my $k (@$dat)
3779
{
3780
0
$i++ ;
3781
0
0
my $hkey = ($DBIx::Recordset::PreserveCase?$$names[$i]:lc($$names[$i])) ;
3782
3783
#warn "hkey = $hkey data = $k\n" ;
3784
0
0
$data -> {$hkey} = ($ofunc->[$i]?(&{$ofunc->[$i]}($k)):$k) if (!exists $data -> {$hkey}) ;
0
0
3785
}
3786
}
3787
}
3788
elsif ($linkname < 2)
3789
{
3790
0
$i = -1 ;
3791
0
0
%$data = map { $i++ ; ($DBIx::Recordset::PreserveCase?$$names[$i]:lc($$names[$i])) => ($ofunc->[$i]?(&{$ofunc->[$i]}($_)):$_) } @$dat if ($dat) ;
0
0
0
0
0
3792
}
3793
elsif ($linkname < 3)
3794
{
3795
0
my $r ;
3796
0
my $repl = $rs -> {'*ReplaceFields'} ;
3797
0
my $n ;
3798
3799
0
foreach $r (@$repl)
3800
{
3801
0
0
$n = $DBIx::Recordset::PreserveCase?$names -> [$i]:lc ($names -> [$i]) ;
3802
0
$of = $ofunc -> [$i] ;
3803
0
0
$data -> {$n} = ($of?(&{$of}($dat->[$i])):$dat->[$i]) ;
0
3804
0
0
0
$data -> {uc($n)} = join (' ', map ({ ($ofunc->[$_]?(&{$ofunc->[$_]}($dat->[$_])):$dat->[$_])} @$r)) if ($#$r > 0 || $r -> [0] != $i) ;
0
0
0
3805
0
$i++ ;
3806
}
3807
}
3808
else
3809
{
3810
0
my $r ;
3811
0
my $repl = $rs -> {'*ReplaceFields'} ;
3812
3813
0
foreach $r (@$repl)
3814
{
3815
0
0
$data -> {($DBIx::Recordset::PreserveCase?$$names[$i]:lc($$names[$i]))} = join (' ', map ({ ($ofunc->[$_]?(&{$ofunc->[$_]}($dat->[$_])):$dat->[$_])} @$r)) ;
0
0
0
3816
#print LOG "###repl $r -> $data->{$$names[$i]}\n" ;
3817
0
$i++ ;
3818
}
3819
}
3820
3821
0
$self -> {'*Recordset'} = $rs ;
3822
}
3823
3824
0
0
if (!$new)
3825
{
3826
0
my $pk = $rs -> {'*PrimKey'} ;
3827
3828
0
0
0
if ($pk && exists ($data -> {$pk}))
3829
{
3830
0
$self -> {'*PrimKeyOrgValue'} = $data -> {$pk} ;
3831
}
3832
else
3833
{
3834
# save whole record for usage as key in later update
3835
0
%{$self -> {'*org'}} = %$data ;
0
3836
3837
0
$self -> {'*PrimKeyOrgValue'} = $self -> {'*org'} ;
3838
}
3839
}
3840
3841
3842
0
return $self ;
3843
}
3844
3845
## ----------------------------------------------------------------------------
3846
3847
sub STORE
3848
{
3849
0
0
my ($self, $key, $value) = @_ ;
3850
0
my $rs = $self -> {'*Recordset'} ;
3851
0
my $dat = $self -> {'*data'} ;
3852
3853
0
local $^W = 0 ;
3854
3855
0
0
print DBIx::Recordset::LOG "DB: Row::STORE $key = $value\n" if ($rs->{'*Debug'} > 3) ;
3856
# any changes?
3857
0
0
0
if ($dat -> {$key} ne $value || defined ($dat -> {$key}) != defined($value))
3858
{
3859
# store the value and remeber it for later update
3860
0
$self -> {'*upd'}{$key} = \($dat -> {$_[1]} = $value) ;
3861
0
$self -> {'*dirty'} = 1 ; # mark row dirty
3862
}
3863
}
3864
3865
## ----------------------------------------------------------------------------
3866
3867
sub FETCH
3868
{
3869
0
0
my ($self, $key) = @_ ;
3870
0
0
return undef if (!$key) ;
3871
0
my $rs = $self -> {'*Recordset'} ;
3872
0
my $data = $self -> {'*data'}{$key} ;
3873
0
my $link ;
3874
0
0
if (!defined($data))
3875
{
3876
0
0
if ($key eq '!Name')
0
3877
{
3878
0
0
my $nf = $rs -> {'*NameField'} || $rs -> TableAttr ('!NameField') ;
3879
0
0
if (!ref $nf)
3880
{
3881
0
0
return $self -> {'*data'}{$key} = $self -> {'*data'}{uc($nf)} || $self -> {'*data'}{$nf} ;
3882
}
3883
3884
0
0
return $self -> {'*data'}{$key} = join (' ', map { $self -> {'*data'}{uc ($_)} || $self -> {'*data'}{$_} } @$nf) ;
0
3885
}
3886
elsif (defined ($link = $rs -> {'*Links'}{$key}))
3887
{
3888
0
my $lf = $link -> {'!LinkedField'} ;
3889
0
my $dat = $self -> {'*data'} ;
3890
0
my $mv ;
3891
0
0
if (exists ($dat -> {$link -> {'!MainField'}}))
3892
{
3893
0
$mv = $dat -> {$link -> {'!MainField'}} ;
3894
}
3895
else
3896
{
3897
0
$mv = $dat -> {"$link->{'!MainTable'}.$link->{'!MainField'}"} ;
3898
}
3899
0
0
if ($link -> {'!UseHash'})
3900
{
3901
0
my $linkset = $rs -> {'*LinkSet'}{$key} ;
3902
0
0
if (!$linkset)
3903
{
3904
0
my $setup = {%$link} ;
3905
0
$setup -> {'!PrimKey'} = $lf ;
3906
0
0
$setup -> {'!DataSource'} = $rs if (!defined ($link -> {'!DataSource'})) ;
3907
0
my %linkset ;
3908
0
0
print DBIx::Recordset::LOG "DB: Row::FETCH $key = Setup New Recordset for table $link->{'!Table'}, $lf = " . (defined ($mv)?$mv:'') . "\n" if ($rs->{'*Debug'} > 3) ;
0
3909
0
$rs -> {'*LinkSet'}{$key} = $linkset = tie %linkset, 'DBIx::Recordset::Hash', $setup ;
3910
}
3911
0
$data = $linkset -> FETCH ($mv) ;
3912
}
3913
else
3914
{
3915
0
my $linkkey = "$key-$lf-$mv" ;
3916
0
my $linkset = $rs -> {'*LinkSet'}{$linkkey} ;
3917
0
0
if (!$linkset)
3918
{
3919
0
my $setup = {%$link} ;
3920
0
$setup -> {$lf} = $mv ;
3921
0
$setup -> {'!Default'} = { $lf => $mv } ;
3922
0
0
$setup -> {'!DataSource'} = $rs if (!defined ($link -> {'!DataSource'})) ;
3923
0
0
print DBIx::Recordset::LOG "DB: Row::FETCH $key = Setup New Recordset for table $link->{'!Table'}, $lf = " . (defined ($mv)?$mv:'') . "\n" if ($rs->{'*Debug'} > 3) ;
0
3924
3925
0
$linkset = DBIx::Recordset -> Search ($setup) ;
3926
0
$data = $self -> {'*data'}{$key} = DBIx::Recordset::Access -> new(\$linkset) ;
3927
3928
0
0
if ($link -> {'!Cache'})
3929
{
3930
0
$rs -> {'*LinkSet'}{$linkkey} = $linkset ;
3931
}
3932
}
3933
else
3934
{
3935
0
$$linkset -> Reset ;
3936
0
$data = DBIx::Recordset::Access -> new(\$linkset) ;
3937
}
3938
}
3939
3940
0
my $of = $rs -> {'*OutputFunctions'}{$key} ;
3941
0
0
$data = &{$of}($data) if ($of) ;
0
3942
}
3943
}
3944
3945
0
0
0
if ($rs && $rs->{'*Debug'} > 3) { local $^W=0;print DBIx::Recordset::LOG "DB: Row::FETCH " . (defined ($key)?$key:'') . " = <" . (defined ($data)?$data:'') . ">\n" } ;
0
0
0
0
3946
3947
0
return $data ;
3948
}
3949
3950
## ----------------------------------------------------------------------------
3951
3952
sub FIRSTKEY
3953
{
3954
0
0
my ($self) = @_ ;
3955
0
my $a = scalar keys %{$self -> {'*data'}};
0
3956
3957
0
return each %{$self -> {'*data'}} ;
0
3958
}
3959
3960
## ----------------------------------------------------------------------------
3961
3962
sub NEXTKEY
3963
{
3964
0
0
return each %{$_[0] -> {'*data'}} ;
0
3965
}
3966
3967
## ----------------------------------------------------------------------------
3968
3969
sub EXISTS
3970
{
3971
0
0
exists ($_[0]->{'*data'}{$_[1]}) ;
3972
}
3973
3974
3975
## ----------------------------------------------------------------------------
3976
3977
sub DELETE
3978
{
3979
0
0
carp ("Cannot DELETE a field from a database record") ;
3980
}
3981
3982
## ----------------------------------------------------------------------------
3983
3984
sub CLEAR ($)
3985
3986
0
0
{
3987
#carp ("Cannot DELETE all fields from a database record") ;
3988
}
3989
3990
## ----------------------------------------------------------------------------
3991
##
3992
## report the cleanless of the row
3993
##
3994
3995
0
0
sub Dirty { return $_[0]->{'*dirty'} }
3996
3997
## ----------------------------------------------------------------------------
3998
##
3999
## Flush data to database if row is dirty
4000
##
4001
4002
4003
sub Flush
4004
4005
{
4006
0
0
my $self = shift ;
4007
0
my $rs = $self -> {'*Recordset'} ;
4008
4009
0
0
return 1 if (!$rs) ;
4010
4011
0
0
if ($self -> {'*dirty'})
4012
{
4013
0
my $rc ;
4014
0
0
print DBIx::Recordset::LOG "DB: Row::Flush id=$rs->{'*Id'} $self\n" if ($rs->{'*Debug'} > 3) ;
4015
4016
0
my $dat = $self -> {'*upd'} ;
4017
0
0
if ($self -> {'*new'})
4018
{
4019
0
$rc = $rs -> Insert ($dat) ;
4020
}
4021
else
4022
{
4023
0
my $pko ;
4024
0
my $pk = $rs -> {'*PrimKey'} ;
4025
0
0
0
$dat->{$pk} = \($self -> {'*data'}{$pk}) if ($pk && !exists ($dat->{$pk})) ;
4026
#carp ("Need primary key to update record") if (!exists($self -> {"=$pk"})) ;
4027
0
0
if (!exists($self -> {'*PrimKeyOrgValue'}))
0
4028
{
4029
0
$rc = $rs -> Update ($dat) ;
4030
}
4031
elsif (ref ($pko = $self -> {'*PrimKeyOrgValue'}) eq 'HASH')
4032
{
4033
0
$rc = $rs -> Update ($dat, $pko) ;
4034
}
4035
else
4036
{
4037
0
$rc = $rs -> Update ($dat, {$pk => $pko} ) ;
4038
}
4039
0
0
0
if ($rc != 1 && $rc ne '')
4040
{ # must excatly be one row!
4041
0
0
print DBIx::Recordset::LOG "DB: ERROR: Row Update has updated $rc rows instead of one ($rs->{'*LastSQLStatement'})\n" if ($rs->{'*Debug'}) ;
4042
#$rs -> savecroak ("DB: ERROR: Row Update has updated $rc rows instead of one ($rs->{'*LastSQLStatement'})") ;
4043
}
4044
}
4045
4046
4047
0
delete $self -> {'*new'} ;
4048
0
delete $self -> {'*dirty'} ;
4049
0
$self -> {'*upd'} = {} ;
4050
}
4051
4052
0
my $k ;
4053
my $v ;
4054
0
my $lrs ;
4055
0
my $rname ;
4056
# "each" is not reentrant !!!!!!!!!!!!!!
4057
#while (($k, $v) = each (%{$rs -> {'*Links'}}))
4058
0
foreach $k (keys %{$rs -> {'*Links'}})
0
4059
{ # Flush linked tables
4060
4061
0
0
if ($lrs = $self->{'*data'}{$k})
4062
{
4063
0
$rname = '' ;
4064
0
0
$rname = eval {ref ($$lrs)} || '' ;
4065
0
0
${$lrs} -> Flush () if ($rname eq 'DBIx::Recordset') ; #if (defined ($lrs) && ref ($lrs) && defined ($$lrs) && ) ;
0
4066
}
4067
}
4068
4069
0
return 1 ;
4070
}
4071
4072
4073
4074
## ----------------------------------------------------------------------------
4075
4076
sub DESTROY
4077
4078
{
4079
0
0
my $self = shift ;
4080
0
my $orgerr = $@ ;
4081
0
local $@ ;
4082
4083
eval
4084
0
{
4085
4086
{
4087
0
local $^W = 0 ;
0
4088
0
0
0
print DBIx::Recordset::LOG "DB: Row::DESTROY\n" if ($DBIx::Recordset::Debug > 2 || $self -> {'*Recordset'} -> {'*Debug'} > 3) ;
4089
}
4090
4091
0
$self -> Flush () ;
4092
} ;
4093
0
0
0
if (!$orgerr && $@)
0
0
4094
{
4095
0
Carp::croak $@ ;
4096
}
4097
elsif ($orgerr && $@)
4098
{
4099
0
warn $@ ;
4100
}
4101
}
4102
4103
4104
################################################################################
4105
4106
1;
4107
__END__