| line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
|
1
|
|
|
|
|
|
|
=head1 NAME |
|
2
|
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
HTML::FormEngine::DBSQL - create html/xhtml forms for adding, updating |
|
4
|
|
|
|
|
|
|
and removing records to / in / from sql database tables |
|
5
|
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=cut |
|
7
|
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
###################################################################### |
|
9
|
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
package HTML::FormEngine::DBSQL; |
|
11
|
|
|
|
|
|
|
require 5.004; |
|
12
|
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# Copyright (c) 2003-2004, Moritz Sinn. This module is free software; |
|
14
|
|
|
|
|
|
|
# you can redistribute it and/or modify it under the terms of the |
|
15
|
|
|
|
|
|
|
# GNU GENERAL PUBLIC LICENSE, see COPYING for more information |
|
16
|
|
|
|
|
|
|
|
|
17
|
1
|
|
|
1
|
|
21236
|
use strict; |
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
51
|
|
|
18
|
1
|
|
|
1
|
|
5
|
use vars qw(@ISA $VERSION); |
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
72
|
|
|
19
|
1
|
|
|
1
|
|
2055
|
use HTML::FormEngine; |
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
@ISA = qw(HTML::FormEngine); |
|
21
|
|
|
|
|
|
|
$VERSION = '1.01'; |
|
22
|
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
###################################################################### |
|
24
|
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 DEPENDENCIES |
|
26
|
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=head2 Perl Version |
|
28
|
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
5.004 |
|
30
|
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
=head2 Standard Modules |
|
32
|
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
Carp 1.01 |
|
34
|
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=head2 Nonstandard Modules |
|
36
|
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
HTML::FormEngine 1.0 |
|
38
|
|
|
|
|
|
|
Clone 0.13 |
|
39
|
|
|
|
|
|
|
Hash::Merge 0.07 |
|
40
|
|
|
|
|
|
|
Locale::gettext 1.01 |
|
41
|
|
|
|
|
|
|
Digest::MD5 2.24 |
|
42
|
|
|
|
|
|
|
DBI 1.42 |
|
43
|
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
=head1 REQUIREMENTS |
|
45
|
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
This class was only tested with PostgreSQL. Please tell me about |
|
47
|
|
|
|
|
|
|
your experiences with other DBMS. Thanks! |
|
48
|
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
=cut |
|
50
|
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
###################################################################### |
|
52
|
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
use Carp; |
|
54
|
|
|
|
|
|
|
use Clone qw(clone); |
|
55
|
|
|
|
|
|
|
use Hash::Merge qw(merge); |
|
56
|
|
|
|
|
|
|
use Locale::gettext; |
|
57
|
|
|
|
|
|
|
use Digest::MD5 qw(md5_hex); |
|
58
|
|
|
|
|
|
|
use HTML::FormEngine::DBSQL::SkinClassic; |
|
59
|
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
###################################################################### |
|
61
|
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=head1 SYNOPSIS |
|
63
|
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=head2 Example Code |
|
65
|
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
#!/usr/bin/perl -w |
|
67
|
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
use strict; |
|
69
|
|
|
|
|
|
|
use HTML::FormEngine::DBSQL; |
|
70
|
|
|
|
|
|
|
use DBI; |
|
71
|
|
|
|
|
|
|
use CGI; |
|
72
|
|
|
|
|
|
|
#use POSIX; #for setlocale |
|
73
|
|
|
|
|
|
|
#setlocale(LC_MESSAGES, 'german'); #for german error messages |
|
74
|
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
my $q = new CGI; |
|
76
|
|
|
|
|
|
|
print $q->header; |
|
77
|
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my $dbh = DBI->connect('dbi:Pg:dbname=test', 'test', 'test'); |
|
79
|
|
|
|
|
|
|
my $Form = HTML::FormEngine::DBSQL->new(scalar $q->Vars, $dbh); |
|
80
|
|
|
|
|
|
|
$Form->dbsql_conf('user'); |
|
81
|
|
|
|
|
|
|
$Form->make(); |
|
82
|
|
|
|
|
|
|
print $q->start_html('FormEngine-dbsql example: User Administration'); |
|
83
|
|
|
|
|
|
|
if($Form->ok) { |
|
84
|
|
|
|
|
|
|
if($_ = $Form->dbsql_insert()) { |
|
85
|
|
|
|
|
|
|
print "Sucessfully added $_ user(s)!
"; |
|
86
|
|
|
|
|
|
|
$Form->clear; |
|
87
|
|
|
|
|
|
|
} |
|
88
|
|
|
|
|
|
|
} |
|
89
|
|
|
|
|
|
|
print $Form->get, |
|
90
|
|
|
|
|
|
|
$q->end_html; |
|
91
|
|
|
|
|
|
|
$dbh->disconnect; |
|
92
|
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=head2 Example Database Table |
|
94
|
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
Execute the following (Postgre)SQL commands to create the tables I used when developing the examples: |
|
96
|
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
CREATE SEQUENCE user_uid_seq; |
|
98
|
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
CREATE TABLE "user" ( |
|
100
|
|
|
|
|
|
|
uid integer DEFAULT nextval('user_uid_seq'::text) NOT NULL, |
|
101
|
|
|
|
|
|
|
name character varying(40) NOT NULL, |
|
102
|
|
|
|
|
|
|
forename character varying(40) NOT NULL, |
|
103
|
|
|
|
|
|
|
street character varying(40) NOT NULL, |
|
104
|
|
|
|
|
|
|
zip integer NOT NULL, |
|
105
|
|
|
|
|
|
|
town character varying(40) NOT NULL, |
|
106
|
|
|
|
|
|
|
email character varying(40) NOT NULL, |
|
107
|
|
|
|
|
|
|
phone character varying(15)[] DEFAULT '{"",""}'::character varying[], |
|
108
|
|
|
|
|
|
|
birthday date NOT NULL, |
|
109
|
|
|
|
|
|
|
newsletter boolean DEFAULT true |
|
110
|
|
|
|
|
|
|
); |
|
111
|
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
CREATE TABLE login ( |
|
113
|
|
|
|
|
|
|
uid integer DEFAULT currval('user_uid_seq'::text) NOT NULL, |
|
114
|
|
|
|
|
|
|
username character varying(30) DEFAULT '-'::character varying NOT NULL, |
|
115
|
|
|
|
|
|
|
"password" character varying(30) DEFAULT '-'::character varying NOT NULL |
|
116
|
|
|
|
|
|
|
); |
|
117
|
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
ALTER TABLE ONLY "user" |
|
120
|
|
|
|
|
|
|
ADD CONSTRAINT user_pkey PRIMARY KEY (uid); |
|
121
|
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
ALTER TABLE ONLY login |
|
123
|
|
|
|
|
|
|
ADD CONSTRAINT login_pkey PRIMARY KEY (uid); |
|
124
|
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
ALTER TABLE ONLY login |
|
126
|
|
|
|
|
|
|
ADD CONSTRAINT "$1" FOREIGN KEY (uid) REFERENCES "user"(uid) MATCH FULL ON UPDATE CASCADE ON DELETE CASCADE; |
|
127
|
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
COMMENT ON COLUMN "user".zip IS 'ERROR=digitonly;'; |
|
129
|
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
COMMENT ON COLUMN "user".email IS 'ERROR=rfc822;'; |
|
131
|
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
COMMENT ON COLUMN "user".phone IS 'display_as={{,}};ERROR_IN={{{not_null,digitonly},{not_null,digitonly}}};SUBTITLE={{,/}};SIZE={{5,10}};'; |
|
133
|
|
|
|
|
|
|
COMMENT ON COLUMN login.username IS 'ERROR={{regex,"must only contain A-Z, a-z and 0-9","^[A-Za-z0-9]+$"},unique,dbsql_unique};'; |
|
134
|
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
COMMENT ON COLUMN login."password" IS 'TYPE=password;VALUE=;ERROR={{regex,"must have more than 4 chars",".{5,}"}};'; |
|
136
|
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
Of course you can use any other table(s) as well. The file C in the examples directory contains the whole database dump. |
|
138
|
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head2 Example Output |
|
140
|
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
This output is produced by FormEngine::DBSQL when using the example |
|
142
|
|
|
|
|
|
|
code, the example table and no data was submitted: |
|
143
|
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=head1 DESCRIPTION |
|
406
|
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
DBSQL.pm is an exentsion of HTML::FormEngine, that means it inherits |
|
408
|
|
|
|
|
|
|
all functionality from HTML::FormEngine and adds some new features. |
|
409
|
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
In web development, form data is mostly used to update a database. For |
|
411
|
|
|
|
|
|
|
example most guestbooks or any similar webapplication store the |
|
412
|
|
|
|
|
|
|
entered data in a database. Often very large forms are needed, |
|
413
|
|
|
|
|
|
|
e.g. when the user should provide his personal data to subscribe to an |
|
414
|
|
|
|
|
|
|
certain service. |
|
415
|
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
In most cases a SQL database is used. If you don't know anything about |
|
417
|
|
|
|
|
|
|
SQL databases or you're not using such things, this module will hardly |
|
418
|
|
|
|
|
|
|
help you. But if you do, you'll know that every record, that you want |
|
419
|
|
|
|
|
|
|
to store in a certain SQL database table, has to have certain fields |
|
420
|
|
|
|
|
|
|
and these fields must contain data of an certain type (datatype). So |
|
421
|
|
|
|
|
|
|
the tables structure already defines how a form, that wants to add |
|
422
|
|
|
|
|
|
|
data to this table, might look like (in case that you don't want to |
|
423
|
|
|
|
|
|
|
process the whole data before adding it to the table). |
|
424
|
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
DBSQL.pm reads out the tables structure and creates a form definition |
|
426
|
|
|
|
|
|
|
for HTML::FormEngine. |
|
427
|
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
Two examples: |
|
429
|
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
A field of type boolean will only accept 0 or 1, this is represented |
|
431
|
|
|
|
|
|
|
in the form as 'Yes' or 'No'. |
|
432
|
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
a field of type VARCHAR(30) will accept strings of maximal 30 |
|
434
|
|
|
|
|
|
|
characters, so it's represented as an one-line-text-input-field in |
|
435
|
|
|
|
|
|
|
which you can put maximal 30 characters. |
|
436
|
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
Of course you can re-adjust the resulting form configuration, |
|
438
|
|
|
|
|
|
|
but in most cases you don't have to care about it! |
|
439
|
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
DBSQL.pm also provides methods for adding and updating records. So you |
|
441
|
|
|
|
|
|
|
don't have to deal with sql commands. |
|
442
|
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
HTML::FormEngine::DBSQL was only tested with B so far, but |
|
444
|
|
|
|
|
|
|
it should also work with other DBMS, like e.g. MySQL. |
|
445
|
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=head1 OVERVIEW |
|
447
|
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
We expect that you know how to use HTML::FormEngine, if not, please |
|
449
|
|
|
|
|
|
|
first read its documentation. Using HTML::FormEngine:DBSQL isn't much |
|
450
|
|
|
|
|
|
|
diffrent: the C method is replaced by C and you may |
|
451
|
|
|
|
|
|
|
pass a database handle as second argument to the C method, using |
|
452
|
|
|
|
|
|
|
C is possible too. Before calling C, you |
|
453
|
|
|
|
|
|
|
may call C for setting some variables by hand. |
|
454
|
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
To C you pass the tables name and optionally a where |
|
456
|
|
|
|
|
|
|
condition (for updating records) and/or a reference to an array with |
|
457
|
|
|
|
|
|
|
fieldnames (for setting explicit which fields to show resp. not to |
|
458
|
|
|
|
|
|
|
show). |
|
459
|
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=head1 USING FormEngine::DBSQL |
|
461
|
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
=head2 Configuring The Form Through The Database |
|
463
|
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=head3 datatype handlers |
|
465
|
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
In DBSQL::DtHandler.pm you'll find all datatype handlers which come |
|
467
|
|
|
|
|
|
|
with this module. Which handler to use for which datatype is defined |
|
468
|
|
|
|
|
|
|
in DBSQL::SkinClassic, the default FormEngine skin for this module. If |
|
469
|
|
|
|
|
|
|
for a certain datatype no handler is defined, the default datatype |
|
470
|
|
|
|
|
|
|
handler will be called. |
|
471
|
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
A handler creates the main part of the form field configuration. |
|
473
|
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
You can easily add your own datatype handlers (see below). |
|
475
|
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=head3 array handling |
|
477
|
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
Though the idea how to store arrays is taken from PostgreSQL, this |
|
479
|
|
|
|
|
|
|
should work with any other DBMS too! |
|
480
|
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
In PostgreSQL every datatype can be arrayed. PostgreSQL arrays have |
|
482
|
|
|
|
|
|
|
the following structure: '{firstelem,secondelem}', a two dimensional |
|
483
|
|
|
|
|
|
|
array looks like this: '{{one,two},{three,four}}'. The problem is |
|
484
|
|
|
|
|
|
|
that PostgreSQL arrays don't have a fixed size, but FormEngine::DBSQL |
|
485
|
|
|
|
|
|
|
need such to represent the array in the form. Here we use a trick: the |
|
486
|
|
|
|
|
|
|
size which should be represented in the form is determined by the |
|
487
|
|
|
|
|
|
|
default value. So a field with '{,}' as default value will be |
|
488
|
|
|
|
|
|
|
represented as an one dimensional array (in case you specify |
|
489
|
|
|
|
|
|
|
C it'll be displayed according to that, see below). Of |
|
490
|
|
|
|
|
|
|
course you can put values between the commas, which will then be |
|
491
|
|
|
|
|
|
|
printed as defaults. |
|
492
|
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
The following feature might sound a bit complicated, don't worry about |
|
494
|
|
|
|
|
|
|
it, you'll normaly not need it. |
|
495
|
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
There are two special variables which make array handling more |
|
497
|
|
|
|
|
|
|
flexible. C can be used to specify how a database array |
|
498
|
|
|
|
|
|
|
shall be represented in the form, C works in the other |
|
499
|
|
|
|
|
|
|
direction, it defines in which format an array submitted by the form |
|
500
|
|
|
|
|
|
|
is written in the database. This is probably a bit hard to understand, |
|
501
|
|
|
|
|
|
|
so here is an example: you could save a telefon number in one database |
|
502
|
|
|
|
|
|
|
field which is of type integer[] (integer array). The first element is |
|
503
|
|
|
|
|
|
|
the code, the second the number. Of course in the database this is a |
|
504
|
|
|
|
|
|
|
one dimensional array. But when the telefon field is now represented |
|
505
|
|
|
|
|
|
|
by the form the one dimensional array will probably cause the two |
|
506
|
|
|
|
|
|
|
fields to be on two diffrent rows, so you want to turn the one |
|
507
|
|
|
|
|
|
|
dimensional array into an two dimensional array just by adding one |
|
508
|
|
|
|
|
|
|
more dimension. This is simply done by setting C in |
|
509
|
|
|
|
|
|
|
the database field comment (see L
|
|
510
|
|
|
|
|
|
|
the database>). Same with C. So if you specify |
|
511
|
|
|
|
|
|
|
e.g. C<{{,}{,}}> for one of these variables it'll cause an array like |
|
512
|
|
|
|
|
|
|
C<[1,2,3,4]> to be turned into C<[[1,2][3,4]]>. The elements are |
|
513
|
|
|
|
|
|
|
simply read from left to right and putted into the template also from |
|
514
|
|
|
|
|
|
|
left to right. |
|
515
|
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
=head3 NOT NULL fields |
|
518
|
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
The form value of fields which have the NOT NULL property will be |
|
520
|
|
|
|
|
|
|
automatically passed to the I check method. This means that |
|
521
|
|
|
|
|
|
|
their I variable will be set to I. |
|
522
|
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
If the I variable was already set through C, |
|
524
|
|
|
|
|
|
|
nothing will be changed. If the variable was set through the fields |
|
525
|
|
|
|
|
|
|
comment (see L), the |
|
526
|
|
|
|
|
|
|
I check will be added in front. |
|
527
|
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
If you called C the not_null check is |
|
529
|
|
|
|
|
|
|
probably not added since a field which will just be ignored if empty |
|
530
|
|
|
|
|
|
|
doesn't have to be checked whether it is empty. Read |
|
531
|
|
|
|
|
|
|
L for more information. |
|
532
|
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
=head3 assigning FormEngine variables in the database |
|
534
|
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
PostgreSQL and other DBMS offer to set comments on database |
|
536
|
|
|
|
|
|
|
objects. This feature can be used to explicitly set form field |
|
537
|
|
|
|
|
|
|
variables in the database. |
|
538
|
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
You might e.g. want to store emailadresses in a certain field of a |
|
540
|
|
|
|
|
|
|
database table, it makes sense to validate an address before inserting |
|
541
|
|
|
|
|
|
|
it. First possibility is to use C to set the ERROR |
|
542
|
|
|
|
|
|
|
variable to 'email' or 'rfc822', but perhaps you've more than one |
|
543
|
|
|
|
|
|
|
script which inserts or updates the table and so you're using several |
|
544
|
|
|
|
|
|
|
forms. In every script you now have to call the C |
|
545
|
|
|
|
|
|
|
method and set the ERROR variable for the email field. This isn't |
|
546
|
|
|
|
|
|
|
nice, because the necessity to check this field is given by the table |
|
547
|
|
|
|
|
|
|
structure and so the check should also be set by the database. You |
|
548
|
|
|
|
|
|
|
might set a check constraint, but this will cause an ugly database |
|
549
|
|
|
|
|
|
|
error which the user might not understand. So beside defining an |
|
550
|
|
|
|
|
|
|
constraint (which is recommended), FormEngine::DBSQL should check the |
|
551
|
|
|
|
|
|
|
address before inserting it. Setting the database fields comment to |
|
552
|
|
|
|
|
|
|
'ERROR=rfc822;' will force FormEngine::DBSQL to do so. You can still |
|
553
|
|
|
|
|
|
|
overwrite this setting with C. |
|
554
|
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
Below you see the whole command: |
|
556
|
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
COMMENT ON COLUMN "user".email IS 'ERROR=rfc822;' |
|
558
|
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
Whenever you pass this tables name to the C method of |
|
560
|
|
|
|
|
|
|
FormEngine::DBSQL, it'll remember to call the rfc822 check method |
|
561
|
|
|
|
|
|
|
before inserting or updating a I field value. |
|
562
|
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
You can even assign array structures to a variable: |
|
564
|
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
COMMENT ON COLUMN "user".phone IS 'ERROR_IN={{{not_null,digitonly},{not_null,digitonly}}};'; |
|
566
|
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
The I field is a string array, with the above command we |
|
568
|
|
|
|
|
|
|
forbid NULL values and demand digits for the first two elements. More |
|
569
|
|
|
|
|
|
|
about arrays and their representation in the form is described above |
|
570
|
|
|
|
|
|
|
(L). |
|
571
|
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
It is possible to assign several variables: |
|
573
|
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
COMMENT ON COLUMN "user".zip IS 'ERROR=digitonly;TITLE=Postcode;'; |
|
575
|
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
Don't forget the ';' at the end of every assignment! |
|
577
|
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
Of course you can still use the comment field to place normal comments |
|
579
|
|
|
|
|
|
|
there as well: |
|
580
|
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
COMMENT ON COLUMN "user".birthday IS 'We\'re really a bit curious!;ERROR=date;'; |
|
582
|
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
Note the ';' at the end of the trivial comment! |
|
584
|
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
In quoted areas ("..") '{', '}' and ',' are not interpreted. You can |
|
586
|
|
|
|
|
|
|
prevent the parsing of '"' and ';' by putting an '\' (backslash) in |
|
587
|
|
|
|
|
|
|
front. |
|
588
|
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=head2 Methods |
|
590
|
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
=head3 new ([ HASHREF, DBHANDLE ]) |
|
592
|
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
Works exactly like Ls C method but accepts a |
|
594
|
|
|
|
|
|
|
second parameter, the database handle. This is needed for |
|
595
|
|
|
|
|
|
|
communicating with the database. Alternatively it can be set through |
|
596
|
|
|
|
|
|
|
L. |
|
597
|
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=head3 dbsql_preconf ( HASHREF, PREPEND, APPEND ) |
|
599
|
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
In the referenced hash you can predefine some parts of the form |
|
601
|
|
|
|
|
|
|
configuration by hand. The hash keys must be named after the tables |
|
602
|
|
|
|
|
|
|
fields. Every element must be a hash reference, in the referenced hash |
|
603
|
|
|
|
|
|
|
you can set variables. |
|
604
|
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
You can use the special keys I and I to add extra |
|
606
|
|
|
|
|
|
|
fields before or after the field. |
|
607
|
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
An example: |
|
609
|
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
my %preconf = ( |
|
611
|
|
|
|
|
|
|
name => { |
|
612
|
|
|
|
|
|
|
TITLE => 'Fore- and Surname', |
|
613
|
|
|
|
|
|
|
ERROR => sub {$_ = shift; m/\w\W\w/ ? return 0 : return 'failed';} |
|
614
|
|
|
|
|
|
|
}, |
|
615
|
|
|
|
|
|
|
email => { |
|
616
|
|
|
|
|
|
|
TITLE => 'Your Emailadress', |
|
617
|
|
|
|
|
|
|
ERROR => 'email' |
|
618
|
|
|
|
|
|
|
} |
|
619
|
|
|
|
|
|
|
); |
|
620
|
|
|
|
|
|
|
$Form->dbsql_preconf(\%preconf); |
|
621
|
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
The field definitions passed for PREPEND or APPEND are added to the |
|
624
|
|
|
|
|
|
|
top resp. the bottom of the generated form. If you want to add more |
|
625
|
|
|
|
|
|
|
than one field, you have to reference an array which contains the |
|
626
|
|
|
|
|
|
|
definitions, else you can reference the hash directly. See the |
|
627
|
|
|
|
|
|
|
L for information about field definitions. |
|
628
|
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
When using the special key format I<__add_VARNAME_last> |
|
630
|
|
|
|
|
|
|
resp. I<__add_VARNAME_first> the given values are added at the |
|
631
|
|
|
|
|
|
|
beginning resp. the end of the (probably) already existing value |
|
632
|
|
|
|
|
|
|
list. Of course you have to replace I with the name of the |
|
633
|
|
|
|
|
|
|
variable to which you want to add something. If the sofar specified |
|
634
|
|
|
|
|
|
|
value of the variable is a scalar its automatically turned into an |
|
635
|
|
|
|
|
|
|
array. |
|
636
|
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
B If you pass more than one table name to C, you |
|
638
|
|
|
|
|
|
|
must reference the fields with I! |
|
639
|
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
=cut |
|
641
|
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
###################################################################### |
|
643
|
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
sub dbsql_preconf { |
|
645
|
|
|
|
|
|
|
my ($self,$preconf,$prepend,$append) = @_; |
|
646
|
|
|
|
|
|
|
if(ref($preconf) eq 'HASH') { |
|
647
|
|
|
|
|
|
|
$self->{dbsql_preconf} = merge($preconf, $self->{dbsql_preconf}); |
|
648
|
|
|
|
|
|
|
} |
|
649
|
|
|
|
|
|
|
#rettarref returns an array reference |
|
650
|
|
|
|
|
|
|
$self->{dbsql_prepend} = retarref($prepend); |
|
651
|
|
|
|
|
|
|
$self->{dbsql_append} = retarref($append); |
|
652
|
|
|
|
|
|
|
} |
|
653
|
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
###################################################################### |
|
655
|
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
=head3 dbsql_conf ( ... ) |
|
657
|
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
The three dots stand for: |
|
659
|
|
|
|
|
|
|
C |
|
660
|
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
This method creates a FormEngine-form-definition and calls FormEngines |
|
662
|
|
|
|
|
|
|
C method. |
|
663
|
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
Normally you only want to manage records out of one table, then it is |
|
665
|
|
|
|
|
|
|
sufficient to give this tables name as first argument. But you can |
|
666
|
|
|
|
|
|
|
also pass several table names by using an array reference. |
|
667
|
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
If you provide COUNT, the form fields will be displayed COUNT times, |
|
669
|
|
|
|
|
|
|
which means that you can insert COUNT records. |
|
670
|
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
If you want to update records, you should provide WHERECONDITION |
|
672
|
|
|
|
|
|
|
instead. This must be a valid where-condition B the C |
|
673
|
|
|
|
|
|
|
directive in front, or a hash reference. A hash reference you must |
|
674
|
|
|
|
|
|
|
provide if you passed several tablenames and want to define diffrent |
|
675
|
|
|
|
|
|
|
where conditions for theses tables. The keys must be the table names |
|
676
|
|
|
|
|
|
|
and the elements the complying conditions. |
|
677
|
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
DBSQL then shows input fields for every found record and uses the |
|
679
|
|
|
|
|
|
|
current values as defaults. The primary keys are stored in hidden |
|
680
|
|
|
|
|
|
|
fields, so that they can't be changed. Later they're used for updating |
|
681
|
|
|
|
|
|
|
the records. |
|
682
|
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
If you'd like to set only some of the tables fields, put their names |
|
684
|
|
|
|
|
|
|
in an array and pass a reference as third and last argument |
|
685
|
|
|
|
|
|
|
(FIELDNAMES). If the first array element is '!', all fields which |
|
686
|
|
|
|
|
|
|
B found in the array will be displayed. You must use a hash |
|
687
|
|
|
|
|
|
|
reference here if you passed more than one table name. |
|
688
|
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
=cut |
|
690
|
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
###################################################################### |
|
692
|
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
sub dbsql_conf { |
|
694
|
|
|
|
|
|
|
my ($self,$table,$where,$fields) = @_; |
|
695
|
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
$self->{dbsql_tables} = retarref($table || $self->{dbsql_tables}); |
|
697
|
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
if(! defined($self->{dbsql_tables}) || ! @{$self->{dbsql_tables}}) { |
|
699
|
|
|
|
|
|
|
croak 'table not defined!'; |
|
700
|
|
|
|
|
|
|
} |
|
701
|
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
$self->{dbsql_where} = $where || $self->{dbsql_where}; |
|
703
|
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
$self->{dbsql_fields} = $fields || $self->{dbsql_fields}; |
|
705
|
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
#if the user references fields out of diffrent tables he must say which fields belong to which table |
|
707
|
|
|
|
|
|
|
if(@{$self->{dbsql_tables}} > 1 && ref($self->{dbsql_fields}) ne 'HASH') { |
|
708
|
|
|
|
|
|
|
croak 'fields must be assigned to tables!'; |
|
709
|
|
|
|
|
|
|
} |
|
710
|
|
|
|
|
|
|
#in the case that we've only one table the user can be lazy and we transform into hash notation |
|
711
|
|
|
|
|
|
|
elsif(@{$self->{dbsql_tables}} == 1 && ref($self->{dbsql_fields}) ne 'HASH') { |
|
712
|
|
|
|
|
|
|
$self->{dbsql_fields} = {$self->{dbsql_tables}->[0] => retarref($self->{dbsql_fields})}; |
|
713
|
|
|
|
|
|
|
} |
|
714
|
|
|
|
|
|
|
#the user could have setted dbsql_pkey before through dbsql_set_pkey |
|
715
|
|
|
|
|
|
|
#if its not a hash he defined them only for one table |
|
716
|
|
|
|
|
|
|
if(ref($self->{dbsql_pkey}) ne 'HASH') { |
|
717
|
|
|
|
|
|
|
$_ = retarref($self->{dbsql_pkey}); |
|
718
|
|
|
|
|
|
|
$self->{dbsql_pkey} = {$self->{dbsql_tables}->[0] => {}}; |
|
719
|
|
|
|
|
|
|
foreach $_ (@{$_}) { |
|
720
|
|
|
|
|
|
|
$self->{dbsql_pkey}->{$self->{dbsql_tables}->[0]}->{$_} = 1; |
|
721
|
|
|
|
|
|
|
} |
|
722
|
|
|
|
|
|
|
} |
|
723
|
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
my ($count, $where_cond); |
|
725
|
|
|
|
|
|
|
#if we have a number we don't have a sql where condition, that means we're just asked to repeat the fields $count time |
|
726
|
|
|
|
|
|
|
if(! ref($self->{dbsql_where}) and $self->{dbsql_where} =~ m/^[0-9]+$/) { |
|
727
|
|
|
|
|
|
|
$count = $self->{dbsql_where}; |
|
728
|
|
|
|
|
|
|
} else { |
|
729
|
|
|
|
|
|
|
#since we have a where condition we'll display the fields content and not the default |
|
730
|
|
|
|
|
|
|
$self->dbsql_set_show_default(0) if($self->{dbsql_show_default} == 1); |
|
731
|
|
|
|
|
|
|
#if a scalar was given we've to turn it into a hash ({table => wherecondition}) |
|
732
|
|
|
|
|
|
|
if(ref($self->{dbsql_where}) ne 'HASH') { |
|
733
|
|
|
|
|
|
|
$where_cond = $self->{dbsql_where}; |
|
734
|
|
|
|
|
|
|
$self->{dbsql_where} = {}; |
|
735
|
|
|
|
|
|
|
} else { |
|
736
|
|
|
|
|
|
|
$where_cond = ''; |
|
737
|
|
|
|
|
|
|
} |
|
738
|
|
|
|
|
|
|
} |
|
739
|
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
my %donotuse; |
|
741
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
742
|
|
|
|
|
|
|
#if no fields are given we just take all |
|
743
|
|
|
|
|
|
|
if(ref($self->{dbsql_fields}->{$tbl}) ne 'ARRAY' or ! @{$self->{dbsql_fields}->{$tbl}}) { |
|
744
|
|
|
|
|
|
|
$self->{dbsql_fields}->{$tbl} = [undef]; |
|
745
|
|
|
|
|
|
|
} |
|
746
|
|
|
|
|
|
|
#$where_cond is '' if nothing was given or if just a scalar was given it is set to that one |
|
747
|
|
|
|
|
|
|
$self->{dbsql_where}->{$tbl} = $where_cond if(ref($self->{dbsql_where}) eq 'HASH' && ! defined($self->{dbsql_where}->{$tbl})); |
|
748
|
|
|
|
|
|
|
#if the first field of the dbsql_fields array is '!' it means that the following fields should not be selected |
|
749
|
|
|
|
|
|
|
$donotuse{$tbl} = {}; |
|
750
|
|
|
|
|
|
|
if(defined($self->{dbsql_fields}->{$tbl}->[0]) and $self->{dbsql_fields}->{$tbl}->[0] eq '!') { |
|
751
|
|
|
|
|
|
|
delete $self->{dbsql_fields}->{$tbl}->[0]; |
|
752
|
|
|
|
|
|
|
foreach $_ (@{$self->{dbsql_fields}->{$tbl}}) { |
|
753
|
|
|
|
|
|
|
$donotuse{$tbl}->{$_} = 1; |
|
754
|
|
|
|
|
|
|
} |
|
755
|
|
|
|
|
|
|
#select all, $donotuse will be used later |
|
756
|
|
|
|
|
|
|
$self->{dbsql_fields}->{$tbl} = [undef]; |
|
757
|
|
|
|
|
|
|
} |
|
758
|
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
#no pkey was defined, so we've to get it/them |
|
760
|
|
|
|
|
|
|
if(! defined($self->{dbsql_pkey}->{$tbl})) { |
|
761
|
|
|
|
|
|
|
$self->{dbsql_pkey}->{$tbl} = {}; |
|
762
|
|
|
|
|
|
|
foreach $_ ($self->{dbsql}->primary_key(undef, undef, $tbl)) { |
|
763
|
|
|
|
|
|
|
my $field = (@{$self->{dbsql_tables}} > 1 ? "$tbl.$_" : $_); |
|
764
|
|
|
|
|
|
|
#like this we can prove better whether a certain field is part of the pkey or not |
|
765
|
|
|
|
|
|
|
$self->{dbsql_pkey}->{$tbl}->{$field} = 1; |
|
766
|
|
|
|
|
|
|
} |
|
767
|
|
|
|
|
|
|
} |
|
768
|
|
|
|
|
|
|
} |
|
769
|
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
my @fconf; |
|
771
|
|
|
|
|
|
|
#configurations saved in dbsql_prepend must be added to the top |
|
772
|
|
|
|
|
|
|
if(defined($self->{dbsql_prepend})) { |
|
773
|
|
|
|
|
|
|
push @fconf, @{retarref($self->{dbsql_prepend})}; |
|
774
|
|
|
|
|
|
|
} |
|
775
|
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
777
|
|
|
|
|
|
|
#get the tables structure |
|
778
|
|
|
|
|
|
|
my @fields = @{$self->{dbsql_fields}->{$tbl}}; |
|
779
|
|
|
|
|
|
|
$self->{dbsql_fields}->{$tbl} = []; |
|
780
|
|
|
|
|
|
|
foreach my $field (@fields) { |
|
781
|
|
|
|
|
|
|
my $sth = $self->{dbsql}->column_info(undef, undef, $tbl, $field); |
|
782
|
|
|
|
|
|
|
$sth->execute; |
|
783
|
|
|
|
|
|
|
while(my $fstruct = $sth->fetchrow_hashref()) { |
|
784
|
|
|
|
|
|
|
#jump over fields that shall not be displayed |
|
785
|
|
|
|
|
|
|
next if($donotuse{$tbl}->{$fstruct->{COLUMN_NAME}}); |
|
786
|
|
|
|
|
|
|
#$_ now contains the form configuration for that field |
|
787
|
|
|
|
|
|
|
local $_ = $self->_dbsql_makeconf($fstruct, $tbl); |
|
788
|
|
|
|
|
|
|
#now we push only the fields that we really want |
|
789
|
|
|
|
|
|
|
push @{$self->{dbsql_fields}->{$tbl}}, $_->{fname}; |
|
790
|
|
|
|
|
|
|
if(defined($_->{prepend})) { |
|
791
|
|
|
|
|
|
|
push @fconf, @{retarref($_->{prepend})}; |
|
792
|
|
|
|
|
|
|
delete $_->{prepend}; |
|
793
|
|
|
|
|
|
|
} |
|
794
|
|
|
|
|
|
|
push @fconf, $_; |
|
795
|
|
|
|
|
|
|
# in case form field name and db table field name differ |
|
796
|
|
|
|
|
|
|
$self->{dbsql_save_as}->{$_->{NAME}} = $_->{save_as} if(defined($_->{save_as})); |
|
797
|
|
|
|
|
|
|
if(defined($_->{append})) { |
|
798
|
|
|
|
|
|
|
push @fconf, @{retarref($_->{append})}; |
|
799
|
|
|
|
|
|
|
delete $_->{append}; |
|
800
|
|
|
|
|
|
|
} |
|
801
|
|
|
|
|
|
|
} |
|
802
|
|
|
|
|
|
|
$sth->finish; |
|
803
|
|
|
|
|
|
|
} |
|
804
|
|
|
|
|
|
|
} |
|
805
|
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
if(defined($self->{dbsql_append})) { |
|
807
|
|
|
|
|
|
|
push @fconf, @{retarref($self->{dbsql_append})}; |
|
808
|
|
|
|
|
|
|
} |
|
809
|
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
#delete primary key fields which are not going to be selected |
|
811
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
812
|
|
|
|
|
|
|
foreach my $field (keys(%{$self->{dbsql_pkey}->{$tbl}})) { |
|
813
|
|
|
|
|
|
|
delete $self->{dbsql_pkey}->{$tbl}->{$field} unless(grep {$field eq $_} @{$self->{dbsql_fields}->{$tbl}}); |
|
814
|
|
|
|
|
|
|
} |
|
815
|
|
|
|
|
|
|
} |
|
816
|
|
|
|
|
|
|
my %value; |
|
817
|
|
|
|
|
|
|
#seems that we shall get the contents of the table fields |
|
818
|
|
|
|
|
|
|
if(! defined($count)) { |
|
819
|
|
|
|
|
|
|
$count = -254; |
|
820
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
821
|
|
|
|
|
|
|
my $sql = 'SELECT '; |
|
822
|
|
|
|
|
|
|
foreach $_ (@{$self->{dbsql_fields}->{$tbl}}) { |
|
823
|
|
|
|
|
|
|
if(m/^(.+)?\.(.+)/) { |
|
824
|
|
|
|
|
|
|
$sql .= $self->{dbsql}->quote_identifier($1) . '.' . $self->{dbsql}->quote_identifier($2); |
|
825
|
|
|
|
|
|
|
} |
|
826
|
|
|
|
|
|
|
else { |
|
827
|
|
|
|
|
|
|
$sql .= $self->{dbsql}->quote_identifier($_); |
|
828
|
|
|
|
|
|
|
} |
|
829
|
|
|
|
|
|
|
$sql .= ','; |
|
830
|
|
|
|
|
|
|
} |
|
831
|
|
|
|
|
|
|
$sql =~ s/,$//; |
|
832
|
|
|
|
|
|
|
$sql .= ' FROM ' . $self->{dbsql}->quote_identifier($tbl); |
|
833
|
|
|
|
|
|
|
if($self->{dbsql_where}->{$tbl} ne '') { |
|
834
|
|
|
|
|
|
|
$sql .= ' WHERE '.$self->{dbsql_where}->{$tbl}; |
|
835
|
|
|
|
|
|
|
} |
|
836
|
|
|
|
|
|
|
my $sth = $self->{dbsql}->prepare($sql); |
|
837
|
|
|
|
|
|
|
if(! $sth->execute) { |
|
838
|
|
|
|
|
|
|
carp($self->{dbsql}->errstr); |
|
839
|
|
|
|
|
|
|
$self->_dbsql_sql_error($sth->{Statement}); |
|
840
|
|
|
|
|
|
|
return 0; |
|
841
|
|
|
|
|
|
|
} |
|
842
|
|
|
|
|
|
|
else { |
|
843
|
|
|
|
|
|
|
#count was not set so we now set it on the number of data records |
|
844
|
|
|
|
|
|
|
if($count == -254) { |
|
845
|
|
|
|
|
|
|
$count = $sth->rows; |
|
846
|
|
|
|
|
|
|
} |
|
847
|
|
|
|
|
|
|
#the whole thing cannot work if the results for the tables used for the forms don't have the same count of records |
|
848
|
|
|
|
|
|
|
elsif($count ne $sth->rows) { |
|
849
|
|
|
|
|
|
|
croak('There must be the same count of records for each table!'); |
|
850
|
|
|
|
|
|
|
} |
|
851
|
|
|
|
|
|
|
#only if dbsql_show_value is set we shall display the current value of the db fields |
|
852
|
|
|
|
|
|
|
while($self->{dbsql_show_value} && (my $record = $sth->fetchrow_hashref)) { |
|
853
|
|
|
|
|
|
|
local $_; |
|
854
|
|
|
|
|
|
|
foreach $_ (keys(%{$record})) { |
|
855
|
|
|
|
|
|
|
#we've to prepend the table name in case we've several tables |
|
856
|
|
|
|
|
|
|
my $field = (@{$self->{dbsql_tables}} > 1 ? "$tbl.$_" : $_); |
|
857
|
|
|
|
|
|
|
if(ref($value{$field}) ne 'ARRAY') { |
|
858
|
|
|
|
|
|
|
$value{$field} = []; |
|
859
|
|
|
|
|
|
|
} |
|
860
|
|
|
|
|
|
|
#turn db arrays into perl arrays |
|
861
|
|
|
|
|
|
|
if(defined($record->{$_}) and $record->{$_} =~ m/^\{.*\}$/) { |
|
862
|
|
|
|
|
|
|
push @{$value{$field}}, $self->_dbsql_parse($record->{$_}); |
|
863
|
|
|
|
|
|
|
} |
|
864
|
|
|
|
|
|
|
else { |
|
865
|
|
|
|
|
|
|
push @{$value{$field}}, $record->{$_}; |
|
866
|
|
|
|
|
|
|
} |
|
867
|
|
|
|
|
|
|
} |
|
868
|
|
|
|
|
|
|
} |
|
869
|
|
|
|
|
|
|
} |
|
870
|
|
|
|
|
|
|
$sth->finish; |
|
871
|
|
|
|
|
|
|
} |
|
872
|
|
|
|
|
|
|
} |
|
873
|
|
|
|
|
|
|
my @conf; |
|
874
|
|
|
|
|
|
|
#dbsql_row says whether to print the fields belonging to one record in one line (1) or one per line (0) |
|
875
|
|
|
|
|
|
|
#if dbsql_row was not explicitly set but the count of records is > 1 the default behaviour shall be to use one line per record |
|
876
|
|
|
|
|
|
|
if($self->{dbsql_row} > 0 or $count > 1 and $self->{dbsql_row} == -254) { |
|
877
|
|
|
|
|
|
|
$self->{dbsql_row} = 1; |
|
878
|
|
|
|
|
|
|
my @title; |
|
879
|
|
|
|
|
|
|
#we've to remove the title out of the configuration and instead use an extra title template which just prints them once at top |
|
880
|
|
|
|
|
|
|
foreach $_ (@fconf) { |
|
881
|
|
|
|
|
|
|
push @title, $_->{TITLE} unless($self->{hidden}->{$_->{templ}}); |
|
882
|
|
|
|
|
|
|
$_->{TITLE} = ''; |
|
883
|
|
|
|
|
|
|
#we want the error message to be printed underneath and not at the right |
|
884
|
|
|
|
|
|
|
##$_->{templ} = $self->{skin_obj}->dbsql_errmsg_bottom($_->{templ}); |
|
885
|
|
|
|
|
|
|
} |
|
886
|
|
|
|
|
|
|
push @conf, {templ => 'title', TITLE => \@title}; |
|
887
|
|
|
|
|
|
|
} |
|
888
|
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
#get all primary key field names, we'll need that to get all pkey values and then create the md5 hash which ensures that none of the pkeys was altered |
|
890
|
|
|
|
|
|
|
my @pkey = (); |
|
891
|
|
|
|
|
|
|
foreach $_ (keys(%{$self->{dbsql_pkey}})) { |
|
892
|
|
|
|
|
|
|
push @pkey, keys(%{$self->{dbsql_pkey}->{$_}}); |
|
893
|
|
|
|
|
|
|
} |
|
894
|
|
|
|
|
|
|
my @pkeyval; |
|
895
|
|
|
|
|
|
|
#the configuration templates for each field is in @fconf, now we create the real form configuration |
|
896
|
|
|
|
|
|
|
for(my $i=0; $i<$count; $i++) { |
|
897
|
|
|
|
|
|
|
@pkeyval = (); |
|
898
|
|
|
|
|
|
|
my $record_conf = clone(\@fconf); |
|
899
|
|
|
|
|
|
|
if(keys(%value) || $self->{skin_obj}->get_dbsql_secret()) { |
|
900
|
|
|
|
|
|
|
foreach my $field (@$record_conf) { |
|
901
|
|
|
|
|
|
|
#we'v to set the default values to the corresponding database record |
|
902
|
|
|
|
|
|
|
if(keys(%value)) { |
|
903
|
|
|
|
|
|
|
if(defined($field->{fname}) && defined($value{$field->{fname}})) { |
|
904
|
|
|
|
|
|
|
#we shouldn't overwrite defaults setted by the user or by the database |
|
905
|
|
|
|
|
|
|
unless(defined($field->{VALUE})) { |
|
906
|
|
|
|
|
|
|
local $_; |
|
907
|
|
|
|
|
|
|
$_ = shift @{$value{$field->{fname}}}; |
|
908
|
|
|
|
|
|
|
#display_as describes in which format the value should be displayed |
|
909
|
|
|
|
|
|
|
if(ref($field->{display_as}) eq 'ARRAY') { |
|
910
|
|
|
|
|
|
|
$_ = [$_] unless(ref($_) eq 'ARRAY'); |
|
911
|
|
|
|
|
|
|
($field->{VALUE}) = _array2array($field->{display_as},[$self->_flatten_array(@{$_})]); |
|
912
|
|
|
|
|
|
|
} |
|
913
|
|
|
|
|
|
|
else { |
|
914
|
|
|
|
|
|
|
$field->{VALUE} = $_; |
|
915
|
|
|
|
|
|
|
} |
|
916
|
|
|
|
|
|
|
} |
|
917
|
|
|
|
|
|
|
} |
|
918
|
|
|
|
|
|
|
} |
|
919
|
|
|
|
|
|
|
#could be that the pkey value was setted by hand that's why we've to do this also when no value was fetched out of the database |
|
920
|
|
|
|
|
|
|
push @pkeyval, $field->{VALUE} if ($field->{fname} and $self->{skin_obj}->get_dbsql_secret() && grep {$_ eq $field->{fname}} @pkey); |
|
921
|
|
|
|
|
|
|
} |
|
922
|
|
|
|
|
|
|
} |
|
923
|
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
#create and add the md5hash field which ensures that the pkeys can't be altered |
|
925
|
|
|
|
|
|
|
$_ = md5_hex(join($self->{skin_obj}->get_dbsql_secret(), @pkeyval) . $self->{skin_obj}->get_dbsql_secret()); |
|
926
|
|
|
|
|
|
|
push @$record_conf, {templ => 'dbsql_hidden', NAME => 'md5hash', VALUE => $_} if(@pkeyval); |
|
927
|
|
|
|
|
|
|
#we probably shall put all fields belonging to one record in one row |
|
928
|
|
|
|
|
|
|
if($self->{dbsql_row} > 0) { |
|
929
|
|
|
|
|
|
|
#ROWNUM should be replaced by something else in feature releases |
|
930
|
|
|
|
|
|
|
push @conf, {templ => $self->{dbsql_row_tmpl}, ROWNUM => $i+1, sub => $record_conf}; |
|
931
|
|
|
|
|
|
|
} |
|
932
|
|
|
|
|
|
|
#one field per row |
|
933
|
|
|
|
|
|
|
else { |
|
934
|
|
|
|
|
|
|
#the empty template should insert space between each line (do we really need that???) |
|
935
|
|
|
|
|
|
|
push @conf, @$record_conf, {templ => $self->{dbsql_empty_tmpl}}; |
|
936
|
|
|
|
|
|
|
} |
|
937
|
|
|
|
|
|
|
} |
|
938
|
|
|
|
|
|
|
$self->set_seperate(1); |
|
939
|
|
|
|
|
|
|
#we place all in body because we probably use more than 3 columns (which is expected by the 'main' template) |
|
940
|
|
|
|
|
|
|
$self->conf([{templ => 'body', sub => \@conf}]); |
|
941
|
|
|
|
|
|
|
#DEBUGGING |
|
942
|
|
|
|
|
|
|
if($self->{debug}) { |
|
943
|
|
|
|
|
|
|
foreach $_ (@fconf) { |
|
944
|
|
|
|
|
|
|
print $_->{NAME}, "\n"; |
|
945
|
|
|
|
|
|
|
} |
|
946
|
|
|
|
|
|
|
} |
|
947
|
|
|
|
|
|
|
} |
|
948
|
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
###################################################################### |
|
950
|
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
=head3 dbsql_update |
|
952
|
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
This method can only be used if a where-condition was passed to |
|
954
|
|
|
|
|
|
|
L. |
|
955
|
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
It updates the found table records to the submitted |
|
957
|
|
|
|
|
|
|
values. If an error occurs the update statement and the DBMSs error |
|
958
|
|
|
|
|
|
|
message and number is printed. If you want only some of this |
|
959
|
|
|
|
|
|
|
information to be displayed, see L. |
|
960
|
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
Normally you must have defined a secret string if you want to use this |
|
962
|
|
|
|
|
|
|
method, else an error message will be printed. See L |
|
963
|
|
|
|
|
|
|
for more information. |
|
964
|
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
Before calling this method, you should prove that the form content is |
|
966
|
|
|
|
|
|
|
valid (see L, C method). |
|
967
|
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
=cut |
|
969
|
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
###################################################################### |
|
971
|
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
sub dbsql_update { |
|
973
|
|
|
|
|
|
|
my ($self) = @_; |
|
974
|
|
|
|
|
|
|
my ($md5hash, @pkeyval, @pkeyval2, $ok, $val, $tbl); |
|
975
|
|
|
|
|
|
|
local $_ = 0; |
|
976
|
|
|
|
|
|
|
#ensure that there's a primary key defined for every table |
|
977
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
978
|
|
|
|
|
|
|
$_ = $tbl and last unless(keys(%{$self->{dbsql_pkey}->{$tbl}})); |
|
979
|
|
|
|
|
|
|
} |
|
980
|
|
|
|
|
|
|
if($_) { |
|
981
|
|
|
|
|
|
|
#append at the form bottom |
|
982
|
|
|
|
|
|
|
$self->_add_to_output($self->{dbsql_errmsg_tmpl}, {ERRMSG => gettext('Primary key is missing for table') . ' \'' . $_ . '\'!'}); |
|
983
|
|
|
|
|
|
|
return 0; |
|
984
|
|
|
|
|
|
|
} |
|
985
|
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
#if dbsql_hide_pkey was set we must in anycase asure that pkey was not altered |
|
987
|
|
|
|
|
|
|
if($self->{dbsql_hide_pkey}) { |
|
988
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
989
|
|
|
|
|
|
|
local $_; |
|
990
|
|
|
|
|
|
|
foreach $_ (keys(%{$self->{dbsql_pkey}->{$tbl}})) { |
|
991
|
|
|
|
|
|
|
push @pkeyval, $self->get_input($_); |
|
992
|
|
|
|
|
|
|
} |
|
993
|
|
|
|
|
|
|
} |
|
994
|
|
|
|
|
|
|
my $md5hash = $self->get_input('md5hash'); |
|
995
|
|
|
|
|
|
|
$self->_add_to_output($self->{dbsql_errmsg_tmpl}, {ERRMSG => gettext('Can\'t update record(s) due to missing primary key checksum').'!'}) and return 0 unless($md5hash); |
|
996
|
|
|
|
|
|
|
my $ok; |
|
997
|
|
|
|
|
|
|
if(ref($md5hash) eq 'ARRAY') { |
|
998
|
|
|
|
|
|
|
$ok = 1; |
|
999
|
|
|
|
|
|
|
#get pkey value for each record and compare |
|
1000
|
|
|
|
|
|
|
foreach $_ (@{$md5hash}) { |
|
1001
|
|
|
|
|
|
|
@pkeyval2 = (); |
|
1002
|
|
|
|
|
|
|
foreach $val (@pkeyval) {push @pkeyval2, shift @{$val} }; |
|
1003
|
|
|
|
|
|
|
$ok-- && last unless $self->_dbsql_chk_check_sum($_, \@pkeyval2); |
|
1004
|
|
|
|
|
|
|
} |
|
1005
|
|
|
|
|
|
|
} |
|
1006
|
|
|
|
|
|
|
else { |
|
1007
|
|
|
|
|
|
|
$ok = $self->_dbsql_chk_check_sum($md5hash, \@pkeyval); |
|
1008
|
|
|
|
|
|
|
} |
|
1009
|
|
|
|
|
|
|
$self->_add_to_output($self->{dbsql_errmsg_tmpl}, {ERRMSG => gettext('Can\'t update record(s) due to primary key cheksum mismatch').'!'}) and return 0 unless($ok); |
|
1010
|
|
|
|
|
|
|
} |
|
1011
|
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
return $self->_dbsql_write(1); |
|
1013
|
|
|
|
|
|
|
} |
|
1014
|
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
###################################################################### |
|
1016
|
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
=head3 dbsql_insert |
|
1018
|
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
This method inserts the transmitted data into the table. If an error |
|
1020
|
|
|
|
|
|
|
occurs, the insert statement and the DBMSs error message and number are |
|
1021
|
|
|
|
|
|
|
printed. If you don't want all or some of this information be |
|
1022
|
|
|
|
|
|
|
displayed, see L. |
|
1023
|
|
|
|
|
|
|
Before calling this method, you should prove that the form content is |
|
1024
|
|
|
|
|
|
|
valid (see L, C method). |
|
1025
|
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
=cut |
|
1027
|
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
###################################################################### |
|
1029
|
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
sub dbsql_insert { |
|
1031
|
|
|
|
|
|
|
my ($self) = @_; |
|
1032
|
|
|
|
|
|
|
return $self->_dbsql_write(0); |
|
1033
|
|
|
|
|
|
|
} |
|
1034
|
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
###################################################################### |
|
1036
|
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
=head3 dbsql_set_dbh ( DBHANDLE ) |
|
1038
|
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
Use this function to set the internally used database handle. If you |
|
1040
|
|
|
|
|
|
|
don't call this funtion, you must set it when creating the object with |
|
1041
|
|
|
|
|
|
|
the L method. |
|
1042
|
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
=cut |
|
1044
|
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
###################################################################### |
|
1046
|
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
sub dbsql_set_dbh { |
|
1048
|
|
|
|
|
|
|
my ($self, $dbh) = @_; |
|
1049
|
|
|
|
|
|
|
$self->{dbsql} = $dbh; |
|
1050
|
|
|
|
|
|
|
if(ref($self->{dbsql}) ne 'DBI::db') { |
|
1051
|
|
|
|
|
|
|
croak 'No valid database connection!'; |
|
1052
|
|
|
|
|
|
|
} |
|
1053
|
|
|
|
|
|
|
} |
|
1054
|
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
###################################################################### |
|
1056
|
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
=head3 dbsql_set_hide_pkey ( BOOLEAN ) |
|
1058
|
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
By default the primary key fields are represented as I form |
|
1060
|
|
|
|
|
|
|
fields. This makes sense because when updating records they mustn't be |
|
1061
|
|
|
|
|
|
|
changed. Sometimes, especially when inserting new records, one might |
|
1062
|
|
|
|
|
|
|
want to set them by hand. Then he should pass false (0) to this method. |
|
1063
|
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
Passing false to this method will also disable the primary key md5 |
|
1065
|
|
|
|
|
|
|
checksum check when calling C. This means that it'll be |
|
1066
|
|
|
|
|
|
|
allowed to change the primary keys even when updating records. By |
|
1067
|
|
|
|
|
|
|
default this is not allowed for security reasons. B
|
|
1068
|
|
|
|
|
|
|
this method!>. DATA CAN EASILY GET OVERWRITTEN!!! |
|
1069
|
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
You can as well set the pkey template by hand using |
|
1071
|
|
|
|
|
|
|
L. |
|
1072
|
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
=cut |
|
1074
|
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
###################################################################### |
|
1076
|
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
sub dbsql_set_hide_pkey { |
|
1078
|
|
|
|
|
|
|
my $self = shift; |
|
1079
|
|
|
|
|
|
|
$self->{dbsql_hide_pkey} = shift; |
|
1080
|
|
|
|
|
|
|
} |
|
1081
|
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
###################################################################### |
|
1083
|
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
=head3 dbsql_set_show_value ( BOOLEAN ) |
|
1085
|
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
When you pass a valid where clause to the new method, the contents of |
|
1087
|
|
|
|
|
|
|
the found records will be read in and displayed as defaults. In |
|
1088
|
|
|
|
|
|
|
certain situations one might like to have the fields empty |
|
1089
|
|
|
|
|
|
|
though. Passing false (0) to this method will do it. |
|
1090
|
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
=cut |
|
1092
|
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
###################################################################### |
|
1094
|
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
sub dbsql_set_show_value { |
|
1096
|
|
|
|
|
|
|
my $self = shift; |
|
1097
|
|
|
|
|
|
|
$self->{dbsql_show_value} = shift; |
|
1098
|
|
|
|
|
|
|
} |
|
1099
|
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
###################################################################### |
|
1101
|
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
=head3 dbsql_set_pkey ( SCALAR|ARRAYREF|HASHREF ) |
|
1103
|
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
Normally the primary key of a database table is |
|
1105
|
|
|
|
|
|
|
autodetected. Sometimes someone might like to define other fields as |
|
1106
|
|
|
|
|
|
|
primary key though (the primary key is important when updating |
|
1107
|
|
|
|
|
|
|
records). You can pass a fieldname or a reference to an array with |
|
1108
|
|
|
|
|
|
|
fieldnames to this method. This method should be called before |
|
1109
|
|
|
|
|
|
|
L |
|
1110
|
|
|
|
|
|
|
(for being sure, call this method as early as possible). |
|
1111
|
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
B: If you pass several table names to dbsql_conf, you must pass |
|
1113
|
|
|
|
|
|
|
as hash reference here, else the passed pkeys will only be used for |
|
1114
|
|
|
|
|
|
|
the first table. |
|
1115
|
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
=cut |
|
1117
|
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
###################################################################### |
|
1119
|
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
sub dbsql_set_pkey { |
|
1121
|
|
|
|
|
|
|
my ($self,$pkey)= @_; |
|
1122
|
|
|
|
|
|
|
if($pkey) { |
|
1123
|
|
|
|
|
|
|
if(ref($pkey) ne 'HASH') { |
|
1124
|
|
|
|
|
|
|
croak "You've to reference a hash since there's more than one table!" if(@{$self->{dbsql_tables}} > 1); |
|
1125
|
|
|
|
|
|
|
$self->{dbsql_pkey} = $pkey; |
|
1126
|
|
|
|
|
|
|
return 1; |
|
1127
|
|
|
|
|
|
|
} |
|
1128
|
|
|
|
|
|
|
foreach my $tbl (keys(%{$pkey})) { |
|
1129
|
|
|
|
|
|
|
$self->{dbsql_pkey}->{$tbl} = {} if(ref($self->{dbsql_pkey}->{$tbl}) ne 'HASH'); |
|
1130
|
|
|
|
|
|
|
$pkey->{$tbl} = [$pkey->{$tbl}] if(ref($pkey->{$tbl}) ne 'ARRAY'); |
|
1131
|
|
|
|
|
|
|
local $_; |
|
1132
|
|
|
|
|
|
|
foreach $_ (@{$pkey->{$tbl}}) { |
|
1133
|
|
|
|
|
|
|
#in case that we've more than one table we reference fields by table.fieldname |
|
1134
|
|
|
|
|
|
|
#is it ok to add the $tbl prefix here in any case or should i check that @{$self->{dbsql_tables}} > 1 ? |
|
1135
|
|
|
|
|
|
|
$self->{dbsql_pkey}->{$tbl}->{"$tbl.$_"} = 1; |
|
1136
|
|
|
|
|
|
|
} |
|
1137
|
|
|
|
|
|
|
} |
|
1138
|
|
|
|
|
|
|
return 1; |
|
1139
|
|
|
|
|
|
|
} |
|
1140
|
|
|
|
|
|
|
return 0; |
|
1141
|
|
|
|
|
|
|
} |
|
1142
|
|
|
|
|
|
|
|
|
1143
|
|
|
|
|
|
|
###################################################################### |
|
1144
|
|
|
|
|
|
|
|
|
1145
|
|
|
|
|
|
|
=head3 dbsql_set_show_default ( BOOLEAN ) |
|
1146
|
|
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
|
If you pass true (1) to this method the field defaults defined in the |
|
1148
|
|
|
|
|
|
|
database are used as defaults in the form. This is the default |
|
1149
|
|
|
|
|
|
|
behavior in case you don't specify a where condition but a number (or |
|
1150
|
|
|
|
|
|
|
nothing at all which defaults to 1) (see L). In case |
|
1151
|
|
|
|
|
|
|
that you do specify a where condition its just logical to not use the |
|
1152
|
|
|
|
|
|
|
database defaults since the real values of the defined database |
|
1153
|
|
|
|
|
|
|
records are used as default values for the form. So this standard |
|
1154
|
|
|
|
|
|
|
behaviour should be just fine and you normally don't need this |
|
1155
|
|
|
|
|
|
|
method. Passing false (0) will force this module to not use the field |
|
1156
|
|
|
|
|
|
|
defaults defined by the database table structure. |
|
1157
|
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
=cut |
|
1159
|
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
###################################################################### |
|
1161
|
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
sub dbsql_set_show_default { |
|
1163
|
|
|
|
|
|
|
my ($self, $set) = @_; |
|
1164
|
|
|
|
|
|
|
#ensure to not set it to 1 since that is the default and it indicates that this function was NOT called |
|
1165
|
|
|
|
|
|
|
$set++ if($set == 1); |
|
1166
|
|
|
|
|
|
|
$self->{dbsql_show_default} = $set; |
|
1167
|
|
|
|
|
|
|
} |
|
1168
|
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
###################################################################### |
|
1170
|
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
=head3 dbsql_set_write_null_fields ( INTEGER ) |
|
1172
|
|
|
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
With this method you can define whether the value of form fields for |
|
1174
|
|
|
|
|
|
|
which the user didn't specify any value (he submitted them empty) |
|
1175
|
|
|
|
|
|
|
should be interpreted as NULL and thus null will be written in the |
|
1176
|
|
|
|
|
|
|
database or whether they should be ignored so that the default is used |
|
1177
|
|
|
|
|
|
|
by the database (in case of an insert) resp. the value is not changed |
|
1178
|
|
|
|
|
|
|
(in case of an update). |
|
1179
|
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
The default is to interpret empty fields as NULL fields. |
|
1181
|
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
B<0> forces the module to not pass empty fields to the database. This |
|
1183
|
|
|
|
|
|
|
will cause problems when you perform an insert and a certain field is |
|
1184
|
|
|
|
|
|
|
defined as not_null field and also doesn't have a default value. So |
|
1185
|
|
|
|
|
|
|
its a bad idea to pass 0 in case you want to make an insert. Also when |
|
1186
|
|
|
|
|
|
|
doing an update it doesn't make much sense normaly. |
|
1187
|
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
B<1> forces the module to only ignore the null value if it was |
|
1189
|
|
|
|
|
|
|
specified for a I field (the table structure forbids the |
|
1190
|
|
|
|
|
|
|
null value for the field). This will cause the same problems as |
|
1191
|
|
|
|
|
|
|
described for I<0> (see above). But this can be a good idea if your |
|
1192
|
|
|
|
|
|
|
planning to make an update. |
|
1193
|
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
B<2> forces the module to only ignore an empty field in case it is |
|
1195
|
|
|
|
|
|
|
defined as I by the database and a default value is |
|
1196
|
|
|
|
|
|
|
defined. This makes e.g. sense when you want to make an insert and the |
|
1197
|
|
|
|
|
|
|
database shall just set the default values for fields which were not |
|
1198
|
|
|
|
|
|
|
fill out by the user. Perhaps you also want to use |
|
1199
|
|
|
|
|
|
|
I to prevent the default values |
|
1200
|
|
|
|
|
|
|
from being displayed. |
|
1201
|
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
B<3> this is the default behaviour. Empty field values are passed as |
|
1203
|
|
|
|
|
|
|
NULL to the database. |
|
1204
|
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
=cut |
|
1206
|
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
###################################################################### |
|
1208
|
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
sub dbsql_set_write_null_fields { |
|
1210
|
|
|
|
|
|
|
my ($self, $set) = @_; |
|
1211
|
|
|
|
|
|
|
$self->{dbsql_write_null_fields} = $set; |
|
1212
|
|
|
|
|
|
|
} |
|
1213
|
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
###################################################################### |
|
1215
|
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
=head3 dbsql_set_errmsg_templ ( TEMPLATENAME ) |
|
1217
|
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
If you want to modifiy the output of the system error messages, create |
|
1219
|
|
|
|
|
|
|
a new template (e.g. copy the default and fit it to your needs) and |
|
1220
|
|
|
|
|
|
|
pass the new templates name to this method. By default the template |
|
1221
|
|
|
|
|
|
|
called I of the configured skin ist used (the default skin is |
|
1222
|
|
|
|
|
|
|
L). |
|
1223
|
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
=cut |
|
1225
|
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
###################################################################### |
|
1227
|
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
sub dbsql_set_errmsg_templ { |
|
1229
|
|
|
|
|
|
|
my($self, $set) = @_; |
|
1230
|
|
|
|
|
|
|
$self->{dbsql_errmsg_tmpl} = $set if($set); |
|
1231
|
|
|
|
|
|
|
} |
|
1232
|
|
|
|
|
|
|
|
|
1233
|
|
|
|
|
|
|
###################################################################### |
|
1234
|
|
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
|
=head3 dbsql_set_sqlerr ( INTEGER ) |
|
1236
|
|
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
|
Perhaps you already read that whenever a database error occurs, the |
|
1238
|
|
|
|
|
|
|
error message, error number and query command is printed out by |
|
1239
|
|
|
|
|
|
|
default. Sometimes you might prove displaying the sql query a security |
|
1240
|
|
|
|
|
|
|
lack. With the help of this method, you can define which information |
|
1241
|
|
|
|
|
|
|
will be printed. |
|
1242
|
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
Listing of the bits and their influence: |
|
1244
|
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
1 error number |
|
1246
|
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
2 error message |
|
1248
|
|
|
|
|
|
|
|
|
1249
|
|
|
|
|
|
|
4 sql command |
|
1250
|
|
|
|
|
|
|
|
|
1251
|
|
|
|
|
|
|
So if you pass 3 to this method the error number and message will be |
|
1252
|
|
|
|
|
|
|
printed, but not the sql command. |
|
1253
|
|
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
|
=cut |
|
1255
|
|
|
|
|
|
|
|
|
1256
|
|
|
|
|
|
|
###################################################################### |
|
1257
|
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
sub dbsql_set_sqlerr { |
|
1259
|
|
|
|
|
|
|
my($self, $set) = @_; |
|
1260
|
|
|
|
|
|
|
$self->{dbsql_sqlerr_show} = $set; |
|
1261
|
|
|
|
|
|
|
} |
|
1262
|
|
|
|
|
|
|
|
|
1263
|
|
|
|
|
|
|
###################################################################### |
|
1264
|
|
|
|
|
|
|
|
|
1265
|
|
|
|
|
|
|
=head3 dbsql_set_sqlerr_templ ( TEMPLATENAME ) |
|
1266
|
|
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
|
If you want to modifiy the output of the sql error messages, create a |
|
1268
|
|
|
|
|
|
|
new template (e.g. copy the default and fit it to your needs) and pass |
|
1269
|
|
|
|
|
|
|
the new templates name to this method. By default the template called |
|
1270
|
|
|
|
|
|
|
I of the configured skin is used (the default skin is |
|
1271
|
|
|
|
|
|
|
L). |
|
1272
|
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
=cut |
|
1274
|
|
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
###################################################################### |
|
1276
|
|
|
|
|
|
|
|
|
1277
|
|
|
|
|
|
|
sub dbsql_set_sqlerr_templ { |
|
1278
|
|
|
|
|
|
|
my($self, $set) = @_; |
|
1279
|
|
|
|
|
|
|
$self->{dbsql_sqlerr_tmpl} = $set if($set); |
|
1280
|
|
|
|
|
|
|
} |
|
1281
|
|
|
|
|
|
|
|
|
1282
|
|
|
|
|
|
|
###################################################################### |
|
1283
|
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
=head3 dbsql_set_row ( BOOLEAN ) |
|
1285
|
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
If you provided a I and more than one record was |
|
1287
|
|
|
|
|
|
|
found, or you provided a number instead and it was higher than 1, then |
|
1288
|
|
|
|
|
|
|
by default it'll be used only one line per record, which means that |
|
1289
|
|
|
|
|
|
|
fields belonging to the same record will be printed on the same line. |
|
1290
|
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
By passing 0 (false) to this method you can force the object to use |
|
1292
|
|
|
|
|
|
|
one line per field, 1 (true) is the default. |
|
1293
|
|
|
|
|
|
|
|
|
1294
|
|
|
|
|
|
|
=cut |
|
1295
|
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
###################################################################### |
|
1297
|
|
|
|
|
|
|
|
|
1298
|
|
|
|
|
|
|
sub dbsql_set_row { |
|
1299
|
|
|
|
|
|
|
my($self,$set) = @_; |
|
1300
|
|
|
|
|
|
|
$set -- if($set == -254); |
|
1301
|
|
|
|
|
|
|
$self->{dbsql_row} = $set; |
|
1302
|
|
|
|
|
|
|
} |
|
1303
|
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
###################################################################### |
|
1305
|
|
|
|
|
|
|
|
|
1306
|
|
|
|
|
|
|
=head3 dbsql_set_row_tmpl ( TEMPLATENAME ) |
|
1307
|
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
By default the I template is used. If you want to use another |
|
1309
|
|
|
|
|
|
|
template for placing the fields which belong to one record into one |
|
1310
|
|
|
|
|
|
|
line, pass it to this method. |
|
1311
|
|
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
|
=cut |
|
1313
|
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
###################################################################### |
|
1315
|
|
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
|
sub dbsql_set_row_tmpl { |
|
1317
|
|
|
|
|
|
|
my ($self,$set) = @_; |
|
1318
|
|
|
|
|
|
|
$self->{dbsql_row_tmpl} = $set if($set); |
|
1319
|
|
|
|
|
|
|
} |
|
1320
|
|
|
|
|
|
|
|
|
1321
|
|
|
|
|
|
|
###################################################################### |
|
1322
|
|
|
|
|
|
|
|
|
1323
|
|
|
|
|
|
|
=head3 dbsql_set_empty_tmpl ( TEMPLATENAME ) |
|
1324
|
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
By default the I template is used for inserting space between |
|
1326
|
|
|
|
|
|
|
the records, If you want to use another template pass its name to this |
|
1327
|
|
|
|
|
|
|
method. The space is only inserted if every field takes one line. |
|
1328
|
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
=cut |
|
1330
|
|
|
|
|
|
|
|
|
1331
|
|
|
|
|
|
|
###################################################################### |
|
1332
|
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
sub dbsql_set_empty_tmpl { |
|
1334
|
|
|
|
|
|
|
my ($self,$set) = @_; |
|
1335
|
|
|
|
|
|
|
$self->{dbsql_empty_tmpl} = $set if($set); |
|
1336
|
|
|
|
|
|
|
} |
|
1337
|
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
###################################################################### |
|
1339
|
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
=head3 dbsql_get_sqlerr |
|
1341
|
|
|
|
|
|
|
|
|
1342
|
|
|
|
|
|
|
This method returns an array with the error number and error message |
|
1343
|
|
|
|
|
|
|
from the last database error. The sql command which caused the error |
|
1344
|
|
|
|
|
|
|
will be the third and last element. |
|
1345
|
|
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
|
=cut |
|
1347
|
|
|
|
|
|
|
|
|
1348
|
|
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
|
###################################################################### |
|
1350
|
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
sub dbsql_get_sqlerr { |
|
1352
|
|
|
|
|
|
|
my $self = shift; |
|
1353
|
|
|
|
|
|
|
return @{$self->{dbsql_sqlerr}}; |
|
1354
|
|
|
|
|
|
|
} |
|
1355
|
|
|
|
|
|
|
|
|
1356
|
|
|
|
|
|
|
###################################################################### |
|
1357
|
|
|
|
|
|
|
|
|
1358
|
|
|
|
|
|
|
=head3 dbsql_add_extra_sql(SQLCOMMAND, ARRAY) |
|
1359
|
|
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
|
This method can be used to define some more sql commands which then |
|
1361
|
|
|
|
|
|
|
will be executed for each record when C or is called. |
|
1362
|
|
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
|
The sql command might contain '?' (question marks). These will be |
|
1364
|
|
|
|
|
|
|
replaced with the values of the fields defined by the second |
|
1365
|
|
|
|
|
|
|
argument. The first '?' is replaced with the value of the first |
|
1366
|
|
|
|
|
|
|
element and so on. |
|
1367
|
|
|
|
|
|
|
|
|
1368
|
|
|
|
|
|
|
A backslash before a question mark will prevent it from being parsed. |
|
1369
|
|
|
|
|
|
|
|
|
1370
|
|
|
|
|
|
|
=cut |
|
1371
|
|
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
###################################################################### |
|
1373
|
|
|
|
|
|
|
|
|
1374
|
|
|
|
|
|
|
sub dbsql_add_extra_sql { |
|
1375
|
|
|
|
|
|
|
my($self,$sql,@vars) = @_; |
|
1376
|
|
|
|
|
|
|
push @{$self->{dbsql_extra_sql}}, [$sql, @vars] if($sql); |
|
1377
|
|
|
|
|
|
|
} |
|
1378
|
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
###################################################################### |
|
1380
|
|
|
|
|
|
|
# INTERNAL METHODS # |
|
1381
|
|
|
|
|
|
|
###################################################################### |
|
1382
|
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
#this method is called by HTML::FormEngine s constructor |
|
1384
|
|
|
|
|
|
|
sub _initialize_child { |
|
1385
|
|
|
|
|
|
|
my $self = shift; |
|
1386
|
|
|
|
|
|
|
# the remaining arguments are forwarded by HTML::FormEngine s new method |
|
1387
|
|
|
|
|
|
|
$self->dbsql_set_dbh(shift); |
|
1388
|
|
|
|
|
|
|
$self->{dbsql_preconf} = {}; |
|
1389
|
|
|
|
|
|
|
$self->{dbsql_where} = 1; |
|
1390
|
|
|
|
|
|
|
$self->{dbsql_pkey} = {}; |
|
1391
|
|
|
|
|
|
|
$self->{dbsql_tables} = []; |
|
1392
|
|
|
|
|
|
|
$self->{dbsql_fields} = {}; |
|
1393
|
|
|
|
|
|
|
$self->{dbsql_hide_pkey} = 1; |
|
1394
|
|
|
|
|
|
|
$self->{dbsql_show_value} = 1; |
|
1395
|
|
|
|
|
|
|
#-254 shall indicate that the value was not touched by the user |
|
1396
|
|
|
|
|
|
|
$self->{dbsql_show_default} = 1; |
|
1397
|
|
|
|
|
|
|
$self->{dbsql_write_null_fields} = 3; |
|
1398
|
|
|
|
|
|
|
$self->{dbsql_sqlerr} = []; |
|
1399
|
|
|
|
|
|
|
$self->{dbsql_sqlerr_show} = 7; |
|
1400
|
|
|
|
|
|
|
$self->{dbsql_sqlerr_tmpl} = 'sqlerr'; |
|
1401
|
|
|
|
|
|
|
$self->{dbsql_errmsg_tmpl} = 'errmsg'; |
|
1402
|
|
|
|
|
|
|
$self->{dbsql_row_tmpl} = 'row'; |
|
1403
|
|
|
|
|
|
|
$self->{dbsql_empty_tmpl} = 'empty'; |
|
1404
|
|
|
|
|
|
|
#-254 shall indicate that the value was not touched by the user |
|
1405
|
|
|
|
|
|
|
$self->{dbsql_row} = -254; |
|
1406
|
|
|
|
|
|
|
$self->{dbsql_extra_sql} = []; |
|
1407
|
|
|
|
|
|
|
$self->{dbsql_save_as} = {}; |
|
1408
|
|
|
|
|
|
|
$self->{dbsql_not_null_fields} = {}; |
|
1409
|
|
|
|
|
|
|
$self->{dbsql_has_default_fields} = {}; |
|
1410
|
|
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
|
#HTML::FormEngine::DBSQL::SkinClassic is the default skin for FormEngine::DBSQL |
|
1412
|
|
|
|
|
|
|
$self->set_skin_obj(new HTML::FormEngine::DBSQL::SkinClassic); |
|
1413
|
|
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
#just in case someone wants to inherit from this method |
|
1415
|
|
|
|
|
|
|
$self->_dbsql_initialize_child; |
|
1416
|
|
|
|
|
|
|
} |
|
1417
|
|
|
|
|
|
|
|
|
1418
|
|
|
|
|
|
|
sub _dbsql_initialize_child { |
|
1419
|
|
|
|
|
|
|
} |
|
1420
|
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
#this method writes the submitted values into the database |
|
1422
|
|
|
|
|
|
|
sub _dbsql_write { |
|
1423
|
|
|
|
|
|
|
my ($self,$update) = @_; |
|
1424
|
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
my (%fields,$count); |
|
1426
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
1427
|
|
|
|
|
|
|
$fields{$tbl} = {}; |
|
1428
|
|
|
|
|
|
|
foreach $_ (@{$self->{dbsql_fields}->{$tbl}}) { |
|
1429
|
|
|
|
|
|
|
my $val = $self->_get_input($_); |
|
1430
|
|
|
|
|
|
|
$val = [$val] if(ref($val) ne 'ARRAY'); |
|
1431
|
|
|
|
|
|
|
#$count shall contain the count of submitted records |
|
1432
|
|
|
|
|
|
|
$count = @{$val} if(!defined($count) || @{$val} > $count); |
|
1433
|
|
|
|
|
|
|
$fields{$tbl}->{$_} = $val; |
|
1434
|
|
|
|
|
|
|
} |
|
1435
|
|
|
|
|
|
|
} |
|
1436
|
|
|
|
|
|
|
|
|
1437
|
|
|
|
|
|
|
$self->{dbsql}->begin_work; |
|
1438
|
|
|
|
|
|
|
my $rec; |
|
1439
|
|
|
|
|
|
|
#for each record.. |
|
1440
|
|
|
|
|
|
|
for($rec = 0; $rec<$count; $rec ++) { |
|
1441
|
|
|
|
|
|
|
my @sql = (); |
|
1442
|
|
|
|
|
|
|
my %tblvalues = (); |
|
1443
|
|
|
|
|
|
|
foreach my $tbl (@{$self->{dbsql_tables}}) { |
|
1444
|
|
|
|
|
|
|
my %values = (); |
|
1445
|
|
|
|
|
|
|
my %pkey = (); |
|
1446
|
|
|
|
|
|
|
local $_; |
|
1447
|
|
|
|
|
|
|
foreach $_ (keys(%{$fields{$tbl}})) { |
|
1448
|
|
|
|
|
|
|
#we can delete fields which don't have any value left |
|
1449
|
|
|
|
|
|
|
if(! @{$fields{$tbl}->{$_}}) { |
|
1450
|
|
|
|
|
|
|
delete $fields{$tbl}->{$_}; |
|
1451
|
|
|
|
|
|
|
} |
|
1452
|
|
|
|
|
|
|
my $value = $fields{$tbl}->{$_}->[$rec]; |
|
1453
|
|
|
|
|
|
|
$value = undef if($value eq ''); |
|
1454
|
|
|
|
|
|
|
|
|
1455
|
|
|
|
|
|
|
#save_as describes in which format the value should be saved to the database |
|
1456
|
|
|
|
|
|
|
if(defined($self->{dbsql_save_as}->{$_}) and ref($self->{dbsql_save_as}->{$_}) eq 'ARRAY') { |
|
1457
|
|
|
|
|
|
|
$value = [$value] unless(ref($value) eq 'ARRAY'); |
|
1458
|
|
|
|
|
|
|
($value) = _array2array($self->{dbsql_save_as}->{$_},$value); |
|
1459
|
|
|
|
|
|
|
} |
|
1460
|
|
|
|
|
|
|
|
|
1461
|
|
|
|
|
|
|
#turn perl arrays into database arrays |
|
1462
|
|
|
|
|
|
|
$value = $self->_dbsql_arr2psql($value) if(ref($value) eq 'ARRAY'); |
|
1463
|
|
|
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
#we only write null fields according to the settings made through dbsql_set_write_null_fields resp. the default |
|
1465
|
|
|
|
|
|
|
#but primary keys must never be set to NULL! |
|
1466
|
|
|
|
|
|
|
if( |
|
1467
|
|
|
|
|
|
|
(defined($value) and $value ne '') or !$self->{dbsql_pkey}->{$tbl}->{$_} && |
|
1468
|
|
|
|
|
|
|
($self->{dbsql_write_null_fields} > 2 || ( |
|
1469
|
|
|
|
|
|
|
$self->{dbsql_write_null_fields} > 0 && ( |
|
1470
|
|
|
|
|
|
|
! defined($self->{dbsql_not_null_fields}->{$_} || ( |
|
1471
|
|
|
|
|
|
|
$self->{dbsql_write_null_fields} > 1 && ! defined($self->{dbsql_has_default_fields}->{$_}) |
|
1472
|
|
|
|
|
|
|
) |
|
1473
|
|
|
|
|
|
|
) |
|
1474
|
|
|
|
|
|
|
) |
|
1475
|
|
|
|
|
|
|
) |
|
1476
|
|
|
|
|
|
|
) |
|
1477
|
|
|
|
|
|
|
) { |
|
1478
|
|
|
|
|
|
|
#filter out the real field name (remove the table name which was added to distinguish the fields) |
|
1479
|
|
|
|
|
|
|
(my $key = $_) =~ s/^(.+)\.(.+)$/$2/; |
|
1480
|
|
|
|
|
|
|
#quote the key (fieldname) probably |
|
1481
|
|
|
|
|
|
|
$key = $self->{dbsql}->quote_identifier($key); |
|
1482
|
|
|
|
|
|
|
if($self->{dbsql_pkey}->{$tbl}->{$_}) { |
|
1483
|
|
|
|
|
|
|
$pkey{$key} = $self->{dbsql}->quote($value); |
|
1484
|
|
|
|
|
|
|
} |
|
1485
|
|
|
|
|
|
|
$values{$key} = $self->{dbsql}->quote($value); |
|
1486
|
|
|
|
|
|
|
$tblvalues{$_} = $values{$key}; |
|
1487
|
|
|
|
|
|
|
} |
|
1488
|
|
|
|
|
|
|
} |
|
1489
|
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
#create an update statement |
|
1491
|
|
|
|
|
|
|
if($update) { |
|
1492
|
|
|
|
|
|
|
push @sql, $self->_dbsql_mk_update([keys(%values)], [values(%values)], \%pkey, $tbl); |
|
1493
|
|
|
|
|
|
|
} |
|
1494
|
|
|
|
|
|
|
#create an insert statement (here we don't need any primary keys) |
|
1495
|
|
|
|
|
|
|
else { |
|
1496
|
|
|
|
|
|
|
push @sql, $self->_dbsql_mk_insert([keys(%values)], [values(%values)], $tbl); |
|
1497
|
|
|
|
|
|
|
} |
|
1498
|
|
|
|
|
|
|
} |
|
1499
|
|
|
|
|
|
|
|
|
1500
|
|
|
|
|
|
|
#add the specified extra sql statements which should be executed for every record (in most cases the user didn't specify any) |
|
1501
|
|
|
|
|
|
|
foreach $_ (@{$self->{dbsql_extra_sql}}) { |
|
1502
|
|
|
|
|
|
|
my $sql = $_->[0]; |
|
1503
|
|
|
|
|
|
|
#replace the ? with the corresponding field value |
|
1504
|
|
|
|
|
|
|
for(my $x=1; $x<@{$_}; $x++) { |
|
1505
|
|
|
|
|
|
|
$sql =~ s/(?!\\)(.)\?/$1.$tblvalues{$_->[$x]}/e; |
|
1506
|
|
|
|
|
|
|
} |
|
1507
|
|
|
|
|
|
|
$sql =~ s/\\\?/?/g; |
|
1508
|
|
|
|
|
|
|
push @sql, $sql; |
|
1509
|
|
|
|
|
|
|
} |
|
1510
|
|
|
|
|
|
|
foreach my $sql (@sql) { |
|
1511
|
|
|
|
|
|
|
if($self->{debug}) { |
|
1512
|
|
|
|
|
|
|
print $sql, "\n"; |
|
1513
|
|
|
|
|
|
|
} |
|
1514
|
|
|
|
|
|
|
my $sth = $self->{dbsql}->prepare($sql); |
|
1515
|
|
|
|
|
|
|
#execute statements |
|
1516
|
|
|
|
|
|
|
if(! $sth->execute) { |
|
1517
|
|
|
|
|
|
|
$self->_dbsql_sql_error($sql); |
|
1518
|
|
|
|
|
|
|
return 0; |
|
1519
|
|
|
|
|
|
|
} |
|
1520
|
|
|
|
|
|
|
} |
|
1521
|
|
|
|
|
|
|
} |
|
1522
|
|
|
|
|
|
|
$self->{dbsql}->commit; |
|
1523
|
|
|
|
|
|
|
return $rec; |
|
1524
|
|
|
|
|
|
|
} |
|
1525
|
|
|
|
|
|
|
|
|
1526
|
|
|
|
|
|
|
|
|
1527
|
|
|
|
|
|
|
#this method turns a perl array into a database array ('{field1, field2, {subfield1, subfield2}, ...}') |
|
1528
|
|
|
|
|
|
|
#it works recursive |
|
1529
|
|
|
|
|
|
|
sub _dbsql_arr2psql { |
|
1530
|
|
|
|
|
|
|
my ($self,$elem) = @_; |
|
1531
|
|
|
|
|
|
|
my $res = ''; |
|
1532
|
|
|
|
|
|
|
if(ref($elem) eq 'ARRAY') { |
|
1533
|
|
|
|
|
|
|
$res = '{'; |
|
1534
|
|
|
|
|
|
|
foreach $_ (@{$elem}) { |
|
1535
|
|
|
|
|
|
|
$res .= $self->_dbsql_arr2psql($_) . ','; |
|
1536
|
|
|
|
|
|
|
} |
|
1537
|
|
|
|
|
|
|
$res =~ s/,$/\}/; |
|
1538
|
|
|
|
|
|
|
} |
|
1539
|
|
|
|
|
|
|
else { |
|
1540
|
|
|
|
|
|
|
$res = $elem; |
|
1541
|
|
|
|
|
|
|
} |
|
1542
|
|
|
|
|
|
|
return $res; |
|
1543
|
|
|
|
|
|
|
} |
|
1544
|
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
#this method creates an insert statement |
|
1546
|
|
|
|
|
|
|
sub _dbsql_mk_insert { |
|
1547
|
|
|
|
|
|
|
my ($self,$fields,$values,$table) = @_; |
|
1548
|
|
|
|
|
|
|
if(ref($fields) eq 'ARRAY' && ref($values) eq 'ARRAY' && $table ne '') { |
|
1549
|
|
|
|
|
|
|
return 'INSERT INTO ' . $self->{dbsql}->quote_identifier($table) . ' ('.join(', ', @{$fields}).') VALUES ('.join(', ', @{$values}).')'; |
|
1550
|
|
|
|
|
|
|
} |
|
1551
|
|
|
|
|
|
|
else { |
|
1552
|
|
|
|
|
|
|
return ''; |
|
1553
|
|
|
|
|
|
|
} |
|
1554
|
|
|
|
|
|
|
} |
|
1555
|
|
|
|
|
|
|
|
|
1556
|
|
|
|
|
|
|
#this method creates an update statement |
|
1557
|
|
|
|
|
|
|
sub _dbsql_mk_update { |
|
1558
|
|
|
|
|
|
|
my ($self,$fields,$values,$pkey,$table) = @_; |
|
1559
|
|
|
|
|
|
|
my $sql = ''; |
|
1560
|
|
|
|
|
|
|
|
|
1561
|
|
|
|
|
|
|
if(ref($fields) eq 'ARRAY' && ref($values) eq 'ARRAY' && ref($pkey) eq 'HASH' && $table ne '') { |
|
1562
|
|
|
|
|
|
|
$sql = 'UPDATE ' . $self->{dbsql}->quote_identifier($table) . ' SET '; |
|
1563
|
|
|
|
|
|
|
my $i = 0; |
|
1564
|
|
|
|
|
|
|
foreach $_ (@{$fields}) { |
|
1565
|
|
|
|
|
|
|
$sql .= "$_=" . $values->[$i] . ', '; |
|
1566
|
|
|
|
|
|
|
$i ++; |
|
1567
|
|
|
|
|
|
|
} |
|
1568
|
|
|
|
|
|
|
$sql =~ s/, $//; |
|
1569
|
|
|
|
|
|
|
$sql .= ' WHERE '; |
|
1570
|
|
|
|
|
|
|
foreach $_ (keys(%{$pkey})) { |
|
1571
|
|
|
|
|
|
|
$sql .= "$_=" . $pkey->{$_} . ' AND '; |
|
1572
|
|
|
|
|
|
|
} |
|
1573
|
|
|
|
|
|
|
$sql =~ s/ AND $//; |
|
1574
|
|
|
|
|
|
|
} |
|
1575
|
|
|
|
|
|
|
|
|
1576
|
|
|
|
|
|
|
return $sql; |
|
1577
|
|
|
|
|
|
|
} |
|
1578
|
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
#this method creates a field configuration with the help of the database table structure information |
|
1580
|
|
|
|
|
|
|
sub _dbsql_makeconf { |
|
1581
|
|
|
|
|
|
|
my ($self,$info,$tbl) = @_; |
|
1582
|
|
|
|
|
|
|
my %res = (); |
|
1583
|
|
|
|
|
|
|
if(ref($info) eq 'HASH') { |
|
1584
|
|
|
|
|
|
|
#($res{TITLE} = $info->{name}) =~ s/^([a-z]{1})/uc($1)/e; does raise an endless loop |
|
1585
|
|
|
|
|
|
|
#by default the title shall be the name but with the first letter being capital |
|
1586
|
|
|
|
|
|
|
$_ = $info->{COLUMN_NAME} and s/^([a-z]{1})/uc($1)/e and $res{TITLE} = $_; |
|
1587
|
|
|
|
|
|
|
#attach $tbl in front so that fields with same names (out of diffrent tables) don't get confused |
|
1588
|
|
|
|
|
|
|
$info->{COLUMN_NAME} = $tbl . '.' . $info->{COLUMN_NAME} if(@{$self->{dbsql_tables}} > 1); |
|
1589
|
|
|
|
|
|
|
#fname is just a copy of name, i forgott what for :( |
|
1590
|
|
|
|
|
|
|
$res{fname} = $info->{COLUMN_NAME}; |
|
1591
|
|
|
|
|
|
|
$res{NAME} = $info->{COLUMN_NAME}; |
|
1592
|
|
|
|
|
|
|
#parse the default |
|
1593
|
|
|
|
|
|
|
#we should only use the default value if dbsql_show_default is true, primary keys should not be touched |
|
1594
|
|
|
|
|
|
|
if($info->{COLUMN_DEF} && $self->{dbsql_show_default} > 0 && ! $self->{dbsql_pkey}->{$tbl}->{$res{NAME}}) { |
|
1595
|
|
|
|
|
|
|
#removing the explizit datatype cast (this is new in postgres 7.4) |
|
1596
|
|
|
|
|
|
|
$info->{COLUMN_DEF} =~ s/::[a-z ]+(\[\])?//g; |
|
1597
|
|
|
|
|
|
|
$info->{COLUMN_DEF} =~ s/^'(.*)'$/$1/; |
|
1598
|
|
|
|
|
|
|
#default can also be an array |
|
1599
|
|
|
|
|
|
|
if($info->{COLUMN_DEF} =~ m/^\{.*,.*\}$/) { |
|
1600
|
|
|
|
|
|
|
($res{VALUE}) = $self->_dbsql_parse($info->{COLUMN_DEF}); |
|
1601
|
|
|
|
|
|
|
} |
|
1602
|
|
|
|
|
|
|
else { |
|
1603
|
|
|
|
|
|
|
$res{VALUE} = $info->{COLUMN_DEF}; |
|
1604
|
|
|
|
|
|
|
} |
|
1605
|
|
|
|
|
|
|
} |
|
1606
|
|
|
|
|
|
|
#call the datatype handlers |
|
1607
|
|
|
|
|
|
|
$info->{TYPE_NAME} =~ s/\[\]$//; |
|
1608
|
|
|
|
|
|
|
my $handler; |
|
1609
|
|
|
|
|
|
|
if(ref($self->{skin_obj}->get_dbsql_dthandler($info->{TYPE_NAME})) eq 'CODE') { |
|
1610
|
|
|
|
|
|
|
$handler = $self->{skin_obj}->get_dbsql_dthandler($info->{TYPE_NAME}); |
|
1611
|
|
|
|
|
|
|
} |
|
1612
|
|
|
|
|
|
|
else { |
|
1613
|
|
|
|
|
|
|
$handler = $self->{skin_obj}->get_dbsql_dthandler('default'); |
|
1614
|
|
|
|
|
|
|
} |
|
1615
|
|
|
|
|
|
|
&$handler($self, \%res, $info); |
|
1616
|
|
|
|
|
|
|
#hide primary keys |
|
1617
|
|
|
|
|
|
|
if($self->{dbsql_pkey}->{$tbl}->{$info->{COLUMN_NAME}} && $self->{dbsql_hide_pkey}) { |
|
1618
|
|
|
|
|
|
|
$res{templ} = 'dbsql_hidden'; |
|
1619
|
|
|
|
|
|
|
$res{TITLE} = ''; |
|
1620
|
|
|
|
|
|
|
} |
|
1621
|
|
|
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
#the user can define configuration variables in the fields description |
|
1623
|
|
|
|
|
|
|
#we parse the description here and ensure that the form configuration gets completed |
|
1624
|
|
|
|
|
|
|
if($info->{REMARKS}) { |
|
1625
|
|
|
|
|
|
|
while($info->{REMARKS} =~ m/\G.*?([A-Za-z_]+)\=(?:;|(.*?[^\\]{1});)/g) { |
|
1626
|
|
|
|
|
|
|
my $var = $1; |
|
1627
|
|
|
|
|
|
|
local $_; |
|
1628
|
|
|
|
|
|
|
if(defined($2)) { |
|
1629
|
|
|
|
|
|
|
($_ = $2) =~ s/\\;/;/g; |
|
1630
|
|
|
|
|
|
|
} |
|
1631
|
|
|
|
|
|
|
else { |
|
1632
|
|
|
|
|
|
|
$_ = ''; |
|
1633
|
|
|
|
|
|
|
} |
|
1634
|
|
|
|
|
|
|
($res{$var}) = $self->_dbsql_parse($_); |
|
1635
|
|
|
|
|
|
|
$res{$var} = '' unless(defined($res{$var})); |
|
1636
|
|
|
|
|
|
|
} |
|
1637
|
|
|
|
|
|
|
} |
|
1638
|
|
|
|
|
|
|
|
|
1639
|
|
|
|
|
|
|
#display_as describes in which format the value should be displayed |
|
1640
|
|
|
|
|
|
|
if(defined($res{display_as}) and defined($res{VALUE}) and ref($res{display_as}) eq 'ARRAY') { |
|
1641
|
|
|
|
|
|
|
$res{VALUE} = [$res{VALUE}] unless(ref($res{VALUE}) eq 'ARRAY'); |
|
1642
|
|
|
|
|
|
|
my @test = $self->_flatten_array(@{$res{VALUE}}); |
|
1643
|
|
|
|
|
|
|
($res{VALUE}) = _array2array($res{display_as},[$self->_flatten_array(@{$res{VALUE}})]); |
|
1644
|
|
|
|
|
|
|
} |
|
1645
|
|
|
|
|
|
|
|
|
1646
|
|
|
|
|
|
|
# only if null fields are going to be written we set the not_null check, see dbsql_set_write_null_fields for better understanding |
|
1647
|
|
|
|
|
|
|
if($self->{dbsql_write_null_fields} > 2 || ($self->{dbsql_write_null_fields} > 1 && !$info->{COLUMN_DEF}) and !$info->{NULLABLE}) { |
|
1648
|
|
|
|
|
|
|
$res{ERROR} = ($res{ERROR} ? [$res{ERROR}] : []) unless(ref($res{ERROR}) eq 'ARRAY'); |
|
1649
|
|
|
|
|
|
|
push @{$res{ERROR}}, 'not_null'; |
|
1650
|
|
|
|
|
|
|
} |
|
1651
|
|
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
|
#we need the following later to distinguish whether a field which was submitted with an empty value shall be written into database or not |
|
1653
|
|
|
|
|
|
|
$self->{dbsql_not_null_fields}->{$res{fname}} = 1 unless($info->{NULLABLE}); |
|
1654
|
|
|
|
|
|
|
$self->{dbsql_has_default_fields}->{$res{fname}} = 1 unless(defined($info->{COLUMN_DEF})); |
|
1655
|
|
|
|
|
|
|
#add the preconf settings made by the user |
|
1656
|
|
|
|
|
|
|
if(ref($self->{dbsql_preconf}->{$info->{COLUMN_NAME}}) eq 'HASH') { |
|
1657
|
|
|
|
|
|
|
foreach $_ (keys(%{$self->{dbsql_preconf}->{$info->{COLUMN_NAME}}})) { |
|
1658
|
|
|
|
|
|
|
#the given values shall not overwrite but complete the default settings |
|
1659
|
|
|
|
|
|
|
if($_ =~ m/^__add_(.+)_(first|last)$/) { |
|
1660
|
|
|
|
|
|
|
my $varname = $1; |
|
1661
|
|
|
|
|
|
|
my $pos = $2; |
|
1662
|
|
|
|
|
|
|
$res{$varname} = [] if(!defined($res{$varname})); |
|
1663
|
|
|
|
|
|
|
$res{$varname} = [$res{$varname}] if(ref($res{$varname}) ne 'ARRAY'); |
|
1664
|
|
|
|
|
|
|
my $addvalue = $self->{dbsql_preconf}->{$info->{COLUMN_NAME}}->{$_}; |
|
1665
|
|
|
|
|
|
|
$addvalue = [$addvalue] unless(ref($addvalue) eq 'ARRAY'); |
|
1666
|
|
|
|
|
|
|
if($pos eq 'last') { |
|
1667
|
|
|
|
|
|
|
push @{$res{$varname}}, @$addvalue; |
|
1668
|
|
|
|
|
|
|
} |
|
1669
|
|
|
|
|
|
|
elsif($pos eq 'first') { |
|
1670
|
|
|
|
|
|
|
#why not use unshift? |
|
1671
|
|
|
|
|
|
|
@{$res{$varname}} = (@$addvalue, @{$res{$varname}}); |
|
1672
|
|
|
|
|
|
|
} |
|
1673
|
|
|
|
|
|
|
} |
|
1674
|
|
|
|
|
|
|
else { |
|
1675
|
|
|
|
|
|
|
$res{$_} = $self->{dbsql_preconf}->{$info->{COLUMN_NAME}}->{$_}; |
|
1676
|
|
|
|
|
|
|
} |
|
1677
|
|
|
|
|
|
|
} |
|
1678
|
|
|
|
|
|
|
} |
|
1679
|
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
} |
|
1681
|
|
|
|
|
|
|
return \%res; |
|
1682
|
|
|
|
|
|
|
} |
|
1683
|
|
|
|
|
|
|
|
|
1684
|
|
|
|
|
|
|
# transform array string-notation (database) into perl array |
|
1685
|
|
|
|
|
|
|
# this method works recursive |
|
1686
|
|
|
|
|
|
|
sub _dbsql_parse { |
|
1687
|
|
|
|
|
|
|
my ($self,$struc) = @_; |
|
1688
|
|
|
|
|
|
|
return [$self->_dbsql_parse($1,1)] if($struc =~ m/^\{([^{}]*)\}$/); |
|
1689
|
|
|
|
|
|
|
my $struc2 = $struc; |
|
1690
|
|
|
|
|
|
|
#just delete quoted (" ... ") sections since they shouldn't be parsed! |
|
1691
|
|
|
|
|
|
|
while($struc2 =~ s/(\G|[^\\]{1})"(?!.*\\).*?"/$1/){}; |
|
1692
|
|
|
|
|
|
|
if($struc2 =~ m/^[^{\,}]*$/) { |
|
1693
|
|
|
|
|
|
|
#remove the quotations, they're only for preventing certain parts of being parsed but not meant to be really part of the array in the end |
|
1694
|
|
|
|
|
|
|
while($struc =~ s/(^|[^\\]{1})"/$1/g){}; |
|
1695
|
|
|
|
|
|
|
#to be able to print " in a quotated section the \ before an " marks it for not being interpreted |
|
1696
|
|
|
|
|
|
|
#now we should remove those \ so that in the end everything looks normal again |
|
1697
|
|
|
|
|
|
|
$struc =~ s/\\"/"/g; |
|
1698
|
|
|
|
|
|
|
return $struc; |
|
1699
|
|
|
|
|
|
|
} |
|
1700
|
|
|
|
|
|
|
my @res = (); |
|
1701
|
|
|
|
|
|
|
#we've a normal list of values here (seperated by ,), no subarrays, so we can easily split the list and just return the resulting array |
|
1702
|
|
|
|
|
|
|
if($struc =~ m/^([^"{}]*\,[^"{}]*)$/) { |
|
1703
|
|
|
|
|
|
|
local $_ = $1; |
|
1704
|
|
|
|
|
|
|
push @res, split(/,/, $_) if($_); |
|
1705
|
|
|
|
|
|
|
push @res, '' if($struc =~ m/,$/); |
|
1706
|
|
|
|
|
|
|
push @res, '' if($struc =~ m/^,$/); |
|
1707
|
|
|
|
|
|
|
return @res; |
|
1708
|
|
|
|
|
|
|
} |
|
1709
|
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
my ($off,$lbr,$rbr,$quot) = (0,0,0,0,0,0,0); |
|
1711
|
|
|
|
|
|
|
my $last = $_ = ''; |
|
1712
|
|
|
|
|
|
|
for(my $i=0; $i
|
|
1713
|
|
|
|
|
|
|
$last = $_; |
|
1714
|
|
|
|
|
|
|
$_ = substr($struc, $i, 1); |
|
1715
|
|
|
|
|
|
|
last unless defined($_); |
|
1716
|
|
|
|
|
|
|
#we found a quotation mark, now we've to wait till we reach the end |
|
1717
|
|
|
|
|
|
|
++ $quot && $i
|
|
1718
|
|
|
|
|
|
|
#we're not in a quoted area if $quot % 2 == 0 |
|
1719
|
|
|
|
|
|
|
unless($quot % 2) { |
|
1720
|
|
|
|
|
|
|
++ $lbr and next if($_ eq '{'); |
|
1721
|
|
|
|
|
|
|
#if we're at the end of the string we mustn't do a next because that would cause a break of the loop |
|
1722
|
|
|
|
|
|
|
++ $rbr and $i
|
|
1723
|
|
|
|
|
|
|
#when we find a ',' or we're at the end of the string and there are as may '{' as '}' we shall parse the piece from the last ',' or beginning till here |
|
1724
|
|
|
|
|
|
|
if($_ eq ',' || $i >= length($struc)-1 and $lbr == $rbr) { |
|
1725
|
|
|
|
|
|
|
# when we're at the end we must add 1 more because $i wasn't increased because we didn't do a 'next' |
|
1726
|
|
|
|
|
|
|
local $_ = substr($struc,$off,$i-$off); |
|
1727
|
|
|
|
|
|
|
#remove brackets |
|
1728
|
|
|
|
|
|
|
if(m/^{(.*)}$/) { |
|
1729
|
|
|
|
|
|
|
push @res, [$self->_dbsql_parse($1)]; |
|
1730
|
|
|
|
|
|
|
} |
|
1731
|
|
|
|
|
|
|
else { |
|
1732
|
|
|
|
|
|
|
push @res, $self->_dbsql_parse($_); |
|
1733
|
|
|
|
|
|
|
} |
|
1734
|
|
|
|
|
|
|
$off=$i+1; |
|
1735
|
|
|
|
|
|
|
next; |
|
1736
|
|
|
|
|
|
|
} |
|
1737
|
|
|
|
|
|
|
} |
|
1738
|
|
|
|
|
|
|
} |
|
1739
|
|
|
|
|
|
|
return @res; |
|
1740
|
|
|
|
|
|
|
} |
|
1741
|
|
|
|
|
|
|
|
|
1742
|
|
|
|
|
|
|
#compare given checksum with the checksum of the given value |
|
1743
|
|
|
|
|
|
|
sub _dbsql_chk_check_sum { |
|
1744
|
|
|
|
|
|
|
my($self,$md5hash,$val) = @_; |
|
1745
|
|
|
|
|
|
|
return 1 if($md5hash eq md5_hex(join($self->{skin_obj}->get_dbsql_secret(), @{$val}) . $self->{skin_obj}->get_dbsql_secret())); |
|
1746
|
|
|
|
|
|
|
return 0; |
|
1747
|
|
|
|
|
|
|
} |
|
1748
|
|
|
|
|
|
|
|
|
1749
|
|
|
|
|
|
|
#gets error string and error number from dbi object, the sqlstatement which causes the error should be passed to the method. it then adds part of this information (depending on dbsql_sqlerr_show) to the bottom of the form using a special template which name is provided by dbsql_sqlerr_tmpl (can be changed by method dbsql_set_sqlerr_templ) |
|
1750
|
|
|
|
|
|
|
sub _dbsql_sql_error { |
|
1751
|
|
|
|
|
|
|
my($self, $sql) = @_; |
|
1752
|
|
|
|
|
|
|
$self->{dbsql_sqlerr} = [$self->{dbsql}->errstr, $sql, $self->{dbsql}->err]; |
|
1753
|
|
|
|
|
|
|
my %errconf = ( |
|
1754
|
|
|
|
|
|
|
ERRNUM => $self->{dbsql_sqlerr_show} & 1 ? $self->{dbsql}->err : gettext('can\'t be displayed'), |
|
1755
|
|
|
|
|
|
|
ERRMSG => $self->{dbsql_sqlerr_show} & 2 ? $self->{dbsql}->errstr : gettext('can\'t be displayed'), |
|
1756
|
|
|
|
|
|
|
SQLSTAT => $self->{dbsql_sqlerr_show} & 4 ? $sql : gettext('can\'t be displayed') |
|
1757
|
|
|
|
|
|
|
); |
|
1758
|
|
|
|
|
|
|
$self->_add_to_output($self->{dbsql_sqlerr_tmpl},\%errconf); |
|
1759
|
|
|
|
|
|
|
} |
|
1760
|
|
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
|
#this method is for internal use only, it just ensures that the given value is an array reference, if not it turns it into one |
|
1762
|
|
|
|
|
|
|
sub retarref { |
|
1763
|
|
|
|
|
|
|
my $arr = shift; |
|
1764
|
|
|
|
|
|
|
defined($arr) ? return [$arr] : return [] if(ref($arr) ne 'ARRAY'); |
|
1765
|
|
|
|
|
|
|
return $arr; |
|
1766
|
|
|
|
|
|
|
} |
|
1767
|
|
|
|
|
|
|
|
|
1768
|
|
|
|
|
|
|
# expects 2 array references. it then takes the first arrays structure as a template in which it puts the values of the second array. the result is returned. |
|
1769
|
|
|
|
|
|
|
sub _array2array { |
|
1770
|
|
|
|
|
|
|
my($arr1,$arr2,$i) = @_; |
|
1771
|
|
|
|
|
|
|
$i = 0 unless($i); |
|
1772
|
|
|
|
|
|
|
my (@res,$elem); |
|
1773
|
|
|
|
|
|
|
foreach $elem (@$arr1) { |
|
1774
|
|
|
|
|
|
|
if(ref($elem) eq 'ARRAY') { |
|
1775
|
|
|
|
|
|
|
local $_; |
|
1776
|
|
|
|
|
|
|
($_,$i) = _array2array($elem,$arr2,$i); |
|
1777
|
|
|
|
|
|
|
push @res, $_; |
|
1778
|
|
|
|
|
|
|
} |
|
1779
|
|
|
|
|
|
|
else { |
|
1780
|
|
|
|
|
|
|
push @res, defined($arr2->[$i]) ? $arr2->[$i] : ''; |
|
1781
|
|
|
|
|
|
|
$i ++; |
|
1782
|
|
|
|
|
|
|
} |
|
1783
|
|
|
|
|
|
|
} |
|
1784
|
|
|
|
|
|
|
return (\@res, $i); |
|
1785
|
|
|
|
|
|
|
} |
|
1786
|
|
|
|
|
|
|
|
|
1787
|
|
|
|
|
|
|
###################################################################### |
|
1788
|
|
|
|
|
|
|
|
|
1789
|
|
|
|
|
|
|
=head1 EXTENDING FORMENGINE::DBSQL |
|
1790
|
|
|
|
|
|
|
|
|
1791
|
|
|
|
|
|
|
=head2 Write A Handler For Another Datatype |
|
1792
|
|
|
|
|
|
|
|
|
1793
|
|
|
|
|
|
|
Have a look at DtHandler.pm and read |
|
1794
|
|
|
|
|
|
|
L. |
|
1795
|
|
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
=head2 Suiting the Layout |
|
1797
|
|
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
|
For this task you should create a new skin. For general information |
|
1799
|
|
|
|
|
|
|
about FormEngine skins, have a look at L and its |
|
1800
|
|
|
|
|
|
|
submodules. You should also read |
|
1801
|
|
|
|
|
|
|
L and its source code, the |
|
1802
|
|
|
|
|
|
|
templates which are defined there are necessary for DBSQL.pm and you |
|
1803
|
|
|
|
|
|
|
should at least implement replacements for them in your new skin. Use |
|
1804
|
|
|
|
|
|
|
C to load your skin. |
|
1805
|
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
=head1 MORE INFORMATION |
|
1807
|
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
Have a look at ... |
|
1809
|
|
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
=over |
|
1811
|
|
|
|
|
|
|
|
|
1812
|
|
|
|
|
|
|
=item |
|
1813
|
|
|
|
|
|
|
|
|
1814
|
|
|
|
|
|
|
L and its source code for |
|
1815
|
|
|
|
|
|
|
information about writing datatype handlers. |
|
1816
|
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
=item |
|
1818
|
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
L and its source code for |
|
1820
|
|
|
|
|
|
|
information about the DBSQL.pm specific templates. |
|
1821
|
|
|
|
|
|
|
|
|
1822
|
|
|
|
|
|
|
=back |
|
1823
|
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
=head1 BUGS |
|
1825
|
|
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
|
Please use |
|
1827
|
|
|
|
|
|
|
L to |
|
1828
|
|
|
|
|
|
|
inform you about reported bugs and to report bugs. |
|
1829
|
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
If it doesn't work feel free to email directly to |
|
1831
|
|
|
|
|
|
|
moritz@freesources.org. |
|
1832
|
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
Thanks! |
|
1834
|
|
|
|
|
|
|
|
|
1835
|
|
|
|
|
|
|
=head1 AUTHOR |
|
1836
|
|
|
|
|
|
|
|
|
1837
|
|
|
|
|
|
|
(c) 2003-2004, Moritz Sinn. This module is free software; you can |
|
1838
|
|
|
|
|
|
|
redistribute it and/or modify it under the terms of the GNU General |
|
1839
|
|
|
|
|
|
|
Public License (see http://www.gnu.org/licenses/gpl.txt) as published |
|
1840
|
|
|
|
|
|
|
by the Free Software Foundation; either version 2 of the License, or |
|
1841
|
|
|
|
|
|
|
(at your option) any later version. |
|
1842
|
|
|
|
|
|
|
|
|
1843
|
|
|
|
|
|
|
This module is distributed in the hope that it will be useful, but |
|
1844
|
|
|
|
|
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of |
|
1845
|
|
|
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|
1846
|
|
|
|
|
|
|
General Public License for more details. |
|
1847
|
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
I am always interested in knowing how my work helps others, so if you |
|
1849
|
|
|
|
|
|
|
put this module to use in any of your own code please send me the |
|
1850
|
|
|
|
|
|
|
URL. If you make modifications to the module because it doesn't work |
|
1851
|
|
|
|
|
|
|
the way you need, please send me a copy so that I can roll desirable |
|
1852
|
|
|
|
|
|
|
changes into the main release. |
|
1853
|
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
Please use |
|
1855
|
|
|
|
|
|
|
L for |
|
1856
|
|
|
|
|
|
|
comments, suggestions and bug reports. If it doesn't work feel free to |
|
1857
|
|
|
|
|
|
|
mail to moritz@freesources.org. |
|
1858
|
|
|
|
|
|
|
|
|
1859
|
|
|
|
|
|
|
=head1 CREDITS |
|
1860
|
|
|
|
|
|
|
|
|
1861
|
|
|
|
|
|
|
Special thanks to Mark Stosberg, he helped a lot by reporting bugs, |
|
1862
|
|
|
|
|
|
|
contributing new ideas and sending patches. |
|
1863
|
|
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
=head1 SEE ALSO |
|
1865
|
|
|
|
|
|
|
|
|
1866
|
|
|
|
|
|
|
HTML::FormEngine by Moritz Sinn |
|
1867
|
|
|
|
|
|
|
|
|
1868
|
|
|
|
|
|
|
HTML::FormTemplate by Darren Duncan |
|
1869
|
|
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
|
=cut |
|
1871
|
|
|
|
|
|
|
|
|
1872
|
|
|
|
|
|
|
1; |
|
1873
|
|
|
|
|
|
|
|
|
1874
|
|
|
|
|
|
|
__END__ |