File Coverage

return($s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-fields}->{$s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-ids}->{$ffh->{fieldId}}})

1217

if $ff && !$fu && $ffh && $ffh->{fieldId}

1218

&& $s->{'-meta-sql'}

1219

&& $s->{'-meta-sql'}->{-forms}

1220

&& $s->{'-meta-sql'}->{-forms}->{$f}

1221

&& $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-ids}

1222

&& $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-ids}->{$ffh->{fieldId}};

1223

my $tn =!$f

1224

? $f

1225

: $s->{-sqlntbl}

1226

? &{$s->{-sqlntbl}($s, $f)}

1227

: $s->{-sqlname}

1228

? &{$s->{-sqlname}($s, $f)}

1229

: sqlnesc($s, $f);

1230

return($tn) if !$f ||!$tn;

1231

$s->{'-meta-sql'} ={} if !$s->{'-meta-sql'};

1232

$s->{'-meta-sql'}->{-forms} ={} if !$s->{'-meta-sql'}->{-forms};

1233

while ($s->{'-meta-sql'}->{$tn} && ($s->{'-meta-sql'}->{$tn}->{formName} ne $f)) {

1234

$tn =$s->{-sqlninc} ? &{$s->{-sqlninc}}($s, $tn) : sqlninc($s, $tn);

1235

}

1236

if (!$s->{'-meta-sql'}->{$tn}) {

1237

$s->{'-meta-sql'}->{$tn} ={formName=>$f, -cols=>{}, -fields=>{}, -ids=>{}, timestamp=>time()};

1238

$s->{'-meta-sql'}->{-forms}->{$f} =$tn;

1239

}

1240

elsif ($fu) {

1241

$s->{'-meta-sql'}->{$tn}->{formName} =$f;

1242

$s->{'-meta-sql'}->{-forms}->{$f} =$tn;

1243

}

1244

return($tn) if !$ff;

1245

my $tc =!$ff

1246

? $ff

1247

: $ffh && $ffh->{fieldId}

1248

&& $s->{'-meta-sql'}->{$tn}

1249

&& $s->{'-meta-sql'}->{$tn}->{-ids} && $s->{'-meta-sql'}->{$tn}->{-ids}->{$ffh->{fieldId}}

1250

? $s->{'-meta-sql'}->{$tn}->{-ids}->{$ffh->{fieldId}}

1251

: $s->{-sqlncol}

1252

? &{$s->{-sqlncol}($s, $ff)}

1253

: $s->{-sqlname}

1254

? &{$s->{-sqlname}($s, $ff)}

1255

: sqlnesc($s, $ff);

1256

return($tc) if !$tc;

1257

while ($s->{'-meta-sql'}->{$tn}->{-cols}->{$tc} && ($s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}->{fieldName} ne $ff)) {

1258

$tc =$s->{-sqlninc} ? &{$s->{-sqlninc}}($s, $tc) : sqlninc($s, $tc);

1259

}

1260

if ($fu ||!$s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}) {

1261

my $flh =$s->{-meta}->{$f}->{-fields}->{$ff}->{limit};

1262

my $tch ={COLUMN_NAME => $tc

1263

, 'fieldName'=>$ff

1264

, 'dataType' => $ffh->{dataType}

1265

, 'timestamp'=>$s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}

1266

&& $s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}->{'timestamp'}

1267

|| time()

1268

, $ffh && $ffh->{fieldId}

1269

? ('fieldId' => $ffh->{fieldId})

1270

: ()

1271

, !$ffh ||!$ffh->{dataType}

1272

? ()

1273

: $ffh->{dataType} eq 'integer'

1274

? (TYPE_NAME => 'int')

1275

: $ffh->{dataType} eq 'real'

1276

? (TYPE_NAME => 'float')

1277

: $ffh->{dataType} eq 'decimal'

1278

? (TYPE_NAME => $ffh->{dataType}

1279

, $flh

1280

? ($flh->{precision} ? (DECIMAL_DIGITS => $flh->{precision}) : ()

1281

,$flh->{rangeHigh} ? (COLUMN_SIZE => length($flh->{rangeHigh})) : ()

1282

)

1283

: ()

1284

)

1285

: $ffh->{dataType} eq 'char'

1286

&& (!$flh || !$flh->{maxLength} || ($flh->{maxLength} >255))

1287

? (TYPE_NAME => 'text')

1288

: 0 && ($ffh->{dataType} eq 'char') && $ffh->{indexUnique}

1289

? (TYPE_NAME => 'char'

1290

, $flh && $flh->{maxLength}

1291

? (COLUMN_SIZE => $flh->{maxLength})

1292

: ()

1293

)

1294

: $ffh->{dataType} eq 'char'

1295

? (TYPE_NAME=>'varchar' # $ffh->{dataType}

1296

, $flh && $flh->{maxLength}

1297

? (COLUMN_SIZE => $flh->{maxLength})

1298

: ()

1299

)

1300

: $ffh->{dataType} eq 'diary'

1301

? (TYPE_NAME => 'text')

1302

: $ffh->{dataType} eq 'time'

1303

? (TYPE_NAME => 'datetime' # !'int'

1304

#,COLUMN_SIZE=>19,DECIMAL_DIGITS=>0

1305

)

1306

: $ffh->{dataType} eq 'enum'

1307

? (TYPE_NAME => 'int')

1308

: ()

1309

, $ffh && $ffh->{fieldId}

1310

&& (($ffh->{fieldId} =~/^(?:1)$/) || $ffh->{indexUnique})

1311

? (IS_PK => $ffh->{fieldId})

1312

: ()

1313

, $ffh && $ffh->{fieldMap}

1314

&& $ffh->{fieldMap}->{fieldType}

1315

&& ($ffh->{fieldMap}->{fieldType} ==2)

1316

&& $ffh->{fieldMap}->{join}

1317

&& (($ffh->{fieldMap}->{join}->{schemaIndex}||0) !=0)

1318

? (IS_JOINED => ($ffh->{fieldMap}->{join}->{realId} || 1))

1319

: ()

1320

, !$ffh ||!$ffh->{option}

1321

? ()

1322

: $ffh->{option} ==1

1323

? ()

1324

: $ffh->{option} ==2

1325

? (NULLABLE => 1)

1326

: $ffh->{option} ==4

1327

? (DISPLAY_ONLY => 1)

1328

: ()

1329

, $ffh && $ffh->{fieldId} && ($ffh->{fieldId} ==6)

1330

? (IS_TIMESTAMP => 1)

1331

: ()

1332

};

1333

$s->{'-meta-sql'}->{$tn}->{-cols}->{$tc} =$tch;

1334

$s->{'-meta-sql'}->{$tn}->{-fields}->{$ff} =$tc;

1335

$s->{'-meta-sql'}->{$tn}->{-ids}->{$ffh->{fieldId}} =$tc

1336

if $ffh->{fieldId};

1337

}

1338

$tc

1339

}

1340

1341

1342

sub ars_errstr {# Last ARS error

1343

$ARS::ars_errstr

1344

}

1345

1346

1347

1348

sub schema { # Schema by form name

1349

# (schema) -> {schema descr}

1350

# () -> {schemaName=>{descr}}

1351

$_[1]

1352

? $_[0]->{-meta}->{ref($_[1]) ? $_[1]->{schemaName} : $_[1]}

1353

: $_[0]->{-meta};

1354

}

1355

1356

1357

sub schfld { # Schema of field

1358

# (schema, field) -> {field descr}

1359

# ({schemaName=>name, fieldName=>name}) -> {field descr}

1360

# (schema) -> {field=>descr}

1361

ref($_[1])

1362

? $_[0]->{-meta}->{$_[1]->{schemaName}}->{-fields}->{$_[1]->{fieldName}}

1363

: $_[2]

1364

? $_[0]->{-meta}->{$_[1]}->{-fields}->{$_[2]}

1365

: $_[0]->{-meta}->{$_[1]}->{-fields}

1366

}

1367

1368

1369

sub schid { # Schema info by field id

1370

# (schema, fieldId) -> {fieldName=>'name', FieldId=>id}

1371

# () -> rearranged self

1372

$_[0]->{-metaid}->{$_[2]}

1373

|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}

1374

|| &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schid',$_[1],$_[2]))

1375

}

1376

1377

1378

sub schdn { # Schema info by field distiguished name

1379

# (schema, fieldName) -> {fieldName=>'name', FieldId=>id}

1380

(($_[2] =~/^\d+$/)

1381

&& ($_[0]->{-metaid}->{$_[2]}

1382

|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}))

1383

|| $_[0]->{-metadn}->{$_[2]}

1384

|| $_[0]->{-meta}->{$_[1]}->{-fields}->{$_[2]}

1385

|| &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schdn',$_[1],$_[2]))

1386

}

1387

1388

1389

sub schdi { # Schema info by field Id

1390

# (schema, fieldId) -> {fieldName=>'name', FieldId=>id} || undef

1391

$_[0]->{-metaid}->{$_[2]}

1392

|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}

1393

}

1394

1395

1396

sub schlbls { # Enum field {values => labels}

1397

# (schema, fieldId) -> {value=>label,...}

1398

my($s,$f,$ff) =@_;

1399

$ff =ref($ff) ? $ff

1400

: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)

1401

: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}

1402

: $s->{-meta}->{$f}->{-fields}->{$ff};

1403

if ($ff && !$ff->{-hashOut} && ($ff->{dataType} eq 'enum')) {

1404

my $et =ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'

1405

? $ff->{'limit'}->{'enumLimits'}

1406

: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}

1407

? $ff->{'limit'}->{'enumLimits'}->{'regularList'}

1408

: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}

1409

? $ff->{'limit'}->{'enumLimits'}->{'customList'}

1410

: undef;

1411

if (!$et) {}

1412

elsif (!ref($et->[0])) {

1413

$ff->{-hashOut} ={map {($_ => $et->[$_])} (0..$#$et)}

1414

}

1415

elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {

1416

$ff->{-hashOut} ={map {($et->[$_]->{itemNumber} => $et->[$_]->{itemName})} (0..$#$et)}

1417

}

1418

}

1419

$ff && $ff->{-hashOut}

1420

}

1421

1422

1423

1424

sub schlblsl { # Enum field {values => labels localised}

1425

# (schema, fieldId) -> {value=>localised label,...}

1426

my($s,$f,$ff) =@_;

1427

$ff =ref($ff) ? $ff

1428

: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)

1429

: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}

1430

: $s->{-meta}->{$f}->{-fields}->{$ff};

1431

$ff->{fieldLbvl} ? {split /\\+/, substr($ff->{fieldLbvl},1)} : schlbls($s,$f,$ff)

1432

}

1433

1434

1435

1436

sub schvals { # Enum field [values]

1437

# (schema, fieldId) -> [value,...]

1438

my($s,$f,$ff) =@_;

1439

$ff =ref($ff) ? $ff

1440

: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)

1441

: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}

1442

: $s->{-meta}->{$f}->{-fields}->{$ff};

1443

if ($ff && !$ff->{-listVals} && ($ff->{dataType} eq 'enum')) {

1444

my $et =ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'

1445

? $ff->{'limit'}->{'enumLimits'}

1446

: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}

1447

? $ff->{'limit'}->{'enumLimits'}->{'regularList'}

1448

: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}

1449

? $ff->{'limit'}->{'enumLimits'}->{'customList'}

1450

: undef;

1451

if (!$et) {}

1452

elsif (!ref($et->[0])) {

1453

$ff->{-listVals} =[0..$#$et]

1454

}

1455

elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {

1456

$ff->{-listVals} =[map {$et->[$_]->{itemNumber}} (0..$#$et)]

1457

}

1458

}

1459

$ff && $ff->{-listVals}

1460

}

1461

1462

1463

1464

sub strOut { # Convert field value for output, using '-meta'

1465

# (schema, fieldId, fieldValue) -> fieldValue

1466

my($s,$f,$ff,$v) =@_;

1467

$ff =ref($ff) ? $ff : $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff} : $s->{-meta}->{$f}->{-fields}->{$ff};

1468

if (!defined($v) ||!$ff ||!$s->{-strFields}) {

1469

}

1470

elsif ($ff->{fieldLbvl} && ($s->{-strFields} ==2) && ($ff->{fieldLbvl} =~/\\\Q$v\E\\([^\\]+)/)) {

1471

$v =$1

1472

}

1473

elsif ($ff->{-hashOut}) {

1474

if (exists($ff->{-hashOut}->{$v})) {

1475

$v =$ff->{-hashOut}->{$v}

1476

}

1477

else {

1478

# return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strOut',$f,$ff->{fieldName},$v)))

1479

}

1480

}

1481

elsif ($ff->{dataType} eq 'enum') {

1482

schlbls(@_);

1483

$v =strOut(@_) if $ff->{-hashOut};

1484

}

1485

elsif ($ff->{dataType} eq 'time') {

1486

$v =strtime($s,$v)

1487

}

1488

1489

}

1490

1491

1492

sub strIn { # Convert input field value to internal, using '-meta'

1493

# (schema, fieldId, fieldValue) -> fieldValue

1494

my($s,$f,$ff,$v) =@_;

1495

$ff =ref($ff) ? $ff : $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff} : $s->{-meta}->{$f}->{-fields}->{$ff};

1496

if (!defined($v) ||!$ff ||!$s->{-strFields}) {

1497

}

1498

elsif ($v =~/^\d+$/) {

1499

}

1500

elsif ($ff->{fieldLbvl} && ($ff->{fieldLbvl} =~/\\(\d+)\\\Q$v\E(?:\\|$)/)) {

1501

# && ($s->{-strFields} ==2)

1502

$v =$1

1503

}

1504

elsif ($ff->{-hashIn}) {

1505

if (exists($ff->{-hashIn}->{$v})) {

1506

$v =$ff->{-hashIn}->{$v};

1507

}

1508

else {

1509

return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strIn',$f,$ff->{fieldName},$v)))

1510

}

1511

}

1512

elsif ($ff->{dataType} eq 'enum') {

1513

my $et = ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'

1514

? $ff->{'limit'}->{'enumLimits'}

1515

: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}

1516

? $ff->{'limit'}->{'enumLimits'}->{'regularList'}

1517

: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}

1518

? $ff->{'limit'}->{'enumLimits'}->{'customList'}

1519

: undef;

1520

if (!$et) {}

1521

elsif (!ref($et->[0])) {

1522

$ff->{-hashIn} ={map {($et->[$_] => $_)} (0..$#$et)};

1523

$v =strIn(@_);

1524

}

1525

elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {

1526

$ff->{-hashIn} ={map {($et->[$_]->{itemName} => $et->[$_]->{itemNumber})} (0..$#$et)};

1527

$v =strIn(@_);

1528

}

1529

else {

1530

$et =undef

1531

}

1532

return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strIn',$f,$ff->{fieldName},$v)))

1533

if $et && ($v !~/^\d+$/);

1534

}

1535

elsif ($ff->{dataType} eq 'time') {

1536

$v =timestr($s,$v);

1537

}

1538

1539

}

1540

1541

1542

sub lsflds { # List fields from '-meta'

1543

# (additional field options)

1544

my ($s, @a) =@_;

1545

@a =('fieldLblc') if !@a;

1546

unshift @a, 'fieldName', 'fieldId', 'dataType', 'option', 'createMode';

1547

map { my $f =$_;

1548

$f =~/^-/

1549

? ()

1550

: map { my $ff =$s->{-meta}->{$f}->{-fields}->{$_};

1551

join("\t", $f

1552

#, $ff->{option} && ($ff->{option} == 4) ? 'ro' : ()

1553

, (map { $_ eq 'fieldLblc'

1554

? join('; '

1555

, map {$ff->{$_} ? $ff->{$_} : ()

1556

} $ff->{$_} ? ('fieldLblc') : ('fieldLbl', 'fieldLbll'), 'fieldLbv', 'fieldLbvl', 'helpText')

1557

: !defined($ff->{$_})

1558

? ''

1559

: $_ eq 'option'

1560

? (!$ff->{$_} ? '' : $ff->{$_} == 4 ? 'r' : $ff->{$_} == 2 ? 'o' : $ff->{$_} == 1 ? 'm' : '')

1561

: $ff->{$_}

1562

} @a[0..$#a]))

1563

} sort keys %{$s->{-meta}->{$f}->{-fields}}

1564

} sort keys %{$s->{-meta}}

1565

}

1566

1567

1568

sub query { # ars_GetListEntry / ars_LoadQualifier

1569

# (-clause=>val) -> list

1570

# (...-for=>sub{}) -> self

1571

# Field Ids translated using -metadn/-metaid

1572

# -from ||-form ||-schema => schema name

1573

# -where || -query ||-qual => search condition

1574

# Syntax:

1575

# 'fieldId' || 'fieldName' - fields

1576

# "string value" - strings

1577

# digits - numeric value, number of seconds as date value

1578

# strIn(form, fieldName, value) - to encode value for '-where'

1579

1580

# -fields => [{fieldId=>1, columnWidth=>9, separator=>"\t"},...

1581

# ,[{fieldName=>name, width=>9},...

1582

# ,[{field=>name|id, width=>9},...] # 128 bytes limit strings

1583

# ||-fields => [fieldId | fieldName,...] # using ars_GetListEntryWithFields()

1584

# ||-fields => '*' | 1 | '*-$', -xfields=>sub{} || [fieldName| fieldId,...]

1585

# ||-fetch => '*' | 1 | [fieldId|fieldName,...] # using ars_GetEntry() for each record

1586

# -order ||-sort => [fieldId, (1||2),...] # 1 - asc, 2 - desc

1587

# [..., fieldName, field=>'desc', field=>'asc',...]

1588

# -limit ||-max => maxRetrieve

1589

# -first ||-start => firstRetrieve

1590

# -for ||-foreach => sub(self, form, id|string, ?{record}){die "last\n", die "next\n"} -> self

1591

# ?-echo=>1

1592

1593

# ars_GetListEntry(ctrl, schema, qualifier, maxRetrieve=0, firstRetrieve=0,...)

1594

# ..., getListFields, sortList,...

1595

# ars_LoadQualifier(ctrl, schema, qualifier string)

1596

1597

# Using the advanced search bar:

1598

# 'Currency Field.VALUE' 'Currency Field' = $NULL$

1599

# ??? BookValue=> {conversionDate=> 1090544110, currencyCode=> 'USD', funcList=> [{currencyCode=> 'USD', value=> '0.00'}, {currencyCode=> 'EUR', value=> ''}, {currencyCode=> 'GBP', value=> ''}, {currencyCode=> 'JPY', value=> ''}, {currencyCode=> 'CAD', value=> ''}], value=> '0.00'}

1600

# 'Status History.Fixed.TIME' < "07/01/99"

1601

# 'Create date' > "10:00:00"

1602

1603

my $s =shift;

1604

my %a =@_;

1605

my $f =$a{-schema} ||$a{-form} ||$a{-from};

1606

my $c =$a{-for} ||$a{-foreach};

1607

1608

if ($a{-fields} && !ref($a{-fields})) {

1609

my $q ='trim|control|table|column|page';

1610

$q .= '|currency|attach' if $a{-fields} =~/^-\$/;

1611

$q .= '|attach' if $a{-fields} =~/^-f/;

1612

$a{-fields} =

1613

[map { my $ff =$s->{-meta}->{$f}->{-fields}->{$_};

1614

!$ff->{dataType} || !$ff->{fieldId}

1615

|| ($ff->{dataType} =~/^($q)/)

1616

|| ($ff->{fieldId} eq '15') # 'Status-History'

1617

# ars_GetListEntryWithFields() -> [ERROR] (ORA-00904: "C15": invalid identifier) (ARERR #552)

1618

|| (!$a{-xfields} ? 0 : ref($a{-xfields}) eq 'CODE' ? &{$a{-xfields}}($s, $ff) : grep {($_ eq $ff->{fieldId}) || ($_ eq $ff->{fieldName})} @{$a{-xfields}})

1619

? ()

1620

: ($ff->{fieldId})

1621

} sort keys %{$s->{-meta}->{$f}->{-fields}}]

1622

}

1623

1624

$a{-fetch} =1 if $a{-fields} && !ref($a{-fields});

1625

delete $a{-fields} if $a{-fetch};

1626

1627

local $s->{-cmd} ="query(" .join(', ',map {!defined($a{$_}) ? () : ref($a{$_}) ? "$_=>" .dsquot($s,$a{$_}) : ("$_=>" .strquot($s,$a{$_}))

1628

} qw(-schema -form -from -fields -fetch -qual -query -where -sort -order -limit -max -maxRetrieve -first -start))

1629

.")";

1630

1631

my $fl = ref($a{-fetch})

1632

? [map {/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}} @{$a{-fetch}}]

1633

: $a{-fields} && ref($a{-fields}->[0])

1634

? [map {ref($_)

1635

? {fieldId=>$_->{fieldId} ||schdn($s,$f, $_->{fieldName} ||$_->{field})->{fieldId}

1636

, separator=>$_->{separator} ||"\t"

1637

, columnWidth=>$_->{columnWidth} ||$_->{width} ||10

1638

}

1639

: {fieldId=>/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}

1640

, separator=>"\t"

1641

, columnWidth=>10

1642

}

1643

} @{$a{-fields}}]

1644

: $a{-fields}

1645

? [map {/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}} @{$a{-fields}}]

1646

: [];

1647

my @fs;

1648

{my ($v, $x, @r) =($a{-sort} ||$a{-order});

1649

@fs = $v

1650

? (map {if (!$x) {$x =$_; @r=()}

1651

elsif(/^(desc|2)$/) {@r =($x=~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId}, 2); $x =undef}

1652

else {@r=($x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId},1); $x=undef if /^(asc|1)$/}

1653

@r} @$v)

1654

: ();

1655

push @fs, $x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId}, 1

1656

if $x}

1657

my $q =$s->_qsubst('',$a{-qual} ||$a{-query} ||$a{-where}, $f);

1658

$s->{-cmd} .=": subst(-from=>'$f'"

1659

.(@$fl ? ',-fields=>' .join(', ', map {ref($_) ? "'" .$_->{fieldId} ."'(" .$_->{columnWidth} .")" : "'$_'"

1660

} @$fl) : '')

1661

.($q ? ",-where=>$q" : '')

1662

.(@fs ? ',-order=>' .join(', ', map {"'$_'"} @fs) : '')

1663

.")"

1664

if 0;

1665

$q =ARS::ars_LoadQualifier($s->{-ctrl}, $f, $q);

1666

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd})))

1667

if !$q;

1668

$s->{-cmd} .=": qual". $s->dsquot(ARS::ars_perl_qualifier($s->{-ctrl}, $q))

1669

if 0;

1670

1671

print $s->cpcon(join(";\n", split /\):\s/, $s->{-cmd})), "\n"

1672

if exists($a{-echo}) ? $a{-echo} : $s->{-echo};

1673

1674

if ($c && $a{-fields} && !ref($a{-fields}->[0])) {

1675

my $id;

1676

local $_;

1677

foreach my $e (ARS::ars_GetListEntryWithFields($s->{-ctrl}, $f, $q

1678

, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0

1679

, $a{-first} ||$a{-start} ||0

1680

, $fl

1681

, @fs)) {

1682

if (!ref($e)) {

1683

$_ =$id =$e

1684

}

1685

elsif (!defined(eval{&$c($s, $f, $_ =$id, entryOut($s, $f, $e))}) && $@) {

1686

last if $@ =~/^last[\r\n]*$/;

1687

next if $@ =~/^next[\r\n]*$/;

1688

return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},'eval(-for)')));

1689

}

1690

}

1691

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},'undef','ars_GetListEntryWithFields')))

1692

if !defined($id) && $ARS::ars_errstr;

1693

return($s);

1694

}

1695

elsif ($c) {

1696

my $i =undef;

1697

local $_ ='';

1698

foreach my $e (ARS::ars_GetListEntry($s->{-ctrl}, $f, $q

1699

, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0

1700

, $a{-first} ||$a{-start} ||0

1701

, $fl

1702

, @fs)) {

1703

if ($i) {

1704

$i =0;

1705

$_ =$_ .($fl->[0]->{separator}) .$e

1706

if $a{-fields};

1707

}

1708

else {

1709

$i =1;

1710

$_ =$e;

1711

1712

}

1713

if (!defined(eval{&$c($s, $f, $_

1714

, $a{-fetch}

1715

? $s->entry(-from=>$f, -id=>$_

1716

, ref($a{-fetch}) ? (-fields => $a{-fetch}) : ())

1717

: ())}) && $@) {

1718

last if $@ =~/^last[\r\n]*$/;

1719

next if $@ =~/^next[\r\n]*$/;

1720

return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},'eval(-for)')));

1721

}

1722

}

1723

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntry')))

1724

if !defined($i) && $ARS::ars_errstr;

1725

return($s)

1726

}

1727

elsif ($a{-fields} && !ref($a{-fields}->[0])) {

1728

my @r =ARS::ars_GetListEntryWithFields($s->{-ctrl}, $f, $q

1729

, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0

1730

, $a{-first} ||$a{-start} ||0

1731

, $fl

1732

, @fs);

1733

if (@r) {

1734

my @rr;

1735

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

1736

push @rr, entryOut($s, $f, $r[$i+1])

1737

}

1738

return(@rr)

1739

}

1740

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntryWithFields')))

1741

if $ARS::ars_errstr;

1742

return(())

1743

}

1744

else {

1745

my @r =ARS::ars_GetListEntry($s->{-ctrl}, $f, $q

1746

, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0

1747

, $a{-first} ||$a{-start} ||0

1748

, $fl

1749

, @fs);

1750

if (@r) {

1751

my @rr;

1752

if ($a{-fields}) {

1753

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

1754

push @rr, $r[$i]

1755

.($fl->[0]->{separator})

1756

. $r[$i+1]

1757

}

1758

}

1759

elsif ($a{-fetch}) {

1760

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

1761

push @rr

1762

, $s->entry(-from=>$f, -id=>$r[$i]

1763

, ref($a{-fetch}) ? (-fields=>$a{-fetch}) : ())

1764

}

1765

}

1766

else {

1767

for (my $i =0; $i <$#r; $i +=2) { push @rr, $r[$i] }

1768

}

1769

return(@rr)

1770

}

1771

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntry')))

1772

if $ARS::ars_errstr;

1773

return(())

1774

}

1775

}

1776

1777

1778

sub _qsubst { # query condition string substitutions

1779

# (''|char, expr string, form) -> translated

1780

my ($s, $c, $q, $f) =@_;

1781

return($q) if !defined($q) ||($q eq '');

1782

my $r ='';

1783

if (!$c) {

1784

while ($q =~/^(.*?)(['"]|#[\w]+[\w\d]+\()(.*)/) {

1785

$r .=$1;

1786

$q =$3;

1787

if (!defined($q)) {

1788

$q =''

1789

}

1790

elsif (substr($2,0,1) eq "'") {

1791

if ($q =~/^([^']+)'(.*)/) {

1792

$q =$2;

1793

my $n =$1;

1794

$r .="'" .($n =~/^\d+$/ ? $n : schdn($s,$f,$n)->{fieldId}) ."'";

1795

}

1796

else {

1797

$r .="'"

1798

}

1799

}

1800

else {

1801

$r .=_qsubst($s, $2, $q, $f)

1802

}

1803

}

1804

$r .=$q if defined($q);

1805

}

1806

elsif ($c eq '(') {

1807

$r =$c;

1808

while ($q =~/^(.*?)([()'"])(.*)/) {

1809

$q =$3;

1810

$r .=$1;

1811

if ($2 eq ')') {$r .=$2; last}

1812

else {$r .=_qsubst($s, $2, $q, $f)}

1813

}

1814

$_[2] =$q;

1815

}

1816

elsif ($c =~/['"]/) {

1817

my $cq =$s->strquot($c);

1818

$cq =substr($cq,1,-1);

1819

$r =$c;

1820

while ($q =~/^(.*?)(\Q$c\E|\Q$cq\E)(.*)/) {

1821

$q =$3;

1822

$r .=$1 .$2;

1823

last if $2 eq $c;

1824

}

1825

$_[2] =$q;

1826

}

1827

elsif ($c eq ',') {

1828

my @r;

1829

while ($q =~/^(.*?)(['"(]|\Q$c\E)(.*)/i) {

1830

$q =$3;

1831

$r .=$1;

1832

if ($2 eq $c) {

1833

push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r);

1834

$r ='';

1835

}

1836

else {

1837

$r .=_qsubst($s, $2, $q, $f);

1838

}

1839

}

1840

$r .=$q;

1841

push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r) if $r ne '';

1842

return(@r)

1843

}

1844

else {

1845

$r =$c .$q

1846

}

1847

1848

}

1849

1850

1851

sub entry { # ars_GetEntry

1852

# (-from=>form, -id=>entryId, ?-for=>{}, ?-fields=>[internalId,...])

1853

# -> {fieldName => value}

1854

# # Field Ids translated using -schdn/-schid

1855

# -from ||-form ||-schema => schema name

1856

# -id => entryId

1857

# -fields => [internalId, fieldName,...]

1858

# -for => {} # steady hash to store each entry fetched

1859

# ?-echo=>1

1860

1861

# ars_GetEntry(ctrl,schema,entry_id,...) -> (internalId => value,...)

1862

# no ars_GetEntryBLOB(ctrl,schema,entry_id,field_id,locType,locFile)

1863

# no ars_EncodeDiary(diaryEntryHash1, ... diaryEntryHashN)

1864

# encoded 'Status-History'

1865

# decoded 'diary'

1866

1867

my ($s, %a) =@_;

1868

my $f =$a{-schema} ||$a{-form} ||$a{-from};

1869

print $s->cpcon("entry(-form=>'$f',-id=>'$a{-id}')\n")

1870

if $s->{-echo} || $a{-echo};

1871

my %r =ARS::ars_GetEntry($s->{-ctrl},$f,$a{-id}

1872

,$a{-fields}

1873

? (map {/^\d+$/ ? $_ : schdn($s, $f, $_)->{fieldId}} @{$a{-fields}})

1874

: ()

1875

);

1876

if (%r) {

1877

my $rr =$a{-for} ||{};

1878

undef(@{$rr}{keys %$rr}) if %$rr;

1879

# @{$rr}{map {schid($s,$f,$_)->{fieldName}} keys %r} =values %r;

1880

# return($rr);

1881

local $_;

1882

local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entry(-form=>'$f',-id=>'$a{-id}')";

1883

foreach my $id (keys %r) {

1884

my $ff =schdi($s,$f,$id);

1885

if ($ff) {

1886

$rr->{$ff->{fieldName}}

1887

= !$s->{-strFields}

1888

? $r{$id}

1889

: $ff->{strOut}

1890

? &{$ff->{strOut}}($s,$f,$ff,$_=$r{$id})

1891

: strOut($s,$f,$id,$r{$id})

1892

}

1893

else {

1894

$rr->{$id} =$r{$id}

1895

}

1896

}

1897

return($rr)

1898

}

1899

return($ARS::ars_errstr

1900

? &{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'entry',-form=>$f,-id=>$a{-id}))

1901

: {})

1902

}

1903

1904

1905

sub entryOut { # Format entry hash ref for output

1906

# (schema, entry, ?sample) -> entry

1907

my ($s, $f, $r, $rr) =@_;

1908

if ($rr) {

1909

undef(@{$rr}{keys %$rr}) if %$rr;

1910

}

1911

else {

1912

$rr ={}

1913

}

1914

local $_;

1915

foreach my $id (keys %$r) {

1916

my $ff =schdi($s,$f,$id);

1917

my $v =$r->{$id};

1918

if ($ff) {

1919

$rr->{$ff->{fieldName}}

1920

= !$s->{-strFields}

1921

? $r->{$id}

1922

: $ff->{strOut}

1923

? &{$ff->{strOut}}($s,$f,$ff,$_=$v)

1924

: strOut($s,$f,$id,$v);

1925

}

1926

else {

1927

$rr->{$id} =$r->{$id}

1928

}

1929

}

1930

$rr

1931

}

1932

1933

1934

sub entryDif { # Diff hash refs

1935

# ({old}, {new}, exclude empty) -> {to update}

1936

my($s, $ds1, $ds2, $ee) =@_;

1937

return(undef) if (ref($ds1) ||'') ne (ref($ds2) ||'');

1938

return(undef) if (ref($ds1) ||'') ne 'HASH';

1939

my ($r, $rr) =({});

1940

foreach my $k (keys %$ds2) {

1941

next if !defined($ds1->{$k}) && !defined($ds2->{$k});

1942

next if (ref($ds1->{$k}) && ref($ds2->{$k}))

1943

&& !dscmp($s,$ds1,$ds2);

1944

next if (defined($ds1->{$k}) && defined($ds2->{$k}))

1945

&& ($ds1->{$k} eq $ds2->{$k});

1946

next if $ee && (!defined($ds2->{$k}) ||($ds2->{$k} eq ''))

1947

&& (!defined($ds1->{$k}) ||($ds1->{$k} eq ''));

1948

$r->{$k} =$ds2->{$k}; $rr =1;

1949

}

1950

$rr ? $r : undef

1951

}

1952

1953

1954

sub entryNew { # New {field => value}

1955

# (-form=>form, field=>value,...) -> {field=>value,...}

1956

# ?'Incident Number'=>1 for 'HPD:Help Desk'

1957

my ($s, %a) =@_;

1958

my $f =$a{-schema} ||$a{-form} ||$a{-into} ||$a{-for};

1959

delete @a{qw(-schema -form -from -into -for)};

1960

local $_;

1961

local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entryNew(-form=>'$f',"

1962

.join(',', map {!defined($a{$_})

1963

? "$_=>undef"

1964

: ref($a{$_})

1965

? ("$_=>" .dsquot($s, $a{$_}))

1966

: ("$_=>" .strquot($s, $a{$_}))

1967

} sort keys %a)

1968

.')';

1969

foreach my $k (%{$s->{-meta}->{$f}->{-fields}}) {

1970

my $ff =$s->{-meta}->{$f}->{-fields}->{$k};

1971

next if !$ff

1972

|| exists($a{$k})

1973

|| ((!defined($ff->{defaultVal}) || ref($ff->{defaultVal}))

1974

&& !$s->{-metaid}->{$ff->{fieldId}}->{defaultVal});

1975

$a{$k} =defined($s->{-metaid}->{$ff->{fieldId}}->{defaultVal})

1976

? $s->{-metaid}->{$ff->{fieldId}}->{defaultVal}

1977

: $ff->{defaultVal};

1978

$a{$k} =$s->{-metaid}->{$ff->{fieldId}}->{strOut}

1979

? &{$s->{-metaid}->{$ff->{fieldId}}->{strOut}}($s,$f,$s->{-metaid}->{$ff->{fieldId}},$_=$a{$k})

1980

: strOut($s, $f, $ff->{fieldId},$_=$a{$k})

1981

if $s->{-strFields};

1982

}

1983

if ($f eq 'HPD:Help Desk') {

1984

if ($a{'Incident Number'} && (length($a{'Incident Number'}) ==1)) {

1985

$a{'Incident Number'} =$s->entryIns(-form=>'HPD:CFG Ticket Num Generator', 'DataTags'=>'za')

1986

}

1987

elsif (defined($a{'Incident Number'}) && !$a{'Incident Number'}) {

1988

delete $a{'Incident Number'}

1989

}

1990

}

1991

\%a

1992

}

1993

1994

1995

sub entryIns { # ars_CreateEntry

1996

# (-form=>form, field=>value) -> id

1997

# ?-echo=>1

1998

# ?'Incident Number'=>1 for 'HPD:Help Desk'

1999

my ($s, %a) =@_;

2000

my $f =$a{-schema} ||$a{-form} ||$a{-into};

2001

my $r;

2002

print $s->cpcon("entryIns(-form=>'$f')\n")

2003

if exists($a{-echo}) ? $a{-echo} : $s->{-echo};

2004

delete @a{qw(-schema -form -from -into -echo)};

2005

local $_;

2006

local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entryIns(-form=>'$f',"

2007

.join(',', map {!defined($a{$_})

2008

? "$_=>undef"

2009

: ref($a{$_})

2010

? ("$_=>" .dsquot($s, $a{$_}))

2011

: ("$_=>" .strquot($s, $a{$_}))

2012

} sort keys %a)

2013

.')';

2014

%a = map { my ($k, $v) =($_, $a{$_});

2015

if ($k !~/^\d+$/) {

2016

my $ff =schdn($s,$f,$k);

2017

$k =$ff->{fieldId};

2018

$v =$ff->{strIn}

2019

? &{$ff->{strIn}}($s,$f,$ff,$_=$v)

2020

: strIn($s,$f,$k,$v)

2021

if $s->{-strFields};

2022

}

2023

($k => $v)

2024

} keys %a;

2025

delete $s->{-entryNo};

2026

if ($f eq 'HPD:Help Desk') {

2027

my $ii=schdn($s,$f,'Incident Number')->{fieldId};

2028

$a{$ii} =$s->entryIns(-form=>'HPD:CFG Ticket Num Generator', 'DataTags'=>'za')

2029

if length($a{$ii}) <2;

2030

$s->{-entryNo} =$a{$ii};

2031

$r =ARS::ars_CreateEntry($s->{-ctrl}, $f, %a)

2032

}

2033

else {

2034

$r =$s->{-entryNo} =ARS::ars_CreateEntry($s->{-ctrl}, $f, %a)

2035

}

2036

if (!$r) {

2037

my $t =$s->efmt($ARS::ars_errstr,$s->{-cmd});

2038

return(&{$s->{-die}}($t)) if !$r && $ARS::ars_errstr;

2039

# warn($t) if !$r && !$ARS::ars_errstr;

2040

}

2041

$r ||$s

2042

}

2043

2044

2045

sub entryUpd { # ars_SetEntry(ctrl,schema,entry_id,getTime,...)

2046

# (-form=>form, -id=>entryId, field=>value) -> id

2047

# ?-echo=>1

2048

2049

# ??? ARMergeEntry()/ars_MergeEntry(ctrl, schema, mergeType, ...)

2050

# ??? ars_EncodeDiary(diaryEntryHash1, ... diaryEntryHashN)

2051

2052

my ($s, %a) =@_;

2053

my $f =$a{-schema} ||$a{-form} ||$a{-into};

2054

my $id=$a{-id};

2055

print $s->cpcon("entryUpd(-form=>'$f',-id=>'$id')\n")

2056

if exists($a{-echo}) ? $a{-echo} : $s->{-echo};

2057

delete @a{qw(-schema -form -from -into -id -echo)};

2058

local $_;

2059

local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')

2060

."entryUpd(-form=>'$f',-id=>'$id',"

2061

.join(',', map {!defined($a{$_})

2062

? "$_=>undef"

2063

: ref($a{$_})

2064

? ("$_=>" .dsquot($s, $a{$_}))

2065

: ("$_=>" .strquot($s, $a{$_}))

2066

} sort keys %a)

2067

.')';

2068

%a = map { my ($k, $v) =($_, $a{$_});

2069

if ($k !~/^\d+$/) {

2070

my $ff =schdn($s,$f,$k);

2071

$k =$ff->{fieldId};

2072

$v =$ff->{strIn}

2073

? &{$ff->{strIn}}($s,$f,$ff,$_=$v)

2074

: strIn($s,$f,$k,$v)

2075

if $s->{-strFields}

2076

}

2077

($k => $v)

2078

} keys %a;

2079

my $r =ARS::ars_SetEntry($s->{-ctrl}, $f, $id, 0, %a);

2080

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr, $s->{-cmd})))

2081

if !$r && $ARS::ars_errstr;

2082

$id

2083

}

2084

2085

2086

sub entryDel { # ars_DeleteEntry

2087

# (-form=>form, -id=>entryId) -> id

2088

# ?-echo=>1

2089

my ($s, %a) =@_;

2090

my $f =$a{-schema} ||$a{-form} ||$a{-from} ||$a{-into};

2091

my $id=$a{-id};

2092

print $s->cpcon("entryDel(-form=>'$f',-id=>'$id')\n")

2093

if exists($a{-echo}) ? $a{-echo} : $s->{-echo};

2094

delete @a{qw(-schema -form -from -into -id -echo)};

2095

my $r =ARS::ars_DeleteEntry($s->{-ctrl}, $f, $id);

2096

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr

2097

,"entryDel(-form=>'$f',-id=>'$id')")))

2098

if !$r && $ARS::ars_errstr;

2099

$id

2100

}

2101

2102

2103

sub entryBLOB { # BLOB field retrieve/update

2104

# (-form=>form, -id=>entryId, -field=>fieldId|fieldName

2105

# ,?-set=>data

2106

# ,?-file=>filePath, ?-set=>boolean

2107

my ($s, %a) =@_;

2108

my $f =$a{-schema} ||$a{-form} ||$a{-from} ||$a{-into};

2109

my $eu =!$a{-file} ? exists($a{-set}) : exists($a{-set}) ? $a{-set} : $a{-into};

2110

if ($eu) {

2111

return($s->entryUpd(-form=>$f, -id=>$a{-id}

2112

, exists($a{-echo}) ? (-echo=>$a{-echo}) : ()

2113

, $a{-field}

2114

, {$a{-file}

2115

? ('file'=>$a{-file}, 'size'=> -s $a{-file})

2116

: ('buffer'=>$a{-set}, 'size'=> length($a{-set}))

2117

}))

2118

}

2119

else {

2120

my $r =ARS::ars_GetEntryBLOB($s->{-ctrl}, $f, $a{-id}

2121

,$a{-field} =~/^\d+$/ ? $a{-field} : schdn($s,$f,$a{-field})->{fieldId}

2122

,$a{-file} ? (ARS::AR_LOC_FILENAME(), $a{-file}) : (ARS::AR_LOC_BUFFER()));

2123

return(&{$s->{-die}}($s->efmt($ARS::ars_errstr

2124

,"entryBLOB(-form=>'$f',-id=>'" .$a{-id} ."',-field=>" .$a{-field} ."')")))

2125

if !defined($r) && $ARS::ars_errstr;

2126

return(!$a{-file} ? $r : $r ? $a{-id} : $r)

2127

}

2128

}

2129

2130

2131

sub dbi { # DBI connection object

2132

return($_[0]->{-dbi}) if $_[0]->{-dbi};

2133

dbiconnect(@_)

2134

}

2135

2136

2137

sub dbiconnect {# DBI connect to any database

2138

# (-dbiconnect=>[]) -> dbi object

2139

set(@_);

2140

set($_[0],-die=>'Carp') if !$_[0]->{-die};

2141

print $_[0]->cpcon("dbiconnect()\n")

2142

if $_[0]->{-echo};

2143

eval('use DBI; 1') ||return(&{$_[0]->{-die}}($_[0]->efmt('No DBI')));

2144

$_[0]->{-dbi} =DBI->connect(ref($_[0]->{-dbiconnect}) ? @{$_[0]->{-dbiconnect}} : $_[0]->{-dbiconnect})

2145

|| &{$_[0]->{-die}}($_[0]->efmt(DBI->errstr,undef,undef,'dbiconnect') ."\n");

2146

}

2147

2148

2149

sub dbiquery { # DBI query

2150

# (dbi query args) -> dbi cursor object

2151

# (-echo=>1,...)

2152

my($s, @q) =@_;

2153

my(%a); while ($#q && ($q[0] =~/^-/)) {$a{$q[0]} =$q[1]; shift @q; shift @q};

2154

print $s->cpcon("dbiquery($q[0])\n")

2155

if exists($a{-echo}) ? $a{-echo} : $s->{-echo};

2156

my $op =$s->{-dbi}->prepare(@q)

2157

|| return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbiprepair',@q)));

2158

$op->execute()

2159

|| return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbiexecute',@q)));

2160

$op;

2161

}

2162

2163

2164

sub dbido { # DBI do

2165

# (dbi do args) -> dbi cursor object

2166

# (-echo=>1,...)

2167

my($s, @q) =@_;

2168

my(%a); while ($#q && ($q[0] =~/^-/)) {$a{$q[0]} =$q[1]; shift @q; shift @q};

2169

print $s->cpcon("dbiquery($q[0])\n")

2170

if exists($a{-echo}) ? $a{-echo} : $s->{-echo};

2171

$s->{-dbi}->do(@q)

2172

|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbido',@q));

2173

}

2174

2175

2176

sub dbierrstr { # Last DBI error

2177

$_[0]->{-dbi}->errstr

2178

}

2179

2180

2181

sub dbitables { # DBI tables array

2182

my ($s, $sch, $tbl) =@_;

2183

my @t =$s->dbi()->tables('',$sch||$s->{-sqlschema}||'', $tbl||'%');

2184

if (!scalar(@t)

2185

&& (((ref($s->{-dbiconnect}) ? $s->{-dbiconnect}->[0] : $s->{-dbiconnect})||'') =~/^dbi:ADO:/i)) {

2186

$sch =$sch||$s->{-sqlschema};

2187

@t =$sch

2188

? (map {$_ =~/\."*\Q$sch\E"*\./i ? ($_) : ()} $s->dbi()->tables())

2189

: $s->dbi()->tables();

2190

}

2191

2192

}

2193

2194

2195

sub dbicols { # DBI table columns

2196

my ($s, $sch, $tbl) =@_;

2197

# my $st =$s->dbiquery('SHOW COLUMNS FROM ' .($sch ? $sch .'.' : '') .$tbl);

2198

my $st =$s->dbi()->column_info('',$sch||$s->{-sqlschema}||'', $tbl||'','%');

2199

@{$st->fetchall_arrayref({})}

2200

}

2201

2202

2203

sub dbitypespc { # DBI column type spec

2204

my ($s, $d) =@_;

2205

($d->{'TYPE_NAME'} ||'unknown')

2206

.($d->{'COLUMN_SIZE'}

2207

? ' (' .join(',', map {defined($d->{$_}) ? $d->{$_} : ()

2208

} 'COLUMN_SIZE', 'DECIMAL_DIGITS') .')'

2209

: '')

2210

2211

}

2212

2213

sub dbidsmetasync { # DBI datastore - sync meta with 'arsmetasql'

2214

my ($s, %arg) =@_; # (-echo)

2215

return(undef) if !$s->{'-meta-sql'};

2216

my $dbt ={map {!$_

2217

? ()

2218

: $_ =~/\."*([^."]+)"*$/

2219

? (lc($1) => 1)

2220

: (lc($_) => 1)

2221

} $s->dbitables()};

2222

foreach my $tbl (sort keys %{$s->{'-meta-sql'}}) {

2223

my @sql;

2224

if ($tbl =~/^-/) {

2225

2226

}

2227

elsif (!$dbt->{$tbl}) {

2228

push @sql, 'CREATE TABLE ' .join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)

2229

." (\n"

2230

.join("\n, "

2231

, map { $s->{'-meta-sql'}->{$tbl}->{-cols}->{$_}->{'TYPE_NAME'}

2232

? '"' .$_ .'" ' .$s->dbitypespc($s->{'-meta-sql'}->{$tbl}->{-cols}->{$_})

2233

.(($s->{'-meta-sql'}->{$tbl}->{-cols}->{$_}->{fieldId}||'') eq '1'

2234

? " PRIMARY KEY"

2235

: $s->{'-meta-sql'}->{$tbl}->{-cols}->{$_}->{IS_PK}

2236

? " UNIQUE"

2237

: '')

2238

: ()

2239

} sort keys %{$s->{'-meta-sql'}->{$tbl}->{-cols}})

2240

.')'

2241

}

2242

else {

2243

my $dbc ={map {

2244

!$_ ||!$_->{COLUMN_NAME}

2245

? ()

2246

: (lc($_->{COLUMN_NAME}) => $_)

2247

} $s->dbicols('',$tbl)};

2248

if (scalar(%$dbc)) {

2249

my (@altc, @addc);

2250

foreach my $col (sort keys %{$s->{'-meta-sql'}->{$tbl}->{-cols}}) {

2251

my $cl =lc($col);

2252

my $cm =$s->{'-meta-sql'}->{$tbl}->{-cols}->{$col};

2253

next if !$cm->{'TYPE_NAME'};

2254

if (!$dbc->{$cl}) {

2255

push @addc, '"' .$col .'" ' .$s->dbitypespc($cm)

2256

}

2257

elsif (($dbc->{$cl}->{'TYPE_NAME'} ne $cm->{'TYPE_NAME'})

2258

|| ($cm->{'TYPE_NAME'} ne 'datetime'

2259

? (($dbc->{$cl}->{'COLUMN_SIZE'}||0) < ($cm->{'COLUMN_SIZE'}||0))

2260

|| (($dbc->{$cl}->{'DECIMAL_DIGITS'}||0) ne ($cm->{'DECIMAL_DIGITS'}||0))

2261

: 0 )

2262

) {

2263

push @altc, '"' .$col .'" ' .$s->dbitypespc($cm)

2264

}

2265

else {

2266

$cm->{COLUMN_SIZE_DB} =$dbc->{$cl}->{'COLUMN_SIZE'}

2267

if ($cm->{COLUMN_SIZE_DB}||0) ne ($dbc->{$cl}->{'COLUMN_SIZE'}||0);

2268

$cm->{DECIMAL_DIGITS_DB} =$dbc->{$cl}->{'DECIMAL_DIGITS'}

2269

if ($cm->{DECIMAL_DIGITS_DB}||0) ne ($dbc->{$cl}->{'DECIMAL_DIGITS'}||0);

2270

}

2271

}

2272

foreach my $r (@addc) {

2273

push @sql

2274

,'ALTER TABLE '

2275

.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)

2276

.' ADD ' .$r;

2277

}

2278

foreach my $r (@altc) {

2279

push @sql

2280

,'ALTER TABLE '

2281

.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)

2282

.' ALTER COLUMN ' .$r;

2283

}

2284

}

2285

}

2286

foreach my $r (@sql) {

2287

print "$r;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2288

$s->dbi()->do($r)

2289

|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$r,undef,'dbidsmetasync'));

2290

}

2291

}

2292

$s;

2293

}

2294

2295

2296

sub dbidsrpl { # DBI datastore - load data from ARS

2297

my ($s, %arg) =@_;

2298

$arg{-form} =$arg{-from} ||$arg{-schema} if !$arg{-form};

2299

$arg{-query} =$arg{-where} ||$arg{-qual} if !$arg{-query};

2300

$arg{-filter}=undef if !$arg{-filter};

2301

$arg{-lim_rf}=300 if !$arg{-lim_rf};

2302

$arg{-lim_or}=40 if !$arg{-lim_or};

2303

$arg{-fields}='*' if !$arg{-fields};

2304

# $arg{-echo}=0;

2305

# $arg{-ckpush}=1; # check db pushes into ARS (_arsobject_insert, _arsobject_update, _arsobject_delete)

2306

# $arg{-ckdel}=0; # check ARS deletes into db

2307

# $arg{-ckupd}=1; # check ARS updates into db

2308

# $arg{-sleep}=0;

2309

# $arg{-pk}=undef;

2310

# $arg{-timestamp}=undef; # field name || 0

2311

# $arg{-unused}=undef;

2312

# $arg{-master}

2313

# $arg{-master_pk}

2314

# $arg{-master_fk}

2315

# $arg{-master_ts}

2316

my $tbl =$s->sqlname($arg{-form});

2317

my $tbc =join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl);

2318

my ($fpk, $fid, $fts, @flds);

2319

my ($ci, $cu, $cd) =(0, 0, 0);

2320

{ my $flds =$s->{'-meta-sql'}->{$tbl}->{-cols};

2321

$fpk = $flds->{$arg{-pk}} if $arg{-pk};

2322

$fts = $flds->{$arg{-timestamp}} if $arg{-timestamp};

2323

foreach my $fn (sort keys %$flds) {

2324

next if !$flds->{$fn}->{fieldName} || !$flds->{$fn}->{COLUMN_NAME}

2325

|| !$flds->{$fn}->{TYPE_NAME};

2326

$fpk =$flds->{$fn} if !$fpk && $flds->{$fn}->{IS_PK}

2327

&& ($flds->{$fn}->{IS_PK} eq '1');

2328

$fid =$flds->{$fn} if !$fid && $flds->{$fn}->{IS_PK}

2329

&& ($flds->{$fn}->{IS_PK} eq '1');

2330

$fts =$flds->{$fn} if !$fts && $flds->{$fn}->{IS_TIMESTAMP};

2331

push @flds, $flds->{$fn};

2332

}

2333

!$fpk && &{$s->{-die}}($s->efmt('PK not found','',undef,'dbidsrpl',$arg{-form}));

2334

$fts =undef if defined($arg{-timestamp}) && !$arg{-timestamp};

2335

# !$fts && &{$s->{-die}}($s->efmt('Timestamp not found','',undef,'dbidsrpl',$arg{-form}));

2336

}

2337

$s->dbi() if !$s->{-dbi};

2338

local $s->{-dbi}->{LongReadLen} =$s->{-dbi}->{LongReadLen} <= 1024 ? 4*64*1024 : $s->{-dbi}->{LongReadLen};

2339

my $vts =$fts && $s->dbiquery('SELECT max(' .$fts->{COLUMN_NAME} .') FROM ' .$tbc)->fetchrow_arrayref();

2340

$vts =$vts && $vts->[0];

2341

my $cts =0;

2342

if ($vts) {

2343

my $sql ='SELECT count(*) FROM ' .$tbc .' WHERE ' .$s->{-dbi}->quote_identifier($fts->{COLUMN_NAME}) .'=' .$s->{-dbi}->quote($vts);

2344

$cts =$s->dbiquery($sql)->fetchrow_arrayref();

2345

$cts =$cts && $cts->[0] ||0;

2346

print "$sql --> $cts;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2347

if (!$cts) {

2348

}

2349

elsif (0 && ($cts > $arg{-lim_rf})) {

2350

$cts -=1;

2351

}

2352

elsif ($cts >= $arg{-lim_rf} *2) {

2353

$cts -=$arg{-lim_rf};

2354

$arg{-lim_rf} *=2;

2355

}

2356

elsif ($cts >= $arg{-lim_rf}) {

2357

$arg{-lim_rf} +=$cts;

2358

$cts =0;

2359

}

2360

else {

2361

$cts =0;

2362

}

2363

$vts =$s->timestr($vts) if $vts =~/\s/;

2364

$vts =$s->timestr($vts) if $vts =~/^(.+)\.0+$/;

2365

}

2366

if ($s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert}

2367

&& (!exists($arg{-ckpush}) ||$arg{-ckpush})) {

2368

local $s->{-strFields} =0;

2369

my $sql ='SELECT * FROM ' .$tbc

2370

.' WHERE _arsobject_insert=1 OR _arsobject_update=1 OR _arsobject_delete=1'

2371

.' ORDER BY ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' asc';

2372

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2373

my $dbq =$s->dbiquery($sql);

2374

my ($rd, @rq) =({});

2375

while (($rd && ($rd =$dbq->fetchrow_hashref())) ||scalar(@rq)) {

2376

if ($rd) {

2377

push @rq, $rd;

2378

next if scalar(@rq) <$arg{-lim_or};

2379

}

2380

else {

2381

next if !scalar(@rq)

2382

}

2383

my $arq =join(' OR '

2384

, map { $_->{$fpk->{COLUMN_NAME}}

2385

&& ($_->{_arsobject_update} ||$_->{_arsobject_delete})

2386

? "'" .$fpk->{fieldName} ."'=" .$s->arsquot($_->{$fpk->{COLUMN_NAME}})

2387

: () } @rq);

2388

my %ars =$arq

2389

? map { ($_->{$fpk->{fieldName}} => $_)

2390

} $s->query(-form=>$arg{-form}

2391

,-fields=>$arg{-fields}

2392

,-echo=>$arg{-echo}

2393

,-query=>join(' AND '

2394

, $arg{-query} ? '(' .$arg{-query} .')' : ()

2395

, "($arq)"))

2396

: ();

2397

foreach my $rd (@rq) {

2398

my $ra =$ars{$rd->{$fpk->{COLUMN_NAME}}};

2399

my $rw ={};

2400

foreach my $f (@flds) {

2401

next if !$f->{fieldName} || !$f->{COLUMN_NAME} || !$f->{TYPE_NAME}

2402

|| !exists($rd->{$f->{COLUMN_NAME}})

2403

|| !$f->{fieldId}

2404

|| $f->{IS_JOINED} ||$f->{DISPLAY_ONLY}

2405

|| $f->{IS_PK}

2406

|| (($f->{fieldId}||'') =~/^(1|2|3|5|6|15|179)$/);

2407

$rd->{$f->{COLUMN_NAME}} =$1

2408

if defined($rd->{$f->{COLUMN_NAME}})

2409

&& ($f->{TYPE_NAME} =~/^(?:datetime|float)$/)

2410

&& ($rd->{$f->{COLUMN_NAME}}=~/^(.+)\.0+$/);

2411

$rd->{$f->{COLUMN_NAME}} =defined($ra->{$f->{fieldName}}) && ($ra->{$f->{fieldName}} =~/\.(\d+)$/)

2412

? sprintf('%.' .length($1) .'f', $rd->{$f->{COLUMN_NAME}})

2413

: $rd->{$f->{COLUMN_NAME}} =~/^(.+)\.0+$/

2414

? $1

2415

: $rd->{$f->{COLUMN_NAME}}

2416

if $ra

2417

&& ($f->{TYPE_NAME} eq 'float')

2418

&& defined($rd->{$f->{COLUMN_NAME}});

2419

$rw->{$f->{fieldName}} =!defined($rd->{$f->{COLUMN_NAME}})

2420

? $rd->{$f->{COLUMN_NAME}}

2421

: $f->{TYPE_NAME} eq 'datetime'

2422

? timestr($s, $rd->{$f->{COLUMN_NAME}})

2423

: $rd->{$f->{COLUMN_NAME}};

2424

}

2425

if ($rd->{_arsobject_delete}) {

2426

$rd->{_arsobject_insert} =$rd->{_arsobject_update} =undef;

2427

next if $arg{-filter}

2428

&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);

2429

sleep($arg{-sleep} ||0);

2430

$cd++;

2431

$s->entryDel(-form=>$arg{-form}, -echo=>$arg{-echo}

2432

,-id=>$rd->{$fid->{COLUMN_NAME}});

2433

}

2434

elsif ($rd->{_arsobject_update}) {

2435

$rd->{_arsobject_insert} =$rd->{_arsobject_delete} =undef;

2436

next if $arg{-filter}

2437

&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);

2438

$rw ={map { !defined($rw->{$_}) && !defined($ra->{$_})

2439

? ()

2440

: !defined($rw->{$_}) ||!defined($ra->{$_})

2441

? ($_ => $rw->{$_})

2442

: $rw->{$_} ne $ra->{$_}

2443

? ($_ => $rw->{$_})

2444

: ()

2445

} keys %$rw}

2446

if $ra;

2447

if (scalar(%$rw)) {

2448

sleep($arg{-sleep} ||0);

2449

$cu++;

2450

$s->entryUpd(-form=>$arg{-form}, -echo=>$arg{-echo}

2451

,-id=>$rd->{$fid->{COLUMN_NAME}}

2452

, %$rw);

2453

}

2454

}

2455

elsif ($rd->{_arsobject_insert}) {

2456

$rd->{_arsobject_update} =$rd->{_arsobject_delete} =undef;

2457

next if $arg{-filter}

2458

&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);

2459

sleep($arg{-sleep} ||0);

2460

$ci++;

2461

$s->entryIns(-form=>$arg{-form}, -echo=>$arg{-echo}

2462

, map {defined($rw->{$_}) ? ($_ => $rw->{$_}) : ()} keys %$rw);

2463

}

2464

my $sql = $rd->{_arsobject_insert} || $rd->{_arsobject_delete}

2465

? ('DELETE FROM ' .$tbc

2466

.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rd->{$fpk->{COLUMN_NAME}}))

2467

: ('UPDATE ' .$tbc .' SET '

2468

.join(', ', map { !exists($rd->{$_})

2469

? ()

2470

: ($s->{-dbi}->quote_identifier($_) .' =NULL')

2471

} '_arsobject_insert','_arsobject_update', '_arsobject_delete')

2472

.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rd->{$fpk->{COLUMN_NAME}}));

2473

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2474

$s->{-dbi}->do($sql)

2475

|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));

2476

}

2477

@rq =();

2478

}

2479

}

2480

if ($arg{-ckdel}) {

2481

my $cnl ='';

2482

my $dbr =[];

2483

while ($dbr) {

2484

my $sql ='SELECT ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME})

2485

.' FROM ' .$tbc

2486

.($cnl ||$s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert}

2487

? ' WHERE ' .join(' AND ', map {$_ ? "($_)" : ()

2488

} ($s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert} ? '_arsobject_insert IS NULL OR _arsobject_insert=0' : '')

2489

, ($cnl ? $s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .'<=' .$s->{-dbi}->quote($cnl) : ''))

2490

: '')

2491

.' ORDER BY 1 desc';

2492

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2493

my $dbq =$s->dbiquery($sql);

2494

my @cnd;

2495

my @rms;

2496

while (($dbr && ($dbr =$dbq->fetchrow_arrayref())) ||scalar(@cnd)) {

2497

if ($dbr) {

2498

push @cnd, $dbr->[0] =~/^([^\s]+)/i ? $1 : $dbr->[0];

2499

}

2500

if ($dbr ? scalar(@cnd) >=$arg{-lim_or} : scalar(@cnd)) {

2501

my %ars =map { ($_->{$fpk->{fieldName}} => 1)

2502

} $s->query(-form=>$arg{-form}

2503

,-fields=>[$fpk->{fieldName}]

2504

,-echo=>$arg{-echo}

2505

,-query=>join(' AND '

2506

, $arg{-query} ? '(' .$arg{-query} .')' : ()

2507

, '(' .join(' OR ', map {"'" .$fpk->{fieldName} ."'=" .$s->arsquot($_)

2508

} @cnd) .')')

2509

);

2510

my @del =map { $ars{$_}

2511

? ()

2512

: !$arg{-filter} || &{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},undef,$_)

2513

? $_

2514

: ()

2515

} @cnd;

2516

if (scalar(@del)) {

2517

$cnl =$del[$#del];

2518

$sql ="DELETE FROM $tbc WHERE "

2519

.join(' OR ', map {$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .'=' .$s->{-dbi}->quote($_)

2520

} @del);

2521

push @rms, $sql;

2522

$cd +=scalar(@del);

2523

}

2524

@cnd =();

2525

sleep($arg{-sleep} ||0);

2526

if (scalar(@del)) {

2527

$dbq->finish();

2528

last;

2529

}

2530

}

2531

}

2532

foreach $sql (@rms) {

2533

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2534

$@ ='Unknown error';

2535

$s->{-dbi}->do($sql)

2536

|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));

2537

}

2538

}

2539

}

2540

if (!exists($arg{-ckupd}) || $arg{-ckupd}) {

2541

my $sqlm=0;

2542

local $s->{-strFields} =0;

2543

my $fpksql ='SELECT * FROM ' .$tbc .' WHERE ' .$fpk->{COLUMN_NAME} .'=';

2544

my $lm;

2545

if ($arg{-master} && $arg{-master_fk} && $fts) {

2546

my $mtb =$s->sqlname($arg{-master});

2547

my $mts =$arg{-master_ts} && ($s->{'-meta-sql'}->{$mtb}->{-fields}->{$arg{-master_ts}} ||$arg{-master_ts});

2548

my $mpk =$arg{-master_pk} && ($s->{'-meta-sql'}->{$mtb}->{-fields}->{$arg{-master_pk}} ||$arg{-master_pk});

2549

my $mfk =$arg{-master_fk} && ($s->{'-meta-sql'}->{$tbl}->{-fields}->{$arg{-master_fk}} ||$arg{-master_fk});

2550

if (!$mts ||!$mpk) {

2551

my $flds =$s->{'-meta-sql'}->{$tbl}->{-cols};

2552

foreach my $fn (sort keys %$flds) {

2553

$mts =$fn if !$mts && $flds->{$fn}->{IS_TIMESTAMP};

2554

$mpk =$fn if !$mpk && $flds->{$fn}->{IS_PK}

2555

&& ($flds->{$fn}->{IS_PK} eq '1');

2556

last if $mts && $mpk;

2557

}

2558

}

2559

my $sql ='SELECT max(d.' .$s->{-dbi}->quote_identifier($fts->{COLUMN_NAME}) .')'

2560

.', max(m.' .$s->{-dbi}->quote_identifier($mts) .')'

2561

.' FROM '

2562

.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)

2563

." m, $tbc d"

2564

.' WHERE m.' .$s->{-dbi}->quote_identifier($mpk)

2565

.'=d.' .$s->{-dbi}->quote_identifier($mfk);

2566

my $mtv = $s->dbiquery($sql)->fetchrow_arrayref();

2567

print "$sql --> " .($mtv ? join(', ', map {$s->{-dbi}->quote(defined($_) ? $_ : 'undef')} @$mtv) : "'undef'") .";\n"

2568

if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2569

$mtv =!$mtv ||!$mtv->[0] ||!$mtv->[1]

2570

? ''

2571

: $mtv->[0] lt $mtv->[1]

2572

? $mtv->[0]

2573

: $mtv->[1];

2574

$sql ='SELECT count(*) FROM '

2575

.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)

2576

.' WHERE '

2577

.$s->{-dbi}->quote_identifier($mts) .'=' .$s->{-dbi}->quote($mtv);

2578

my $mtc =$s->dbiquery($sql)->fetchrow_arrayref();

2579

$mtc =$mtc && $mtc->[0] ||0;

2580

my $mpv =$mtc >=($arg{-lim_rf} -$arg{-lim_rf} *0.1)

2581

? $s->dbiquery('SELECT max(m.' .$s->{-dbi}->quote_identifier($mpk) .'), count(*)'

2582

.' FROM '

2583

.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)

2584

." m, $tbc d"

2585

.' WHERE m.' .$s->{-dbi}->quote_identifier($mpk)

2586

.'=d.' .$s->{-dbi}->quote_identifier($mfk)

2587

.' AND m.' .$s->{-dbi}->quote_identifier($mts) .'=' .$s->{-dbi}->quote($mtv)

2588

)->fetchrow_arrayref()

2589

: '';

2590

$mpv =$mpv && $mpv->[0] ||'';

2591

print "$sql --> $mtc;\n"

2592

if $mpv && (exists($arg{-echo}) ? $arg{-echo} : $s->{-echo});

2593

$sql ='SELECT ' .$s->{-dbi}->quote_identifier($mpk)

2594

.' FROM '

2595

.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)

2596

.($mtv

2597

? ' WHERE ' .$s->{-dbi}->quote_identifier($mts)

2598

.'>=' .$s->{-dbi}->quote($mtv)

2599

.($mpv

2600

? ' AND ' .$s->{-dbi}->quote_identifier($mpk)

2601

.'>=' .$s->{-dbi}->quote($mpv)

2602

: '')

2603

: '')

2604

.' ORDER BY ' .$s->{-dbi}->quote_identifier($mts) .' ASC '

2605

.', ' .$s->{-dbi}->quote_identifier($mpk) .' ASC ';

2606

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2607

$lm =$s->{-dbi}->selectcol_arrayref($sql,{'MaxRows'=>$arg{-lim_rf}});

2608

return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'selectcol_arrayref',$sql)))

2609

if !$lm && $s->{-dbi}->errstr;

2610

# print $s->dsquot($lm),"\n";

2611

# die('TEST')

2612

# -form=>'HPD:HelpDesk_AuditLogSystem'

2613

# ,-master=>'HPD:Help Desk', -master_pk=>'Entry ID',-master_fk=>'Original Request ID', -master_ts=>'Last Modified Date'

2614

}

2615

my ($rw, $rd) =({});

2616

my ($cs, $cw) =($cts,0);

2617

while ($lm ? scalar(@$lm) : 1) {

2618

$cw++;

2619

foreach my $r ($s->query(-form=>$arg{-form}

2620

,-fields=>$arg{-fields}

2621

,-echo=>$arg{-echo}

2622

,$lm

2623

? (-query=>join(' AND '

2624

, $arg{-query} ? '(' .$arg{-query} .')' : ()

2625

, '(' .join(' OR '

2626

, map {"'" .($s->{'-meta-sql'}->{$tbl}->{-cols}->{$arg{-master_fk}} && $s->{'-meta-sql'}->{$tbl}->{-cols}->{$arg{-master_fk}}->{fieldName} || $arg{-master_fk})

2627

."'=\"$_\""

2628

} splice @$lm, 0, $arg{-lim_or}) .')'))

2629

: (-query=>join(' AND ', map {$_ ? "($_)" : ()

2630

} $arg{-query}, $fts && $vts ? "'" .$fts->{fieldName} ."'>=" .$vts : ()

2631

) ||'1=1'

2632

,-limit=>$arg{-lim_rf}

2633

,-start=>$cs)

2634

,-order=>$fts

2635

? [$fts->{fieldName} => 'asc', $fpk->{fieldName} => 'asc']

2636

: [$fpk->{fieldName} => 'asc']

2637

)) {

2638

$cs++;

2639

next if !$r->{$fpk->{fieldName}};

2640

my $sql ='';

2641

$rd =$s->dbiquery($fpksql .$s->{-dbi}->quote($r->{$fpk->{fieldName}}))->fetchrow_hashref();

2642

my $ru;

2643

foreach my $f (@flds) {

2644

next if !$f->{fieldName} || !$f->{COLUMN_NAME} || !$f->{TYPE_NAME}

2645

|| !exists($r->{$f->{fieldName}});

2646

$rw->{$f->{fieldName}} =!defined($r->{$f->{fieldName}})

2647

? $r->{$f->{fieldName}}

2648

: $f->{TYPE_NAME} eq 'datetime'

2649

? strtime($s, $r->{$f->{fieldName}})

2650

: ($f->{dataType} =~/^(?:char)$/) && $f->{COLUMN_SIZE}

2651

? substr($r->{$f->{fieldName}}, 0, $f->{COLUMN_SIZE_DB} ||$f->{COLUMN_SIZE})

2652

: $r->{$f->{fieldName}};

2653

$rd->{$f->{COLUMN_NAME}} =$1

2654

if $rd

2655

&& defined($rd->{$f->{COLUMN_NAME}})

2656

&& ($f->{TYPE_NAME} =~/^(?:datetime|float)$/)

2657

&& ($rd->{$f->{COLUMN_NAME}}=~/^(.+)\.0+$/);

2658

$rd->{$f->{COLUMN_NAME}} =defined($rw->{$f->{fieldName}}) && ($rw->{$f->{fieldName}} =~/\.(\d+)$/)

2659

? sprintf('%.' .length($1) .'f', $rd->{$f->{COLUMN_NAME}})

2660

: $rd->{$f->{COLUMN_NAME}} =~/^(.+)\.0+$/

2661

? $1

2662

: $rd->{$f->{COLUMN_NAME}}

2663

if $rd

2664

&& defined($rd->{$f->{COLUMN_NAME}})

2665

&& ($f->{TYPE_NAME} eq 'float');

2666

$rd->{$f->{COLUMN_NAME}} =substr($rd->{$f->{COLUMN_NAME}}, 0, $f->{COLUMN_SIZE_DB} ||$f->{COLUMN_SIZE})

2667

if $rd

2668

&& defined($rd->{$f->{COLUMN_NAME}})

2669

&& ($f->{dataType} =~/^(?:char)$/) && $f->{COLUMN_SIZE};

2670

$ru =1 if $rd

2671

&& (defined($rd->{$f->{COLUMN_NAME}})

2672

? !defined($rw->{$f->{fieldName}})

2673

|| ($rd->{$f->{COLUMN_NAME}} ne $rw->{$f->{fieldName}})

2674

: defined($rw->{$f->{fieldName}}));

2675

}

2676

if (!$rd) {

2677

next if $arg{-filter}

2678

&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);

2679

$sql ='INSERT INTO ' .$tbc .' ('

2680

.join(', '

2681

, map { !exists($rw->{$_->{fieldName}})

2682

|| !defined($rw->{$_->{fieldName}})

2683

? ()

2684

: $s->{-dbi}->quote_identifier($_->{COLUMN_NAME})

2685

} @flds)

2686

.') VALUES ('

2687

.join(', '

2688

, map { !exists($rw->{$_->{fieldName}})

2689

|| !defined($rw->{$_->{fieldName}})

2690

? ()

2691

: $s->{-dbi}->quote($rw->{$_->{fieldName}})

2692

} @flds)

2693

.')';

2694

$ci++;

2695

}

2696

elsif ($ru) {

2697

next if (!exists($arg{-ckpush}) ||$arg{-ckpush})

2698

&& ($rd->{'_arsobject_insert'}

2699

|| $rd->{'_arsobject_update'}

2700

|| $rd->{'_arsobject_delete'});

2701

next if $arg{-filter}

2702

&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);

2703

$sql ='UPDATE ' .$tbc .' SET '

2704

.join(', '

2705

,(exists($arg{-ckpush}) && !$arg{-ckpush}

2706

&& $s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert}

2707

? '_arsobject_insert=NULL, _arsobject_update=NULL, _arsobject_delete=NULL'

2708

: ())

2709

, map { !exists($rw->{$_->{fieldName}})

2710

? ()

2711

: ($s->{-dbi}->quote_identifier($_->{COLUMN_NAME}) .' ='

2712

.(!defined($rw->{$_->{fieldName}})

2713

? 'NULL'

2714

: $s->{-dbi}->quote($rw->{$_->{fieldName}})

2715

))

2716

} @flds)

2717

.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rw->{$fpk->{fieldName}});

2718

$cu++

2719

}

2720

if ($sql) {

2721

# local $s->{-dbi}->{LongTruncOk} =1;

2722

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2723

$s->{-dbi}->do($sql)

2724

|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));

2725

}

2726

}

2727

if (!$fts && ($cs == $cw *$arg{-lim_rf})) {

2728

sleep($arg{-sleep} ||0);

2729

next;

2730

}

2731

elsif ($lm) {

2732

sleep($arg{-sleep} ||0);

2733

next;

2734

}

2735

last;

2736

}

2737

if ($arg{-unused} && ($fts ? $vts : 1)) {

2738

my $sql ='DELETE FROM ' .$tbc .' WHERE '

2739

.dbidsqq($s

2740

, $vts && $fts ? '(' .$fts->{COLUMN_NAME} .'<' .$s->{-dbi}->quote($s->strtime($vts||0)) .') AND (' .$arg{-unused} .')' : $arg{-unused}

2741

, $s->{'-meta-sql'}->{$tbl});

2742

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2743

my $n= $s->{-dbi}->do($sql)

2744

|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));

2745

$cd +=$n;

2746

}

2747

}

2748

join(', ', map {$_ ? $_ : ()} $ci && "new $ci", $cu && "upd $cu", $cd && "del $cd")

2749

||'up-to-date'

2750

}

2751

2752

2753

sub dbidsquery { # DBI datastore - query data alike ARS

2754

my ($s, %arg) =@_;

2755

# -form => ARS form || -from => sql table name

2756

# -fields=> ARS fields || -select=>sql select list

2757

# -query=> ARS query || -where => sql where

2758

# -order =>

2759

# -filter=> undef

2760

# -undefs=>1

2761

# -strFields=>1|0

2762

my $m =$s->{'-meta-sql'}->{$s->sqlname($arg{-form})};

2763

my $sql =join(' ', 'SELECT'

2764

,(ref($arg{-fields})

2765

? join(', ', map {$s->{-dbi}->quote_identifier($m->{-fields}->{$_} || $m->{-ids}->{$_} || $_)

2766

} @{$arg{-fields}})

2767

: $arg{-fields} && ($arg{-fields} ne '*')

2768

? dbidsqq($s, $arg{-fields}, $m)

2769

: ($arg{-fields} ||$arg{-select} ||'*')

2770

)

2771

,'FROM'

2772

,($arg{-from}

2773

? $arg{-from}

2774

: join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $s->sqlname($arg{-form})))

2775

,($arg{-where}

2776

? 'WHERE ' .$arg{-where}

2777

: $arg{-query}

2778

? 'WHERE ' .dbidsqq($s, $arg{-query}, $m)

2779

: '')

2780

,(ref($arg{-order})

2781

? 'ORDER BY '

2782

.(do{ my $r ='';

2783

my $i =0;

2784

foreach my $e (@{$arg{-order}}) {

2785

$r .= $i && ($e =~/^(asc|1)$/)

2786

? ' asc'

2787

: $i && ($e =~/^(desc|2)$/)

2788

? ' desc'

2789

: (($r ? ',' : '')

2790

.$s->{-dbi}->quote_identifier($m->{-fields}->{$e} || $m->{-ids}->{$e} || $e)

2791

);

2792

$i =!$i;

2793

}

2794

$r})

2795

: $arg{-order}

2796

? ('ORDER BY ' .$arg{-order})

2797

: '')

2798

);

2799

print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};

2800

local $s->{-dbi}->{LongReadLen} =$s->{-dbi}->{LongReadLen} <= 1024 ? 4*64*1024 : $s->{-dbi}->{LongReadLen};

2801

my $h =$s->dbiquery($sql);

2802

my $xu=exists($arg{-undefs}) && !$arg{-undefs};

2803

my $yc=$arg{-select} ||ref($arg{-fields})

2804

|| ($arg{-fields} && ($arg{-fields} eq '*'));

2805

my $ys=defined($arg{-strFields}) ? $arg{-strFields} : $s->{-strFields};

2806

local $s->{-strFields} =defined($arg{-strFields}) ? $arg{-strFields} : $s->{-strFields};

2807

my ($r, $r1, @r);

2808

while ($r =$h->fetchrow_hashref()) {

2809

$r1 ={map { $xu && !defined($r->{$_})

2810

? ()

2811

: $m->{-cols}->{$_} && $m->{-cols}->{$_}->{fieldName} && $m->{-cols}->{$_}->{fieldId}

2812

? ($m->{-cols}->{$_}->{fieldName}

2813

2814

(!defined($r->{$_})

2815

? $r->{$_}

2816

: $ys && ($m->{-cols}->{$_}->{dataType} eq 'enum')

2817

? $s->strOut($arg{-form}, $m->{-cols}->{$_}->{fieldId}, $r->{$_})

2818

: ($m->{-cols}->{$_}->{TYPE_NAME} =~/^(?:datetime|float)$/) && ($r->{$_} =~/^(.+)\.0+$/)

2819

? $1

2820

: $r->{$_}))

2821

: $yc

2822

? ($_ => $r->{$_})

2823

: ()

2824

} keys %$r};

2825

next if $arg{-filter} && !&{$arg{-filter}}($s,$r1);

2826

push @r, $r1;

2827

}

2828

2829

}

2830

2831

2832

sub dbidsqq { # DBI datastore - quote/parse condition to SQL names

2833

my ($s,$sf,$mh) =@_; # (self, query string, default sql metadata)

2834

if (0) {

2835

my $q =substr($s->{-dbi}->quote_identifier(' '),0,1);

2836

$sf =~s/$q([^$q]+)$q\.$q([^$q]+)$q/!$s->{'-meta-sql'}->{-forms}->{$1} ? "?1$q$1${q}.$q$2$q" : $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$1}}->{-fields}->{$2} ? $s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) .'.' .$s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$1}}->{-fields}->{$2}) : $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$1}}->{-ids}->{$2} ? $s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) .'.' .$s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$1}}->{-ids}->{$2}) : "?2$q$1${q}.$q$2$q"/ge;

2837

$sf =~s/$q([^$q]+)$q/$s->{'-meta-sql'}->{-forms}->{$1} ? ($s->{-sqlschema} ? $s->{-dbi}->quote_identifier($s->{-sqlschema}) .'.' : '') .$s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) : $mh->{-fields}->{$1} ? $s->{-dbi}->quote_identifier($mh->{-fields}->{$1}) : $mh->{-ids}->{$1} ? $s->{-dbi}->quote_identifier($mh->{-ids}->{$1}) : "$q$1$q"/ge;

2838

return($sf);

2839

}

2840

my $qs =$s->{-dbi}->quote('w') =~/^([^w]+)w/ ? $1 : "'";

2841

my $qi =$s->{-dbi}->quote_identifier('w') =~/^([^w]+)w/ ? $1 : '"';

2842

my $qsq=$s->{-dbi}->quote("'w") =~/^([^w]+)w/ ? $1 : "''";

2843

my $qiq=$s->{-dbi}->quote_identifier('"w') =~/^([^w]+)w/ ? $1 : '""';

2844

my $qit=$qi .'.' .$qi;

2845

my $sr ='';

2846

my $m =undef;

2847

while ($sf =~/^(.*?)(\Q$qs\E|\Q$qi\E)(.*)/) {

2848

if ($2 eq $qi) {

2849

$sr .=$1 .$2;

2850

$sf =$3;

2851

my ($st,$sn) =('','');

2852

while (1) {

2853

if (!($sf =~/^(.*?)(\Q$qiq\E|\Q$qit\E|\Q$qi\E)(.*)/)) {

2854

return($sr .($st ? $st .$qit : '') .$sn .$sf)

2855

}

2856

elsif ($2 eq $qiq) {

2857

$sn .=$1 .$2;

2858

$sf =$3;

2859

2860

}

2861

elsif ($2 eq $qit) {

2862

$st =$sn .$1;

2863

$sn ='';

2864

$sf =$3;

2865

2866

}

2867

else {

2868

$sn .=$1;

2869

$sf =$3;

2870

$st =$st && $s->{'-meta-sql'}->{-forms}->{$st} || $st;

2871

$sn =$st && $s->{'-meta-sql'}->{$st}

2872

? ($s->{'-meta-sql'}->{$st}->{-fields}->{$sn}

2873

|| $s->{'-meta-sql'}->{$st}->{-ids}->{$sn}

2874

|| $sn)

2875

: ($mh->{-fields}->{$sn}

2876

|| $mh->{-ids}->{$sn}

2877

|| ($s->{'-meta-sql'}->{-forms}->{$sn}

2878

&& (($s->{-sqlschema} ? $s->{-sqlschema} .$qit : '')

2879

.$s->{'-meta-sql'}->{-forms}->{$sn}))

2880

|| $sn);

2881

$sr .=($st ? $st .$qit : '') .$sn .$qi;

2882

last

2883

}

2884

}

2885

}

2886

elsif ($2 eq $qs) {

2887

$sr .=$1 .$2;

2888

$sf =$3;

2889

while (1) {

2890

if (!($sf =~/^(.*?)(\Q$qsq\E|\Q$qs\E)(.*)/)) {

2891

return($sr .$sf)

2892

}

2893

elsif ($2 eq $qsq) {

2894

$sr .=$1 .$2;

2895

$sf =$3;

2896

2897

}

2898

else {

2899

$sr .=$1 .$2;

2900

$sf =$3;

2901

last

2902

}

2903

}

2904

}

2905

}

2906

$sr .$sf

2907

}

2908

2909

2910

2911

sub cgi { # CGI object

2912

return($_[0]->{-cgi}) if $_[0]->{-cgi};

2913

cgiconnect(@_)

2914

}

2915

2916

2917

sub cgiconnect {# Connect CGI

2918

my $s =shift;

2919

22126

no warnings;

1004

2920

local $^W =0;

2921

$ENV{HTTP_USER_AGENT} =$ENV{HTTP_USER_AGENT}||'';

2922

$ENV{PERLXS} ='PerlIS' if !$ENV{PERLXS} && ($^O eq 'MSWin32') && $0 =~/[\\\/]perlis\.dll$/i;

2923

eval('use CGI; 1')

2924

||return(&{$s->{-die}}($s->efmt('No CGI')));

2925

$s->{-cgi} =$CGI::Q =$CGI::Q =eval{CGI->new(@_)}

2926

||return($s->{-die}

2927

? &{$s->{-die}}($s->efmt($@, undef, undef, 'cgi'))

2928

: CORE::die($s->efmt($@, undef, undef, 'cgi')));

2929

$s->set(-die=>'CGI::Carp fatalsToBrowser') if !$s->{-die};

2930

return(&{$s->{-die}}($s->efmt($s->{-cgi}->{'.cgi_error'}, undef, undef, 'cgi')))

2931

if $s->{-cgi}->{'.cgi_error'};

2932

if (1) { # parse parameters

2933

# __C_ change(d),

2934

# __O_ open, __L_ listbox choise, __S_ set, __X_ close

2935

# __P_ previous value

2936

# __B_ button for javascript

2937

foreach my $p ($s->{-cgi}->param) {

2938

if ($p =~/^(.+?)__S_$/) {

2939

$s->{-cgi}->param($1, $s->{-cgi}->param("$1__L_"));

2940

$s->{-cgi}->param("$1__C_", 1);

2941

$s->{-cgi}->delete("$1__L_");

2942

}

2943

elsif ($p =~/^(.+?)__X_$/) {

2944

if (defined($s->{-cgi}->param("$1__P_"))) {

2945

$s->{-cgi}->param($1, $s->{-cgi}->param("$1__P_"));

2946

}

2947

else {

2948

$s->{-cgi}->delete($1);

2949

}

2950

$s->{-cgi}->delete("$1__L_");

2951

}

2952

}

2953

foreach my $p ($s->{-cgi}->param) {

2954

if ($p =~/^(.+?)__L_$/) {

2955

# $s->{-cgi}->param($1, $s->{-cgi}->param("$1__L_"));

2956

# $s->{-cgi}->param("$1__C_", 1);

2957

$s->{-cgi}->delete("$1__L_");

2958

}

2959

}

2960

}

2961

$s->{-cgi}

2962

}

2963

2964

2965

sub cgipar { # CGI parameter

2966

$_[0]->{-cgi}->param(@_[1..$#_])

2967

}

2968

2969

2970

sub cgiurl { # CGI script URL

2971

local $^W =0; # $ENV{PATH_INFO}

2972

if ($#_ >0) {

2973

my $v =($_[0]->{-cgi}||$_[0]->cgi)->url(@_[1..$#_]);

2974

if ($v) {}

2975

elsif (!($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {}

2976

elsif (($#_ >2) ||(($#_ ==2) && !$_[2])) {}

2977

elsif ($_[1] eq '-relative') {

2978

$v =$ENV{SCRIPT_NAME};

2979

$v =$1 if $v =~/[\\\/]([^\\\/]+)$/;

2980

}

2981

elsif ($_[1] eq '-absolute') {

2982

$v =$ENV{SCRIPT_NAME}

2983

}

2984

return($v)

2985

}

2986

else {

2987

# MSDN: "GetServerVariable (ISAPI Extensions)"

2988

# ms-help://MS.MSDNQTR.v90.en/wcecomm5/html/wce50lrfGetServerVariableISAPIExtensions.htm

2989

# http:// $ENV{HTTP_HOST} : $ENV{SERVER_PORT} / ($ENV{PATH_INFO} | $ENV{SCRIPT_NAME})

2990

# + $ENV{QUERY_STRING}

2991

my $v =($_[0]->{-cgi}||$_[0]->cgi)->url();

2992

if ($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/)) {

2993

$v .= (($v =~/\/$/) ||($ENV{SCRIPT_NAME} =~/^\//) ? '' : '/')

2994

.$ENV{SCRIPT_NAME}

2995

if ($v !~/\w\/\w/) && $ENV{SCRIPT_NAME};

2996

}

2997

return($v)

2998

}

2999

}

3000

3001

3002

sub cgitext { # CGI textarea field

3003

$_[0]->{-cgi}->textarea(@_[1..$#_])

3004

# -default=>$v, -override=>1

3005

}

3006

3007

3008

sub cgistring { # CGI string field

3009

$_[0]->{-cgi}->textfield(@_[1..$#_])

3010

}

3011

3012

3013

sub cgiselect { # CGI selection field composition

3014

# -onchange=>1 reloads form

3015

my ($s, %a) =@_;

3016

my $cs =$a{-onchange} && (length($a{-onchange}) ==1);

3017

($cs

3018

? ''

3019

: '')

3020

.$s->{-cgi}->popup_menu(%a

3021

, $a{-labels} && !$a{-values}

3022

? (-values => do{use locale; [sort {$a{-labels}->{$a} cmp $a{-labels}->{$b}} keys %{$a{-labels}}]})

3023

: ()

3024

, $cs

3025

? (-onchange => '{window.document.forms[0].' .$a{-name} .'__C_.value="1"; window.document.forms[0].submit(); return(false)}')

3026

: ()

3027

)

3028

.( $cs && ($a{-onchange}=~/^\d/) && $s->{-cgi}->param($a{-name} .'__C_')

3029

? ''

3030

: '')

3031

}

3032

3033

3034

sub cgiddlb { # CGI drop-down listbox field composition

3035

# -strict=> - disable text edit, be alike cgiselect

3036

my ($s, %a) =@_;

3037

$s->cgi();

3038

my $n =$a{-name};

3039

my $nl="${n}__L_";

3040

my $av=sub{ return($a{-values}) if $a{-values};

3041

196

use locale;

3042

$a{-values} =[

3043

$a{-labels0}

3044

? sort {(defined($a{-labels0}->{$a}) ? $a{-labels0}->{$a} : '')

3045

cmp (defined($a{-labels0}->{$b}) ? $a{-labels0}->{$b} : '')

3046

} keys %{$a{-labels0}}

3047

: ()

3048

, (sort {(defined($a{-labels}->{$a}) ? $a{-labels}->{$a} : '')

3049

cmp (defined($a{-labels}->{$b}) ? $a{-labels}->{$b} : '')

3050

} keys %{$a{-labels}})

3051

, $a{-labels1}

3052

? sort {(defined($a{-labels1}->{$a}) ? $a{-labels1}->{$a} : '')

3053

cmp (defined($a{-labels1}->{$b}) ? $a{-labels1}->{$b} : '')

3054

} keys %{$a{-labels1}}

3055

: ()

3056

];

3057

foreach my $e ('-labels0','-labels1') {

3058

next if !$a{$e};

3059

foreach my $k (keys %{$a{$e}}) {

3060

$a{-labels}->{$k} =$a{$e}->{$k}

3061

}

3062

}

3063

$a{-values}

3064

};

3065

my $ac=$a{-class} ? ' class="' .$a{-class} .'"' : '';

3066

my $as=$a{-style} ? ' style="' .$a{-style} .'"' : '';

3067

my $aw=$a{-size} ||80;

3068

my $v =!defined($s->{-cgi}->param($n)) ||$a{-override}

3069

? $a{-default}

3070

: $s->{-cgi}->param($n);

3071

$v =&$av()->[0]

3072

if $a{-strict} && (!defined($v) || !grep /^\Q$v\E$/, @{&$av()});

3073

$s->{-cgi}->param($n, defined($v) ? $v : '');

3074

my $ek =$s->{-cgi}->user_agent('MSIE') ? 'window.event.keyCode' : 'event.which';

3075

my $fs =sub{

3076

'{var k;'

3077

."var l=window.document.forms[0].$nl;"

3078

."if(l.style.display=='none'){"

3079

.($_[0] eq '4' ? '' : 'return(true)') .'}else{'

3080

.(!$_[0] # onkeypess - input

3081

? "if (String.fromCharCode($ek) ==\"\\r\") {${n}__S_.focus(); ${n}__S_.click(); return(true)}; k=window.document.forms[0].$n.value +String.fromCharCode($ek);"

3082

: $_[0] eq '1' # onkeypess - list -> input (first char)

3083

? "if (String.fromCharCode($ek) ==\"\\r\") {${n}__S_.focus(); ${n}__S_.click(); return(true)}; window.document.forms[0].$n.focus(); k=window.document.forms[0].$n.value =String.fromCharCode($ek); "

3084

: $_[0] eq '2' # onkeypess - list -> prompt (selected char)

3085

# ? "k=prompt('Enter search string',String.fromCharCode($ek));"

3086

? "if (String.fromCharCode($ek) ==\"\\r\") {${n}__S_.focus(); ${n}__S_.click(); return(true)}; k =String.fromCharCode($ek); for (var i=0; i

3087

: $_[0] eq '3' # button - '..'

3088

? "k=prompt('Enter search substring',''); $nl.focus();"

3089

: $_[0] eq '4' # onload - document

3090

? "k=window.document.forms[0].$n.value; window.document.forms[0].$nl.focus();"

3091

: ''

3092

)

3093

.'if(k){'

3094

.'k=k.toLowerCase();'

3095

.'for (var i=0; i

3096

.($_[0] eq '4'

3097

? 'if (l.options.item(i).value.toLowerCase() ==k){'

3098

: $s->{-cgi}->user_agent('MSIE')

3099

? "if (l.options.item(i).innerText !='' ? l.options.item(i).innerText.toLowerCase().indexOf(k)"

3100

.($_[0] eq '3' ?'>=' :'==') .'0 : l.options.item(i).value.toLowerCase().indexOf(k)'

3101

.($_[0] eq '3' ?'>=' :'==') .'0){'

3102

: "if (l.options.item(i).text !='' ? l.options.item(i).text.toLowerCase().indexOf(k)"

3103

.($_[0] eq '3' ?'>=' :'==') .'0 : l.options.item(i).value.toLowerCase().indexOf(k)'

3104

.($_[0] eq '3' ?'>=' :'==') .'0){')

3105

.'l.selectedIndex =i; break;};}};'

3106

.($_[0] && ($_[0] ne '4')

3107

? 'return(false);'

3108

: $_[0] && ($_[0] eq '2')

3109

? 'return(false);'

3110

: '')

3111

.'}}'};

3112

3113

($s->{-cgi}->param("${n}__O_")

3114

? "

\n"

3115

: '')

3116

.$s->{-cgi}->textfield((map {defined($_) && defined($a{$_})

3117

? ($_ => $a{$_})

3118

: $a{-textfield} && $a{-textfield}->{$_} && !$s->{-cgi}->param("${n}__O_")

3119

? ($_ => $a{-textfield}->{$_})

3120

: ()

3121

} qw(-name -title -class -style -size -maxlength))

3122

, -default=>$v

3123

, -override=>1

3124

, ($a{-strict} && !$s->{-cgi}->param("${n}__O_")

3125

? (-readonly=>1) # ,-hidefocus=>0, -disabled=>0

3126

: ())

3127

)

3128

.($s->{-cgi}->param("${n}__O_")

3129

? (""

3130

."{-cgi}->escapeHTML($v) : '') ."\"$ac$as />\n"

3131

."
\n"

3132

3133

."$ac$as"

3134

." ondblclick=\"{${n}__S_.focus(); ${n}__S_.click(); return(true)}\""

3135

." onkeypress=\"" .($s->{-cgi}->user_agent('MSIE') ? &$fs(1) : &$fs(2))

3136

."\">\n"

3137

.join('',map {'

3138

.((defined($v) ? $v : '') eq (defined($_) ? $_ : '') ? ' selected' : '')

3139

.' value="' .$s->{-cgi}->escapeHTML(defined($_) ? $_ : '') .'">'

3140

.$s->{-cgi}->escapeHTML(

3141

!defined($_)

3142

? ''

3143

: !$a{-labels}

3144

? (length($_) > $aw ? substr($_,0,$aw) .'...' : $_)

3145

: defined($a{-labels}->{$_})

3146

? (length($a{-labels}->{$_}) > $aw ? substr($a{-labels}->{$_},0,$aw) .'...' : $a{-labels}->{$_})

3147

: '') ."\n"

3148

} @{&$av()})

3149

."\n"

3150

.""

3151

.$s->{-cgi}->button(-value=>'...', -title=>'find', -onClick=>&$fs(3))

3152

.""

3153

."\n"

3154

.""

3155

)

3156

: (""

3157

.($s->{-cgi}->param("${n}__C_") ||$s->{-cgi}->param("${n}__X_")

3158

? ""

3159

: ''

3160

))

3161

)

3162

}

3163

3164

3165

sub cgiesc { # escape strings to html

3166

$_[0]->{-cgi}->escapeHTML(@_[1..$#_])

3167

}

3168

3169

3170

sub cgitfrm { # table form layot

3171

# -form =>{form attrs}, -table=>{table attrs}, -tr=>{tr attrs}, -td=>{}, -th=>{}

3172

my ($s, %a) =$_[0];

3173

my $i =1;

3174

while (ref($_[$i]) ne 'ARRAY') {$a{$_[$i]} =$_[$i+1]; $i +=2};

3175

$s->cgi->start_form(-method=>'POST',-action=>'', $a{-form} ? %{$a{-form}} : ())

3176

# ,-name=>'test'

3177

.$s->{-cgi}->table($a{-table} ? $a{-table} : (), "\n"

3178

.join(''

3179

, map { my $r =$_;

3180

$s->{-cgi}->Tr($a{-tr} ? $a{-tr} : (), "\n"

3181

.join(''

3182

, map { ($_ =~/^

3183

? $s->{-cgi}->td($a{-td} || {-align=>'left', -valign=>'top'}, $_)

3184

: $s->{-cgi}->th($a{-th} || $a{-td} || {-align=>'left', -valign=>'top'}, $_)

3185

) ."\n"

3186

} @$r)

3187

) ."\n"

3188

} @_[$i..$#_])) ."\n"

3189

.$s->cgi->end_form()

3190

}

3191

3192

3193

sub smtpconnect {# Connect SMTP

3194

set(@_); # (-smtphost) -> self->{-smtp}

3195

set($_[0],-die=>'Carp') if !$_[0]->{-die};

3196

my $s =shift;

3197

1694

no warnings;

6670

3198

local $^W =0;

3199

eval('use Net::SMTP; 1') ||return(&{$s->{-die}}($@, $s->efmt('Net::SMTP')));

3200

$s->{-smtp} =eval {

3201

local $^W=undef;

3202

eval("use Net::SMTP");

3203

$s->{-smtphost}

3204

? Net::SMTP->new($s->{-smtphost})

3205

: CORE::die($s->efmt('SMTP host name required'))

3206

};

3207

return(&{$s->{-die}}("SMTP host '" .($s->{-smtphost}||'') ."': $@\n"))

3208

if !$s->{-smtp} ||$@;

3209

$s->{-smtp}

3210

}

3211

3212

3213

sub smtp { # SMTP connection object

3214

return($_[0]->{-smtp}) if $_[0]->{-smtp};

3215

smtpconnect(@_)

3216

}

3217

3218

3219

sub smtpsend { # SMTP mail msg send

3220

# -from||-sender, -to||-recipient,

3221

# -data|| -subject + (-text || -html)

3222

my ($s, %a) =@_;

3223

return(&{$s->{-die}}("SMTP host not defined"))

3224

if !$s->{-smtphost};

3225

local $s->{-smtpdomain} =$s->{-smtpdomain}

3226

|| ($s->{-smtphost} && $s->smtp(sub{$_[1]->domain()}))

3227

|| 'nothing.net';

3228

$a{-from} =$a{-from} ||$a{-sender} ||$ENV{REMOTE_USER} ||$ENV{USERNAME};

3229

$a{-from} =&{$a{-from}}($s,\%a) if ref($a{-from}) eq 'CODE';

3230

$a{-to} =&{$a{-to}}($s,\%a) if ref($a{-to}) eq 'CODE';

3231

$a{-to} =[grep {$_} split /\s*[,;]\s*/, ($a{-to} =~/^\s*(.*)\s*$/ ? $1 : $a{-to})]

3232

if $a{-to} && !ref($a{-to}) && ($a{-to} =~/[,;]/);

3233

$a{-sender} =$a{-sender} ||$a{-from};

3234

$a{-recipient} =$a{-recipient} ||$a{-to};

3235

$a{-recipient} =&{$a{-recipient}}($s,\%a) if ref($a{-recipient}) eq 'CODE';

3236

$a{-recipient} =[grep {$_} split /\s*[,;]\s*/, ($a{-recipient} =~/^\s*(.*)\s*$/ ? $1 : $a{-recipient})]

3237

if $a{-recipient} && ref($a{-recipient}) && ($a{-recipient} =~/[,;]/);

3238

return(&{$s->{-die}}("SMTP e-mail recipients not defined"))

3239

if !$a{-recipient};

3240

if (!defined($a{-data})) {

3241

my $koi =(($a{-charset}||$s->charset()||'') =~/1251/);

3242

$a{-subject} = ref($a{-subject}) eq 'CODE'

3243

? &{$a{-subject}}($s,\%a)

3244

: 'ARSObject'

3245

if ref($a{-subject}) ||!defined($a{-subject});

3246

$a{-data} ='';

3247

$a{-data} .='From: ' .($koi ? $s->cptran('ansi','koi',$a{-from})

3248

: $a{-from})

3249

."\cM\cJ";

3250

$a{-data} .='Subject: '

3251

.($koi

3252

? $s->cptran('ansi','koi',$a{-subject})

3253

: $a{-subject}) ."\cM\cJ";

3254

$a{-data} .='To: '

3255

.($koi

3256

? $s->cptran('ansi','koi', ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to})

3257

: (ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}))

3258

."\cM\cJ"

3259

if $a{-to};

3260

foreach my $k (keys %a) {

3261

3262

next if !defined($a{$k});

3263

my $n =$k =~/^-(.+)/ ? ucfirst($1) .':' : $k;

3264

$a{-data} .=$n .' ' .$a{$k} ."\cM\cJ";

3265

}

3266

$a{-data} .="MIME-Version: 1.0\cM\cJ";

3267

$a{-data} .='Content-type: ' .($a{-html} ? 'text/html' : 'text/plain')

3268

.'; charset=' .($a{-charset}||$s->charset())

3269

."\cM\cJ";

3270

$a{-data} .='Content-Transfer-Encoding: ' .($a{-encoding} ||'8bit') ."\cM\cJ";

3271

$a{-data} .="\cM\cJ";

3272

$a{-data} .=$a{-html} ||$a{-text} ||'';

3273

}

3274

local $^W=undef;

3275

$s->smtp->mail($a{-sender} =~/<\s*([^<>]+)\s*>/ ? $1 : $a{-sender})

3276

||return(&{$s->{-die}}("SMTP sender \'" .$a{-sender} ."' -> " .($s->smtp->message()||'?')));

3277

$s->smtp->to(ref($a{-recipient})

3278

? (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})

3279

: $a{-recipient}, {'SkipBad'=>1}) # , {'SkipBad'=>1}

3280

|| return(&{$s->{-die}}("SMTP recipient \'"

3281

.(ref($a{-recipient}) ? join(', ', (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})) : $a{-recipient}) ."' -> " .($s->smtp->message()||'?')));

3282

$s->smtp->data($a{-data})

3283

||return(&{$s->{-die}}("SMTP data '" .$a{-data} ."' -> " .($s->smtp->message()||'?')));

3284

my $r =$s->smtp->dataend()

3285

||return(&{$s->{-die}}("SMTP dataend -> " .($s->smtp->message()||'?')));

3286

$r ||1;

3287

}

3288

3289

3290

sub soon { # Periodical execution of this script

3291

# (minutes ||sub{}, ?log file, ?run command, ?soon command)

3292

# minutes: undef - clear sched, run once || sub{} -> number

3293

# log file: empty || full file name || var file name

3294

# run command: empty || 'command line' || [command line] || sub{}

3295

# soon command: empty || 'command line' || [command line] || []

3296

# empty run command - only soon command will be scheduled

3297

# empty soon command - sleep(minutes*60) will be used

3298

# !defined(minutes) - soon command will be deleted from schedule

3299

# and run command will be executed once

3300

# [soon command,... [arg,...],...] - schedule cleaning hint:

3301

# join(' ',@{[soon,...arg]}) used to clean schedule

3302

# join('', @{[arg,...]}) used in soon command

3303

my ($s, $mm, $lf, $cr, $cs) =@_;

3304

$lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);

3305

my $wl;

3306

if (ref($cs) ? scalar(@$cs) : $cs) {

3307

return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))

3308

if $^O ne 'MSWin32';

3309

if (defined($mm) && ($^O eq 'MSWin32') && eval('use Win32::Event; 1')) {

3310

# MSDN: 'CreateEvent', 'Kernel Object Namespaces'

3311

my $q =_sooncl($s, $cs, 1);

3312

my $n =$q;

3313

$n =~s/[\\]/!/g;

3314

$n ="Global\\$n";

3315

# sleep(60);

3316

$wl =Win32::Event->new(0,0,$n);

3317

# $s->fstore(">>$lf", $s->strtime() ."\t$$\tWin32::Event->new(0,0,$n) -> " .join(', ', $wl &&1 ||0, $^E ? ($^E +0) .".'$^E'" : ()) ."\n")

3318

# if $lf;

3319

if ($wl && $^E && ($^E ==183)) {

3320

print "Already '$q', done.\n";

3321

$s->fstore(">>$lf", "\n" .$s->strtime() ."\t$$\tAlready '$q', done.\n")

3322

if $lf;

3323

return(0);

3324

}

3325

}

3326

_sooncln($s, $mm, $lf, $wl ? '' : $cr, $cs, 1);

3327

}

3328

my $r =1;

3329

while (1) {

3330

if (!$cr) {

3331

}

3332

elsif (ref($cr) eq 'CODE') {

3333

local *OLDOUT;

3334

local *OLDERR;

3335

if ($lf) {

3336

eval{fileno(STDOUT) && open(OLDOUT, '>&STDOUT')};

3337

eval{fileno(STDERR) && open(OLDERR, '>&STDERR')};

3338

open(STDOUT, ">>$lf");

3339

open(STDERR, ">>$lf");

3340

}

3341

$r =&$cr(@_);

3342

if ($lf) {

3343

eval{fileno(OLDOUT) && close(STDOUT) && open(STDOUT, '>&OLDOUT')};

3344

eval{fileno(OLDERR) && close(STDERR) && open(STDERR, '>&OLDERR')};

3345

}

3346

}

3347

else {

3348

my $cmd =$cr;

3349

if (ref($cr) eq 'ARRAY') {

3350

$cr->[0] =Win32::GetFullPathName($cr->[0])

3351

if ($^O eq 'MSWin32') && ($cr->[0] !~/[\\\/]/);

3352

$cr->[0] = $cr->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cr->[0]

3353

if $cr->[0] =~/\.dll$/i;

3354

$cmd =join(' ', @$cr);

3355

}

3356

if ($lf) {

3357

$cmd ="$cmd >>$lf 2>>\&1";

3358

print(($cs ? '' : "\n") ."$cmd\n");

3359

$s->fstore(">>$lf", ($cs ? '' : "\n") .$s->strtime() ."\t$$\t$cmd\n");

3360

if (system($cmd) <0) {

3361

$r =0;

3362

print("Error $!\n");

3363

$s->fstore(">>$lf", $s->strtime() ."\t$$\t$!\n");

3364

}

3365

}

3366

else {

3367

print(($cs ? '' : "\n") ."$cmd\n");

3368

if (system(ref($cr) ? @$cr : $cr) <0) {

3369

$r =0;

3370

print("Error $!\n");

3371

}

3372

}

3373

}

3374

last if $cs || !defined($mm);

3375

my $mmm =ref($mm) eq 'CODE' ? &$mm($s) : $mm;

3376

print "sleep(", $mmm *60, ")...\n";

3377

$s->fstore(">>$lf", $s->strtime() ."\t$$\tsleep(" .($mmm*60) .")...\n")

3378

if $lf;

3379

sleep($mmm *60);

3380

}

3381

if (defined($mm) && (ref($cs) ? scalar(@$cs) : $cs)) {

3382

_sooncln($s, $mm, $lf, $cr, $cs, 0) if !$wl;

3383

my $t1 =$s->strtime($s->timeadd(

3384

sprintf('%.0f', time()/60) *60

3385

, 0,0,0,0

3386

, ref($mm) eq 'CODE' ? &$mm($s) : $mm

3387

));

3388

$t1 =$1 if $t1 =~/\s([^\s]+)/;

3389

my $cmd ="at $t1 /interactive " ._sooncl($s, $cs);

3390

print("$cmd\n");

3391

$s->fstore(">>$lf", $s->strtime() ."\t$$\t$cmd\n")

3392

if $lf;

3393

if (system($cmd) <0) {

3394

print("Error $!\n");

3395

$s->fstore(">>$lf", $s->strtime() ."\t$$\t$!\n")

3396

if $lf;

3397

}

3398

}

3399

3400

}

3401

3402

3403

3404

sub _sooncl { # soon() command line former

3405

my ($s, $cs, $q) =@_;

3406

my $nc;

3407

my $qry =$cs;

3408

if (ref($cs)) {

3409

return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))

3410

if $^O ne 'MSWin32';

3411

$cs->[0] =Win32::GetFullPathName($cs->[0])

3412

if ($^O eq 'MSWin32') && ($cs->[0] !~/[\\\/]/);

3413

$cs->[0] = $cs->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cs->[0]

3414

if $cs->[0] =~/\.dll$/i;

3415

$qry =$q ? join(' ', map { $nc

3416

? ()

3417

: !defined($_)

3418

? '""'

3419

: ref($_)

3420

? (do{$nc =$_->[0]})

3421

: $_

3422

} @$cs)

3423

: join(' ', map {!defined($_) ? '""' : ref($_) ? join('', @$_) : $_

3424

} @$cs);

3425

}

3426

$qry

3427

}

3428

3429

3430

sub _sooncln { # soon() cleaner

3431

my ($s, $mm, $lf, $cr, $cs, $strt) =@_;

3432

$lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);

3433

if (ref($cs) ? scalar(@$cs) : $cs) {

3434

my $nc;

3435

my $qry =_sooncl($s, $cs, 1);

3436

print "Starting '$qry'...\n" if $strt && defined($mm);

3437

$s->fstore(">>$lf", "\n" .$s->strtime() ."\t$$\tStarting '$qry'...\n")

3438

if $strt && $lf && defined($mm);

3439

sleep(int(rand(20))) if $strt && defined($mm) && $cr;

3440

foreach my $l (`at`) {

3441

next if $nc

3442

? $l !~/\Q$qry\E/i

3443

: $l !~/\Q$qry\E[\w\d\s]*[\r\n]*$/i;

3444

next if $l !~/(\d+)/;

3445

my $v =$1;

3446

my $cmd ="at $v /d";

3447

print("$cmd # $l\n");

3448

$s->fstore(">>$lf", $s->strtime() ."\t$$\t$cmd # $l\n")

3449

if $lf;

3450

system($cmd);

3451

}

3452

}

3453

3454

}

3455

3456

3457

sub cfpinit { # Field Player: init data structures

3458

my ($s) =@_; # (self) -> self

3459

$s->{-fphc} ={};

3460

$s->{-fphd} ={};

3461

my $dh ={};

3462

my $dp =undef;

3463

my $ah ={};

3464

my $ak;

3465

my $bf =undef;

3466

foreach my $f (@{$s->{-fpl}}) {

3467

if (ref($f) && $f->{-key} && $f->{-namecgi}) {

3468

$ak =$f->{-namecgi};

3469

last

3470

}

3471

}

3472

foreach my $f (@{$s->{-fpl}}) {

3473

if (ref($f) ne 'HASH') {

3474

if (!defined($dp)) {

3475

$dp =$f ||'-unknown';

3476

}

3477

elsif (!defined($f)) {

3478

delete $dh->{$dp};

3479

delete $dh->{-record} if $dp eq '-formdb';

3480

$dp =undef;

3481

}

3482

else {

3483

$dh->{$dp} =$f;

3484

delete $dh->{-record} if $dp eq '-formdb';

3485

$dp =undef;

3486

}

3487

}

3488

else {

3489

@$f{keys %$dh} =values %$dh;

3490

if ($f->{-metadb} && $f->{-formdb} && $s->{-meta} && $s->{-meta}->{$f->{-formdb}}) {

3491

my $fm =$f->{-metadb};

3492

$fm = ($fm =~/^\d+$/

3493

? $s->{-meta}->{$f->{-formdb}}->{-fldids}->{$fm}

3494

: $s->{-meta}->{$f->{-formdb}}->{-fields}->{$fm})

3495

|| &{$s->{-die}}($s->efmt('Field not found',$s->{-cmd},undef,'cfpinit',$f->{-formdb},$f->{-metadb}));

3496

$f->{-name} =$fm->{fieldName} if !$f->{-name};

3497

$f->{-namelbl}=$fm->{fieldLbll} if !exists($f->{-namelbl});

3498

$f->{-values} =schvals($s, $f->{-formdb}, $fm)

3499

if !($f->{-values} ||$f->{-labels})

3500

&& schvals($s, $f->{-formdb}, $fm);

3501

$f->{-labels} =schlblsl($s, $f->{-formdb}, $fm)

3502

if !$f->{-labels}

3503

&& schlbls($s, $f->{-formdb}, $fm);

3504

$f->{-value} =$fm->{defaultVal}

3505

if !exists($f->{-value})

3506

&& exists($fm->{defaultVal});

3507

}

3508

if (!$f->{-namecgi}) {

3509

$f->{-namecgi} =$f->{-name};

3510

$f->{-namecgi} =~s/[\s-]/_/g

3511

if $f->{-namecgi};

3512

}

3513

if (!$f->{-namedb}) {

3514

$f->{-namedb} =$f->{-name};

3515

}

3516

$s->{-fphc}->{$f->{-namecgi}} =$f if $f->{-namecgi};

3517

$s->{-fphd}->{$f->{-namedb}} =$f if $f->{-namedb};

3518

$f->{-namecmt} =$f->{-namelbl} ||$f->{-namecgi} ||$f->{-namedb} ||$f->{-name} if !$f->{-namecmt};

3519

3520

$f->{-values} =schvals($s, $f->{-formdb}, $f->{-namedb})

3521

if $f->{-namedb} && $f->{-formdb}

3522

&& !($f->{-values} ||$f->{-labels})

3523

&& schvals($s, $f->{-formdb}, $f->{-namedb});

3524

3525

$f->{-labels} =$s->{-strFields} && ($s->{-strFields} ==2)

3526

? schlblsl($s, $f->{-formdb}, $f->{-namedb})

3527

: schlbls($s, $f->{-formdb}, $f->{-namedb})

3528

if $f->{-namedb} && $f->{-formdb}

3529

&& !$f->{-labels}

3530

&& schlbls($s, $f->{-formdb}, $f->{-namedb});

3531

3532

if ((ref($f->{-labels}) eq 'HASH')) {

3533

foreach my $k (keys %{$f->{-labels}}) {

3534

last if !ref($f->{-labels}->{$k});

3535

$f->{-changelb} ={} if !$f->{-changelb};

3536

my $n =defined($f->{-labels}->{$k}->{-label})

3537

? $f->{-labels}->{$k}->{-label}

3538

: defined($f->{-labels}->{$k}->{-name})

3539

? $f->{-labels}->{$k}->{-name}

3540

: '';

3541

$f->{-changelb}->{$k} =$f->{-labels}->{$k};

3542

$f->{-labels}->{$k} =$n;

3543

}

3544

}

3545

if ((ref($f->{-values}) eq 'ARRAY')) {

3546

for (my $i =0; $i <=$#{$f->{-values}}; $i++) {

3547

last if !ref($f->{-values}->[$i]);

3548

$f->{-changelb} ={} if !$f->{-changelb};

3549

my $n =defined($f->{-values}->[$i]->{-name})

3550

? $f->{-values}->[$i]->{-name}

3551

: defined($f->{-values}->[$i]->{-label})

3552

? $f->{-values}->[$i]->{-label}

3553

: '';

3554

$f->{-changelb}->{$n} =$f->{-values}->[$i];

3555

$f->{-values}->[$i] =$n;

3556

}

3557

}

3558

3559

if ($f->{-change} ||$f->{-changelb}) {

3560

$f->{-onchange} =1

3561

}

3562

3563

if (exists($f->{-computed}) && !($f->{-readonly} ||$f->{-disabled})) {

3564

$f->{-disabled} =1

3565

}

3566

3567

if (!$f->{-namecgi} || !$f->{-action}) {

3568

}

3569

elsif (!$ah->{$f->{-namecgi}}) {

3570

$ah->{$f->{-namecgi}} =$f

3571

}

3572

elsif (ref($f->{-action}) ||($f->{-action} =~/^../)) {

3573

}

3574

else {

3575

$f->{-used} =$ah->{$f->{-namecgi}}->{-used}

3576

if !exists($f->{-used})

3577

&& exists($ah->{$f->{-namecgi}}->{-used});

3578

$f->{-unused} =$ah->{$f->{-namecgi}}->{-unused}

3579

if !exists($f->{-unused})

3580

&& exists($ah->{$f->{-namecgi}}->{-unused});

3581

$ah->{$f->{-namecgi}}->{-widget} =undef

3582

if !exists($ah->{$f->{-namecgi}}->{-widget});

3583

}

3584

if (exists($f->{-used}) ||exists($f->{-unused})) {

3585

}

3586

elsif ($ak && ($f->{-action}||$f->{-preact})

3587

&& (($f->{-action}||$f->{-preact}) =~/^(?:entryUpd|entryDel|entry|vfentry|vfhash)$/)) {

3588

$f->{-used} =sub{$_[0]->cgipar($ak)}

3589

}

3590

else {

3591

$f->{-used} =1

3592

}

3593

$f->{-widget} =undef

3594

if $f->{-preact} && !exists($f->{-widget});

3595

$bf =1

3596

if $f->{-action} && ($f->{-action} =~/^\d$/);

3597

}

3598

}

3599

if (!$bf) {

3600

my @bl;

3601

foreach my $f (@{$s->{-fpl}}) {

3602

next if ref($f) ne 'HASH';

3603

next if !$f->{-namecgi} || !$f->{-action};

3604

$f->{-widget} =undef;

3605

next if exists($f->{-computed}) || exists($f->{-value})

3606

|| !$ah->{$f->{-namecgi}};

3607

push @bl, {%$f, -action=>1};

3608

delete $bl[$#bl]->{-widget};

3609

delete $ah->{$f->{-namecgi}};

3610

}

3611

push @{$s->{-fpl}}, @bl;

3612

}

3613

3614

}

3615

3616

3617

sub cfpused { # Field Player: field should be used?

3618

# (self, field) -> yes?

3619

my ($s, $f) =@_;

3620

return(map {ref($_) && cfpused($s, $_) ? $_ : ()} @{$s->{-fpl}})

3621

if !$f;

3622

$f =$s->{-fphc}->{$f} ||$s->{-fphd}->{$f}

3623

if !ref($f);

3624

!ref($f) || (ref($f) ne 'HASH')

3625

? 0

3626

: ( !exists($f->{-used})

3627

? 1

3628

: !$f->{-used}

3629

? 0

3630

: (ref($f->{-used}) eq 'CODE')

3631

? &{$f->{-used}}($s, $f)

3632

: (ref($f->{-used}) eq 'ARRAY')

3633

? !scalar(grep {my $v =cfpused($s, $_) && cfpvv($s, $_);

3634

!defined($v) || ($v eq '')} @{$f->{-used}})

3635

: !ref($f->{-used}) && ($f->{-used} !~/^\d/)

3636

? (do{ my $v =cfpused($s, $f->{-used}) && cfpvv($s, $f->{-used});

3637

defined($v) && ($v ne '')})

3638

: ($f->{-used} && 1)

3639

)

3640

&& ( !exists($f->{-unused})

3641

? 1

3642

: !$f->{-unused}

3643

? 1

3644

: (ref($f->{-unused}) eq 'CODE')

3645

? !&{$f->{-unused}}($s, $f)

3646

: (ref($f->{-unused}) eq 'ARRAY')

3647

? scalar(grep {my $v =cfpused($s, $_) && cfpvv($s, $_);

3648

!defined($v) || ($v eq '')} @{$f->{-unused}})

3649

: !ref($f->{-unused}) && ($f->{-unused} !~/^\d/)

3650

? !(do{ my $v =cfpused($s, $f->{-unused}) && cfpvv($s, $f->{-unused});

3651

defined($v) && ($v ne '')})

3652

: ($f->{-unused} && 1)

3653

)

3654

}

3655

3656

3657

sub cfpn { # Field Player: field name

3658

# (self, field || fieldname) -> cgi field name

3659

ref($_[1])

3660

? $_[1]->{-namecgi}

3661

: (($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]} ||{})->{-namecgi} ||$_[1])

3662

}

3663

3664

3665

sub cfpnd { # Field Player: field name

3666

# (self, field || fieldname) -> db field name

3667

ref($_[1])

3668

? $_[1]->{-namedb}

3669

: (($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]} ||{})->{-namedb} ||$_[1])

3670

}

3671

3672

3673

sub cfpv { # Field Player: field value

3674

# (self, field || fieldname) -> value

3675

my $f =ref($_[1])

3676

? $_[1]

3677

: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});

3678

!$f

3679

? $_[0]->{-cgi}->param($_[1])

3680

: !$f->{-namecgi} || !defined($_[0]->{-cgi}->param($f->{-namecgi}))

3681

? (exists($f->{-computed})

3682

? (ref($f->{-computed}) eq 'CODE'

3683

? &{$f->{-computed}}($_[0], $f)

3684

: ref($f->{-computed}) eq 'ARRAY'

3685

? cfpv($_[0], @{$f->{-computed}})

3686

: $f->{-computed})

3687

: undef)

3688

: $_[0]->{-cgi}->param($f->{-namecgi})

3689

}

3690

3691

3692

sub cfpvl { # Field Player: field values list

3693

# (self, field || fieldname) -> [list]

3694

my $f =ref($_[1])

3695

? $_[1]

3696

: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});

3697

!$f

3698

? []

3699

: !$f->{-values}

3700

? (!$f->{-labels}

3701

? []

3702

: (do{ local $_ =cfpv(@_);

3703

my $ll =ref($f->{-labels}) eq 'CODE'

3704

? &{$f->{-labels}}($_[0], $f, $_)

3705

: $f->{-labels};

3706

use locale;

3707

[sort {lc($ll->{$a}) cmp lc($ll->{$b})

3708

} keys %$ll]}))

3709

: ref($f->{-values}) eq 'CODE'

3710

? (do{ local $_ =cfpv(@_);

3711

&{$f->{-values}}($_[0], $f, $_)})

3712

: $f->{-values}

3713

}

3714

3715

3716

sub cfpvv { # Field Player: field value or default

3717

# (self, field || fieldname) -> value

3718

my $v =cfpv(@_);

3719

defined($v) ? $v : cfpvd(@_)

3720

}

3721

3722

3723

sub cfpvd { # Field Player: field default value

3724

# (self, field || fieldname) -> value

3725

my $f =ref($_[1])

3726

? $_[1]

3727

: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});

3728

!$f

3729

? undef

3730

: exists($f->{-computed})

3731

? ( ref($f->{-computed}) eq 'CODE'

3732

? &{$f->{-computed}}($_[0], $f)

3733

: ref($f->{-computed}) eq 'ARRAY'

3734

? cfpvv($_[0], @{$f->{-computed}})

3735

: $f->{-computed})

3736

: !exists($f->{-value})

3737

? ($f->{-values} ||$f->{-labels} ? cfpvl($_[0], $f)->[0] : undef)

3738

: ref($f->{-value}) eq 'CODE'

3739

? &{$f->{-value}}($_[0], $f)

3740

: ref($f->{-value}) eq 'ARRAY'

3741

? cfpvv($_[0], @{$f->{-value}})

3742

: $f->{-value}

3743

}

3744

3745

3746

sub cfpvp { # Field Player: field previous value

3747

# (self, field || fieldname) -> value

3748

$_[0]->{-cgi}->param((ref($_[1])

3749

? $_[1]->{-namecgi} ||''

3750

: (($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]} ||{})->{-namecgi} ||$_[1])

3751

) .'__PV_')

3752

}

3753

3754

3755

sub cfpvc { # Field Player: field value changed since form open?

3756

# (self, field || fieldname) -> changed?

3757

my ($v1, $v0) =(cfpv(@_), cfpvp(@_));

3758

defined($v1) && defined($v0)

3759

? $v1 ne $v0

3760

: !defined($v1) && !defined($v0)

3761

? 0

3762

: 1

3763

}

3764

3765

3766

sub cfpvcc { # Field Player: field value changed in the last form submit?

3767

# (self, field || fieldname) -> changed?

3768

my $f =ref($_[1])

3769

? $_[1]

3770

: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});

3771

my $fn =ref($f) ? $f->{-namecgi} ||'' : '';

3772

$f->{-onchange} ||$f->{-values}

3773

? $_[0]->{-cgi}->param("${fn}__C_") ||!defined($_[0]->{-cgi}->param("${fn}__C_"))

3774

: cfpvc(@_)

3775

}

3776

3777

3778

sub cfpaction { # Field Player: execute action

3779

# (self, {action}||'action'

3780

# , '-preact'||'-action', {key field}) -> success

3781

my ($s, $act, $ord, $rp, $f) =@_;

3782

my $r =1;

3783

my $af=ref($act) eq 'HASH' ? $act : {};

3784

my $ae=ref($act) eq 'HASH' ? $act->{$ord} : $act;

3785

my $frm =$f->{-formdb}|| $af->{-formdb} ||'';

3786

my $frn =$f->{-record}|| $af->{-record} ||'';

3787

my $frk =undef;

3788

my $ffc =sub{ my $f =$_[1];

3789

!ref($f)

3790

|| !$f->{-namedb} || $f->{-key}

3791

|| !$f->{-formdb} || ($f->{-formdb} ne $frm)

3792

|| (($f->{-record}||'') ne $frn)

3793

};

3794

my $vy =0;

3795

my $fvu =sub{ return(undef)

3796

if (ref($_[1]->{-values}) eq 'ARRAY')

3797

&& !scalar(@{$_[1]->{-values}});

3798

my $v =cfpvv(@_);

3799

$v =undef if defined($_[1]->{-undef}) && defined($v) && ($_[1]->{-undef} eq $v);

3800

$vy=1 if defined($v) && ($v ne '') && (!$_[1]->{-master} ||$_[1]->{-key});

3801

$v =cfpvv($_[0], $_[1]->{-master}) if $_[1]->{-master} && !$_[1]->{-key};

3802

return($v) if !$_[2] || (defined($_[1]->{-vftran}) && !$_[1]->{-vftran});

3803

!defined($v)

3804

? $v

3805

: (ref($_[1]->{-labels}) eq 'HASH') && exists($_[1]->{-labels}->{$v})

3806

? $_[1]->{-labels}->{$v}

3807

: $v;

3808

};

3809

local $_;

3810

if ($frn || $s->{-fpbn}) {

3811

my $n =$frn =~/^(.+?)\d+$/ ? $1 : $frn;

3812

if ($n ne ($s->{-fpbn}||'')) {

3813

$s->{-fpbn} =$n; # buffer values

3814

$s->{-fpbv} =undef; # buffer name == record common name

3815

if ($ae =~/^(?:vfentry|entry)$/) {

3816

foreach my $ff (@{$s->{-fpl}}) {

3817

next if &$ffc($s, $ff) || !$ff->{-master};

3818

$frk =$ff;

3819

last;

3820

}

3821

}

3822

}

3823

}

3824

if (!$ae) {

3825

}

3826

elsif (ref($ae) eq 'CODE' && ($ord eq '-action')) {

3827

$r =eval{&$ae($s, $act, $ord, $rp, $f, $_ =cfpvv($s,$f), cfpvp($s,$f)

3828

, {map {&$ffc($s, $_)

3829

? ()

3830

: ($_->{-namedb} => &$fvu($s, $_))

3831

} cfpused($s)}

3832

)}

3833

}

3834

elsif (ref($ae) eq 'CODE') { # -preact

3835

$r =eval{&$ae($s, $act, $ord, $rp, $f, $_ =cfpvv($s, $f), cfpvp($s,$f)

3836

, {map {&$ffc($s, $_) || !defined(cfpv($s, $_))

3837

? ()

3838

: ($_->{-namedb} => cfpv($s, $_))

3839

} @{$s->{-fpl}}}

3840

)}

3841

}

3842

elsif ($ae =~/^(?:vfentry|entry)$/ && ref($s->{-fpbv})) {

3843

$r =shift @{$s->{-fpbv}} if scalar(@{$s->{-fpbv}});

3844

$r ={} if !$r;

3845

}

3846

elsif ($ae eq 'vfentry') { # -preact

3847

my $fs =$f->{-vfname} ||$af->{-vfname};

3848

my $fn =undef;

3849

my $fv =undef;

3850

if ($frk && $fs && ($fn =$frk->{-namedb}) && defined($fv=cfpv($s, $frk->{-master}))) {

3851

$s->{-fpbv} =$f->{-namedb}

3852

? $s->vfdata($fs, sub{defined($_->{$fn}) && ($_->{$fn} eq $fv)})

3853

: [];

3854

$r =shift @{$s->{-fpbv}} if $s->{-fpbv} && scalar(@{$s->{-fpbv}});

3855

$r ={} if !$r;

3856

}

3857

elsif ($fs) {

3858

$r =undef;

3859

if (defined($fv=cfpv($s, $f))) {

3860

$fn =$f->{-namedb}

3861

}

3862

elsif ($af->{-namedb} && ($fv =cfpv($s, $af))) {

3863

$fn =$af->{-namedb};

3864

}

3865

elsif ($fn =cfpnd($s, cfpv($s, $af))) {

3866

$fv =cfpv($s, $fn)

3867

}

3868

if ($fn && defined($fv)) {

3869

$r =undef;

3870

my $fa =$s->vfdata($fs);

3871

foreach my $e (@$fa) {

3872

next if !defined($e->{$fn}) || ($e->{$fn} ne $fv);

3873

$r =$e;

3874

last

3875

}

3876

$@="Not found '$fn'=\"$fv\""

3877

if !$r;

3878

}

3879

else {

3880

$@ =$fn

3881

? "Key '$fn' not defined at vfentry('$fs')"

3882

: "Key not defined at vfentry('$fs')"

3883

}

3884

}

3885

else {

3886

$@ ="Nothing to do at 'vfentry', '-vfname' not defined"

3887

}

3888

}

3889

elsif ($ae eq 'vfhash') { # -preact

3890

my $fs =$f->{-vfname} ||$af->{-vfname};

3891

my $fn =undef;

3892

my $fv =undef;

3893

if (defined($fv=cfpv($s, $f))) {

3894

$fn =$f->{-namedb}

3895

}

3896

elsif ($af->{-namedb} && ($fv =cfpv($s, $af))) {

3897

$fn =$af->{-namedb};

3898

}

3899

elsif ($fn =cfpnd($s, cfpv($s, $af))) {

3900

$fv =cfpv($s, $fn)

3901

}

3902

$r =undef;

3903

if (!$fs) {

3904

$@ ="Nothing to do at 'vfhash', '-vfname' not defined"

3905

}

3906

elsif (!$fn) {

3907

$@ ="Key not defined at 'vfhash'"

3908

}

3909

elsif (!defined($fv)) {

3910

$@ ="Key '$fn' not defined at 'vfhash'"

3911

}

3912

else {

3913

$r =$s->vfhash($fs, $fn, $fv);

3914

$@="Not found '$fn'=\"$fv\""

3915

if !$r;

3916

}

3917

}

3918

elsif ($ae eq 'entry') { # -preact

3919

my $fn =undef;

3920

my $fv =undef;

3921

if (!$frm) {

3922

$r =undef;

3923

$@ ="Form not defined"

3924

}

3925

elsif ($frk && ($fn=$frk->{-namedb}) && ($fv =cfpv($s, $frk->{master}))) {

3926

$s->{-fpbv} =$f->{-namedb}

3927

? eval{$s->connect()

3928

&& $s->query(-form=>$frm

3929

,-fields=>'*'

3930

,-where=>"'$fn'=" .$s->arsquot($fv))}

3931

: [];

3932

if ($s->{-fpbv}) {

3933

$r =shift @{$s->{-fpbv}} if scalar(@{$s->{-fpbv}});

3934

$r ={} if !$r;

3935

}

3936

else {

3937

$r =undef

3938

}

3939

}

3940

elsif ($f && ($fv =cfpv($s, $f))) {

3941

$r =eval{$s->connect()

3942

&& $s->entry(-form=>$frm

3943

,-id=>$fv)};

3944

}

3945

elsif ( (($fn =$af->{-namedb}) && defined($fv =cfpv($s, $af)))

3946

|| (($fn =cfpnd($s, cfpv($s, $af))) && defined($fv =cfpv($s, $fn)))

3947

) {

3948

$r =eval{$s->connect()

3949

&& $s->query(-form=>$frm

3950

,-fields=>'*'

3951

,-where=>"'$fn'=" .$s->arsquot($fv))};

3952

if ($r) {

3953

$r =shift @$r;

3954

$@ ="Not found '$fn'=\"$fv\""

3955

if !$r

3956

}

3957

}

3958

else {

3959

$r =undef;

3960

$@ ="Key not defined"

3961

}

3962

}

3963

elsif ($ae eq 'entryNew') { # -preact

3964

$r =eval{$s->connect()

3965

&& $s->entryNew(-form => $frm)}

3966

if $frm;

3967

}

3968

elsif ($ae eq 'entryIns') { # -action

3969

my $fs =$f->{-vfname} ||$af->{-vfname};

3970

$r =eval{$s->connect()

3971

&& $s->entryIns(-form=>$frm

3972

, map { &$ffc($s, $_) ||(exists($_->{-entryIns}) && !$_->{-entryIns})

3973

? ()

3974

: ($_->{-namedb} => &$fvu($s, $_))

3975

} cfpused($s))}

3976

if $frm;

3977

$r =1 if ref($r);

3978

if (!$r) {

3979

$@ ="Unknown 'entryIns' error" if !$@

3980

}

3981

elsif (!$fs ||!$f->{-key}) {

3982

}

3983

elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {

3984

$s->vfclear($fs);

3985

}

3986

elsif (($af->{-vfrenew} || $f->{-vfrenew}) && $s->{"${fs}-store"}) {

3987

eval{$s->vfclear($fs); $s->vfrenew($fs)}

3988

}

3989

elsif ($af->{-vfedit} || $f->{-vfedit}) {

3990

my $fn =$f->{-namedb} ||$af->{-namedb};

3991

my $ft =defined($f->{-vftran}) ? $f->{-vftran} : $af->{-vftran};

3992

my $fv =cfpv($s, $f);

3993

my $fa =$s->vfdata($fs);

3994

push @$fa, {$f->{-namedb} ? ($f->{-namedb}=>$r) : ()

3995

,map { &$ffc($s, $_) ||(exists($_->{-vfstore}) && !$_->{-vfstore})

3996

? ()

3997

: ($_->{-namedb} => &$fvu($s, $_, $ft))

3998

} cfpused($s)};

3999

$s->vfstore($fs);

4000

$s->vfclear($fs);

4001

}

4002

}

4003

elsif ($ae eq 'entryUpd') { # -action

4004

my $fs =$f->{-vfname} ||$af->{-vfname};

4005

$r =eval{$s->connect()

4006

&& $s->entryUpd(-form=>$frm, -id=>cfpvv($s,$f)

4007

, map { &$ffc($s, $_) ||(exists($_->{-entryUpd}) && !$_->{-entryUpd})

4008

? ()

4009

: ($_->{-namedb} => &$fvu($s, $_))

4010

} cfpused($s))}

4011

if $frm && cfpvv($s,$f);

4012

if (!$r) {

4013

$@ ="Unknown 'entryUpd' error" if !$@

4014

}

4015

elsif (!$f->{-key} ||!$fs) {

4016

}

4017

elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {

4018

$s->vfclear($fs);

4019

}

4020

elsif (($af->{-vfrenew} || $f->{-vfrenew}) && $s->{"${fs}-store"}) {

4021

eval{$s->vfclear($fs); $s->vfrenew($fs)}

4022

}

4023

elsif ($af->{-vfedit} || $f->{-vfedit}) {

4024

my $fn =$f->{-namedb} ||$af->{-namedb};

4025

my $ft =defined($f->{-vftran}) ? $f->{-vftran} : $af->{-vftran};

4026

my $fv =cfpv($s, $f);

4027

my $fa =$s->vfdata($fs);

4028

foreach my $e (@$fa) {

4029

next if !defined($e->{$fn}) || ($e->{$fn} ne $fv);

4030

foreach my $f1 (cfpused($s)) {

4031

next if &$ffc($s, $f1) ||(exists($f1->{-vfstore}) && !$f1->{-vfstore});

4032

$e->{$f1->{-namedb}} =&$fvu($s, $f1, $ft);

4033

}

4034

last;

4035

}

4036

$s->vfstore($fs);

4037

$s->vfclear($fs);

4038

}

4039

}

4040

elsif ($act eq 'entryDel') { # -action

4041

my $fs =$f->{-vfname} ||$af->{-vfname};

4042

$r =eval{$s->connect()

4043

&& $s->entryDel(-form=>$frm

4044

, -id=>cfpvv($s,$f))}

4045

if $frm && cfpvv($s,$f);

4046

if (!$r) {

4047

$@ ="Unknown 'entryDel' error" if !$@

4048

}

4049

elsif (!$fs ||!$f->{-key}) {

4050

}

4051

elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {

4052

$s->vfclear($fs);

4053

}

4054

elsif (($af->{-vfrenew} || $f->{-vfrenew}) && $s->{"${fs}-store"}) {

4055

eval{$s->vfclear($fs); $s->vfrenew($fs)}

4056

}

4057

elsif ($af->{-vfedit} || $f->{-vfedit}) {

4058

my $fn =$f->{-namedb} ||$af->{-namedb};

4059

my $fv =cfpv($s, $f);

4060

my $fa =$s->vfdata($fs);

4061

my ($i,$j) =(0, undef);

4062

foreach my $e (@$fa) {

4063

if (defined($e->{$fn}) && ($e->{$fn} eq $fv)) {

4064

$j =$i;

4065

last;

4066

}

4067

$i++

4068

}

4069

splice(@$fa, $i, 1);

4070

$s->vfstore($fs);

4071

$s->vfclear($fs);

4072

}

4073

}

4074

elsif ($ae eq 'entrySave') { # -action

4075

my $a =cfpvv($s,$f) ? 'entryUpd' : cfpvp($s,$f) ? 'entryDel' : 'entryIns';

4076

if ($a eq 'entryIns') { # $vy= 1 if cfpvv($s,$f)

4077

map { &$ffc($s, $_) ||(exists($_->{-entryIns}) && !$_->{-entryIns})

4078

? ()

4079

: ($_->{-namedb} => &$fvu($s, $_))

4080

} cfpused($s);

4081

$a = $vy

4082

? $a

4083

: ($a eq 'entryIns')

4084

? ''

4085

: ($a eq 'entryUpd') && cfpvp($s,$f)

4086

? 'entryDel'

4087

: $a;

4088

}

4089

$s->{-cgi}->param($f->{-namecgi}, cfpvp($s,$f))

4090

if ($a eq 'entryDel') && $f->{-namecgi};

4091

$r =!$a

4092

? 1

4093

: ref($act) eq 'HASH'

4094

? cfpaction($s, {%$act, -action => $a}, @_[2..$#_])

4095

: cfpaction($s, $a, @_[2..$#_])

4096

}

4097

if ((ref($r) eq 'HASH') && ($ord eq '-preact')) {

4098

foreach my $f1 (map { &$ffc($s, $_) || !$_->{-namecgi}

4099

? ()

4100

: ($_)

4101

} @{$s->{-fpl}}) {

4102

next if !exists($r->{$f1->{-namedb}});

4103

my $u =$s->cfpused($f1);

4104

my $v =$r->{$f1->{-namedb}};

4105

if (defined($v)

4106

|| defined($s->{-cgi}->param($f1->{-namecgi}))) {

4107

$s->{-cgi}->param($f1->{-namecgi}, $v);

4108

$s->{-cgi}->param($f1->{-namecgi} .'__C_', '')

4109

if $u && ($f1->{-values} || $f1->{-labels});

4110

}

4111

if (defined($v)

4112

&& (defined($f1->{-vftran}) ? $f1->{-vftran} : defined($f->{-vftran}) ? $f->{-vftran} : $af->{-vftran})

4113

&& (ref($f1->{-labels}) eq 'HASH') && !exists($f1->{-labels}->{$v})) {

4114

foreach my $k (keys %{$f1->{-labels}}) {

4115

next if $v ne $f1->{-labels}->{$k};

4116

$v =$k;

4117

$s->{-cgi}->param($f1->{-namecgi}, $v);

4118

last;

4119

}

4120

print &{$s->{-fpmsg}}($s, 'Warning'

4121

, ($af->{-namelbl} ||$af->{-namecgi})

4122

.': '

4123

."'" .($f1->{-namelbl}||$f1->{-namedb})

4124

."' == ?\"$v\"?")

4125

if $u

4126

&& !exists($f1->{-labels}->{$v})

4127

&& (defined($f1->{-lbtran}) && !$f1->{-lbtran})

4128

}

4129

}

4130

}

4131

4132

}

4133

4134

4135

sub cfprun { # Field Player: run

4136

# (self, msg sub{}

4137

# , form row sub{}, form top, form bottom) -> success

4138

my ($s, $cmsg, $cfld, $cfld0, $cfld1) =@_;

4139

my $hmsg =ref($cmsg) eq 'HASH'

4140

? $cmsg

4141

: ($s->{-lang} ||'') =~/^ru/i

4142

? {'Error'=>'��', 'Warning'=>'��', 'Success'=>'��'

4143

,'Executing'=>'��', 'Done'=>'��'}

4144

: {};

4145

$cmsg =sub{"\n

4146

.($_[1] =~/^(?:Error|Warning)/ ? ' color="red"' : '')

4147

.'>'

4148

.(defined($_[1]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[1]} ||$_[1]) : 'undef')

4149

.": "

4150

.(defined($_[2]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[2]} ||$_[2]) : 'undef')

4151

.""

4152

# 'Error', 'Warning',

4153

# 'Executing', 'Done'('Success', 'Error')

4154

}

4155

if !$cmsg || (ref($cmsg) ne 'CODE');

4156

my $emsg =sub{

4157

$CGI::Carp::CUSTOM_MSG

4158

? &$CGI::Carp::CUSTOM_MSG($_[1])

4159

: print(&$cmsg($_[0], 'Error', $_[1]))

4160

};

4161

$cfld =sub{"\n

4162

. ($_[1]->{-namehtml}

4163

? &{$_[1]->{-namehtml}}(@_)

4164

: $_[0]->{-cgi}->escapeHTML($_[1]->{-namelbl}||''))

4165

. "\n

4166

. $_[2]

4167

. "

4168

}

4169

if !$cfld;

4170

$cfld0="\n" if !$cfld0;

4171

$cfld1="\n

" if !$cfld1;

4172

$s->cgi();

4173

cfpinit($s);

4174

local $s->{-fpmsg} =$cmsg;

4175

my $err;

4176

my $act;

4177

my $acf;

4178

my $aec;

4179

my $arv;

4180

foreach my $f (@{$s->{-fpl}}) {

4181

next if (ref($f) ne 'HASH')

4182

|| (exists($f->{-used}) && !$f->{-used});

4183

if ($f->{-preact} && ($f->{-preact} !~/^\d$/) && cfpvv($s, $f)) {

4184

$acf =1;

4185

$act =[] if !$act;

4186

push @$act, $f

4187

}

4188

if ($f->{-action} && ($f->{-action} !~/^\d$/) && cfpvv($s, $f)) {

4189

$aec =cfpvv($s, $f);

4190

}

4191

if ($f->{-key} && $act && !$err) {

4192

$arv =1;

4193

foreach my $a (@$act) {

4194

$arv =cfpaction($s, $a, '-preact', $arv, $f);

4195

next if $arv;

4196

$err =$@;

4197

last

4198

}

4199

$act =undef;

4200

if (!$arv) {

4201

&$emsg($s, $err ||"Unknown 'cfpaction' error");

4202

$err =1;

4203

last;

4204

}

4205

}

4206

if ($f->{-key}) {

4207

$act =undef;

4208

}

4209

next if !cfpused($s, $f);

4210

my $fn =cfpn($s, $f);

4211

if (!$f->{-reset}

4212

? undef

4213

: ref($f->{-reset}) eq 'CODE'

4214

? &{$f->{-reset}}($s, $f)

4215

: ref($f->{-reset}) eq 'ARRAY'

4216

? grep {cfpvcc($s, $_)} @{$f->{-reset}}

4217

# ??? read from URL interpreted as changed listbox

4218

: $f->{-reset}

4219

? cfpvcc($s, $f->{-reset})

4220

: undef

4221

) {

4222

$s->{-cgi}->delete($fn);

4223

}

4224

my $fv =exists($f->{-computed})

4225

? (ref($f->{-computed}) eq 'CODE'

4226

? &{$f->{-computed}}($s, $f)

4227

: ref($f->{-computed}) eq 'ARRAY'

4228

? cfpvv($s, @{$f->{-computed}})

4229

: $f->{-computed})

4230

: cfpvv($s, $f);

4231

local $_ =$fv;

4232

if (!($f->{-action} || $f->{-preact}) && $f->{-namecgi}) {

4233

if (defined($fv)) {

4234

if ((defined($f->{-lbtran}) ? $f->{-lbtran} : 0)

4235

&& (ref($f->{-labels}) eq 'HASH') && !exists($f->{-labels}->{$fv})) {

4236

foreach my $k (keys %{$f->{-labels}}) {

4237

next if $fv ne $f->{-labels}->{$k};

4238

$fv =$k;

4239

last;

4240

}

4241

print &$cmsg($s, 'Warning'

4242

, "'" .($f->{-namelbl} ||$f->{-namecgi} ||$f->{-namedb})

4243

."' == ?\"$fv\"?")

4244

if !exists($f->{-labels}->{$fv})

4245

&& !$f->{-lbadd}

4246

}

4247

if ((defined($f->{-lbadd}) ? $f->{-lbadd} : 0)) {

4248

6625

$f->{-values} =do{use locale;

4249

[sort {lc($f->{-labels}->{$a}) cmp lc($f->{-labels}->{$b})} keys %{$f->{-labels}}]}

4250

if (ref($f->{-labels}) eq 'HASH')

4251

&& !$f->{-values};

4252

push @{$f->{-values}}, $fv

4253

if (ref($f->{-values}) eq 'ARRAY')

4254

&& !grep /^\Q$fv\E$/, @{$f->{-values}};

4255

}

4256

}

4257

$f->{-labels} =&{$f->{-labels}}($s, $f, $_ =$fv)

4258

if ref($f->{-labels}) eq 'CODE';

4259

$f->{-values} =&{$f->{-values}}($s, $f, $_ =$fv)

4260

if ref($f->{-values}) eq 'CODE';

4261

235

$f->{-values} =do{use locale;

4262

[sort {lc($f->{-labels}->{$a}) cmp lc($f->{-labels}->{$b})} keys %{$f->{-labels}}]}

4263

if $f->{-labels}

4264

&& !$f->{-values};

4265

if ($f->{-values}

4266

&& (!defined($fv) || !grep /^\Q$fv\E$/, @{$f->{-values}})) {

4267

$fv =$f->{-values}->[0];

4268

$fv ='' if !defined($fv);

4269

$s->{-cgi}->delete("${fn}__C_") if $f->{-change};

4270

}

4271

if (defined($fv)) {

4272

$s->{-cgi}->param($fn, $fv);

4273

$s->{-cgi}->param("${fn}__PV_", $fv)

4274

if !defined($s->{-cgi}->param("${fn}__PV_"));

4275

}

4276

else {

4277

$s->{-cgi}->delete($fn);

4278

}

4279

}

4280

foreach my $q ('-change', '-changelb') {

4281

next if !$f->{$q};

4282

last if !cfpvcc($s, $f);

4283

my $c =ref($f->{$q}) eq 'CODE' ? &{$f->{$q}}($s, $f, $_ =$fv) : $f->{$q};

4284

$c =ref($c) ne 'HASH' ? undef : ref($c->{$fv}) eq 'HASH' ? $c->{$fv} : $c;

4285

if (ref($c) eq 'HASH') {

4286

foreach my $k (keys %$c) {

4287

next if $k =~/^-/;

4288

defined($c->{$k})

4289

? $s->{-cgi}->param(cfpn($s, $k)

4290

, ref($c->{$k}) eq 'CODE'

4291

? &{$c->{$k}}($s, $f, $_ =$fv)

4292

: $c->{$k}

4293

)

4294

: $s->{-cgi}->delete(cfpn($s, $k))

4295

}

4296

}

4297

}

4298

if (my $ev =!$aec || !$f->{-error}

4299

? undef

4300

: ref($f->{-error}) eq 'CODE'

4301

? &{$f->{-error}}($s, $f, $_ =$fv, cfpvp($s, $f), $aec)

4302

: !ref($f->{-error}) && (!defined($fv) || ($fv eq ''))

4303

? $f->{-error}

4304

: undef

4305

) {

4306

print &$cmsg($s, 'Error', "'" .$f->{-namelbl} ."' - $ev");

4307

$err =1;

4308

}

4309

if (my $ev =!$f->{-warn}

4310

? undef

4311

: ref($f->{-warn}) eq 'CODE'

4312

? &{$f->{-warn}}($s, $f, $_ =$fv, cfpvp($s, $f), $aec)

4313

: !ref($f->{-warn}) && (!defined($fv) || ($fv eq ''))

4314

? $f->{-warn}

4315

: undef

4316

) {

4317

print &$cmsg($s, 'Warning', "'" .$f->{-namelbl} ."' - $ev");

4318

}

4319

}

4320

return(undef)

4321

if $err;

4322

$act = $acf =$arv =undef;

4323

foreach my $f (@{$s->{-fpl}}) {

4324

next if (ref($f) ne 'HASH')

4325

|| (exists($f->{-used}) && !$f->{-used});

4326

next if !cfpused($s, $f);

4327

if ($f->{-action} && ($f->{-action} !~/^\d$/) && cfpvv($s, $f)) {

4328

$acf =1;

4329

$act =[] if !$act;

4330

push @$act, $f

4331

}

4332

if ($f->{-key} && $act && !$err) {

4333

$arv =1;

4334

foreach my $a (@$act) {

4335

print &$cmsg($s, 'Executing', ($a->{-namelbl} ||$a->{-namecgi} ||'') .' ', $arv)

4336

if $a->{-namelbl} ||$a->{-namecgi};

4337

$arv =cfpaction($s, $a, '-action', $arv, $f);

4338

next if $arv;

4339

$err =$@;

4340

last;

4341

}

4342

$act =undef;

4343

if (!$arv) {

4344

&$emsg($s, $err ||"Unknown 'cfpaction' error");

4345

$err =1;

4346

last;

4347

}

4348

}

4349

if ($f->{-key}) {

4350

$act =undef;

4351

}

4352

}

4353

if ($acf) {

4354

print &$cmsg($s, 'Done', $err ? ('Error', $@) : ('Success', $arv))

4355

}

4356

return(undef)

4357

if $err;

4358

return(1)

4359

if $acf;

4360

foreach my $f (@{$s->{-fpl}}) {

4361

next if (ref($f) ne 'HASH')

4362

|| (exists($f->{-used}) && !$f->{-used});

4363

next if exists($f->{-widget}) && !defined($f->{-widget});

4364

next if !$f->{-namecgi};

4365

my $u =cfpused($s, $f);

4366

next if $u && !($f->{-hidden} ||((ref($f->{-values}) eq 'ARRAY') && !scalar(@{$f->{-values}})));

4367

print defined(cfpvp($s, $f))

4368

? ' 4369

.$s->{-cgi}->escapeHTML(cfpvp($s, $f))

4370

.'" />' ."\n"

4371

: ''

4372

, !$u

4373

? ( defined($s->{-cgi}->param($f->{-namecgi}))

4374

? ' 4375

.$s->{-cgi}->escapeHTML($s->{-cgi}->param($f->{-namecgi}))

4376

.'" />' ."\n"

4377

: '')

4378

: defined(cfpvv($s, $f))

4379

? ' 4380

.$s->{-cgi}->escapeHTML(cfpvv($s, $f))

4381

.'" />' ."\n"

4382

: '';

4383

}

4384

print ref($cfld0) ? &{$cfld0}($s) : $cfld0;

4385

my $bb ='';

4386

foreach my $f (@{$s->{-fpl}}) {

4387

next if (ref($f) ne 'HASH')

4388

|| (exists($f->{-used}) && !$f->{-used});

4389

next if !cfpused($s, $f);

4390

next if exists($f->{-widget}) && !defined($f->{-widget});

4391

next if $f->{-hidden} ||((ref($f->{-values}) eq 'ARRAY') && !scalar(@{$f->{-values}}));

4392

my $bf =$f->{-action} ||$f->{-preact};

4393

if ($f->{-action} ||$f->{-preact}) {

4394

$bb .=' ' if $bb;

4395

$bb .= exists($f->{-widget}) && !$f->{-widget}

4396

? ''

4397

: !ref($f->{-widget}) && $f->{-widget}

4398

? $f->{-widget}

4399

: ref($f->{-widget}) eq 'CODE'

4400

? &{$f->{-widget}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))

4401

: !$f->{-namecgi}

4402

? ''

4403

: ref($f->{-widget}) eq 'HASH'

4404

? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}

4405

, %{$f->{-widget}})

4406

: $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}

4407

, map {defined($f->{$_}) ? ($_=>$f->{$_}) : ()} qw(-class -style));

4408

4409

}

4410

elsif ($bb) {

4411

print &$cfld($s, {}, $bb);

4412

$bb ='';

4413

}

4414

print &$cfld($s

4415

, $f->{-action} ||$f->{-preact}

4416

? {}

4417

: $f

4418

, (!$f->{-widget0}

4419

? ''

4420

: ref($f->{-widget0}) eq 'CODE'

4421

? &{$f->{-widget0}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))

4422

: $f->{-widget0})

4423

. (!($f->{-action} || $f->{-preact}) && $f->{-namecgi} && defined(cfpvp($s, $f))

4424

? ' 4425

.$s->{-cgi}->escapeHTML(cfpvp($s, $f))

4426

.'" />'

4427

: ''

4428

)

4429

. (!ref($f->{-widget}) && exists($f->{-widget})

4430

? $f->{-widget}

4431

: ref($f->{-widget}) eq 'CODE'

4432

? &{$f->{-widget}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))

4433

: !$f->{-namecgi}

4434

? ''

4435

: ref($f->{-widget}) eq 'HASH'

4436

? ( $f->{-values}

4437

? $s->cgiselect(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}

4438

, -onchange=>1

4439

, map {defined($f->{$_}) ? ($_=>$f->{$_}) : ()} qw(-values -labels)

4440

, -id => $f->{-namecgi}

4441

, %{$f->{-widget}})

4442

: $f->{-rows}

4443

? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}

4444

, -id => $f->{-namecgi}

4445

, %{$f->{-widget}})

4446

: $f->{-action} ||$f->{-preact}

4447

? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}

4448

, -id => $f->{-namecgi}

4449

, %{$f->{-widget}})

4450

: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}

4451

, -id => $f->{-namecgi}

4452

, %{$f->{-widget}})

4453

)

4454

: ( $f->{-values}

4455

? $s->cgiselect(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}

4456

, -id => $f->{-namecgi}

4457

, -onchange=>1

4458

, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};

4459

defined($v) ? ($_=>$v) : ()} qw(-values -labels -onchange -readonly -disabled -class -style))

4460

: $f->{-rows}

4461

? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}

4462

, -id => $f->{-namecgi}

4463

, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};

4464

defined($v) ? ($_=>$v) : ()} qw(-rows -columns -maxlength -readonly -class -style))

4465

: $f->{-action} ||$f->{-preact}

4466

? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}

4467

, -id => $f->{-namecgi}

4468

, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};

4469

defined($v) ? ($_=>$v) : ()} qw(-class -style))

4470

: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}

4471

, -id => $f->{-namecgi}

4472

, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};

4473

defined($v) ? ($_=>$v) : ()} qw(-size -maxlength -readonly -disabled -class -style))

4474

)

4475

)

4476

. (!$f->{-widget1}

4477

? ''

4478

: ref($f->{-widget1}) eq 'CODE'

4479

? &{$f->{-widget1}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))

4480

: $f->{-widget1})

4481

);

4482

}

4483

if ($bb) {

4484

print &$cfld($s, {}, $bb);

4485

$bb ='';

4486

}

4487

print ref($cfld1) ? &{$cfld1}($s) : $cfld1;

4488

$err ? undef : 1

4489

}