line
stmt
bran
cond
sub
pod
time
code
1
#!perl -w
2
#
3
# DBIx::Web - Active Web Database Layer
4
#
5
# makarow at mail.com, started 2003-09-16
6
#
7
# Future ToDo:
8
# - !!! ??? *** review, code review
9
# - record references finder via 'wikn://', 'key://', bracket notation
10
# - root hierarchical record functionality: -ridRoot
11
# - calendar views: type and start/end time; start sub{}, entry sub{}, periodical rec.
12
# - mail-in interface - records and message browser source
13
# - logfile reading interface - message browser source
14
# - acknowledgements feature - message browser implementation
15
# - replication feature - distributing data
16
# - 'recRead' alike calls may return an objects, knows metadata
17
# - remake in three tiers: database with triggers, web interface, communicator
18
#
19
# Problems - Think:
20
# - strDiff() breaks hyperlinks
21
# - table operation trigger instead of -cgiRun0A: should be included within each trigger and duplicated within actions and user interface
22
# # -unflt/uglist, -ugflt/uglist/ugroups, -usernt/user/uglist, -userln/user/uglist, -udisp/udisp, -ugadd/ugroups/uglist
23
# # ui: -unflt, -udisp
24
# # pi: -ugflt, -usernt, -userln, -ugadd
25
# # pc: uglist, user, ugroups, udisp
26
# - store for users preferences, homepages, notes, etc.
27
#
28
# Limitation Issues:
29
# - PerlEx/IIS Source='Application Error', EventID=1000, faulting application:
30
# w3wp.exe 6.0.3790.1830; unknown 0.0.0.0; address 0x01805f98.
31
# w3wp.exe 6.0.3790.1830; w3cache.dll 6.0.3790.1830; address 0x0000342a.
32
# w3wp.exe 6.0.3790.3959; w3cache.dll 6.0.3790.3959; address 0x0000341a.
33
# W3SVC. Warning. 1009. A process serving application pool 'IIS5AppPool' terminated unexpectedly. The process id was '6280'. The process exit code was '0xc0000005'.
34
# ? may occur stopping www serice with DBIx::Web, CGI::Bus, printenv.cgi, reload.cgi
35
# ? this may be a PerlEx bug or bug in my PerlEx installation
36
# - html page scrolling with menu bar
37
# # no simple means
38
# - innice htmlML() selection: _frmName.value=_form.value ? _form.value : '';
39
# # ms-help://MS.MSDNQTR.2005JAN.1033/DHTML/workshop/samples/author/dhtml/refs/oncontextmenu.htm
40
# - dbmSeek() -key=>{[{}]} syntax of cgiForm(recQBF)/cgiQKey
41
# # dbm not used at all, it seems
42
#
43
# ToDo:
44
# CMDB / Service Desk:
45
# - hdesk: association records, invisible when not needed?
46
# - cmdb/hdesk: status classification graphs: object, application, location, personal
47
#
48
# Done:
49
#
50
51
package DBIx::Web;
52
require 5.000;
53
1
1
4878
use strict;
1
2
1
40
54
1
1
998
use UNIVERSAL;
1
14
1
6
55
1
1
1001
use POSIX;
1
7947
1
6
56
1
1
3323
use Fcntl qw(:DEFAULT :flock :seek :mode);
1
2
1
754
57
58
1
1
5
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD $SELF $CACHE $LNG $IMG);
1
1
1
19697
59
60
$VERSION= '0.80';
61
$SELF =undef; # current object pointer, use 'local $SELF'
62
$CACHE ={}; # cache for pointers to subobjects
63
*isa = \&UNIVERSAL::isa; isa('',''); # isa function
64
65
my $RISM0 ='/'; # record identification separation mark 0
66
my $RISM1 ='//'; # record identification table/id seperator
67
# (-idsplit; consider -recInsID, -rfdName)
68
my $RISM2 ='.rfd'; # record identification end special mark
69
my $NLEN =14; # length to pad left numbers in indexes
70
my $LIMRS =512; # limit of result set
71
my $LIMLB =8 *$LIMRS; # limit of result set for listboxes
72
my $KSORD ='-aall'; # default key sequental order
73
my $HS =';'; # hyperlink parameters separation style '&'
74
my $TW32 =($^O eq 'MSWin32') && (*Win32::GetTickCount{CODE}) && eval{Win32::GetTickCount()};
75
76
if ($ENV{MOD_PERL_API_VERSION}
77
&& ($ENV{MOD_PERL_API_VERSION} >=2)) {
78
# eval('use Apache2; use Apache2::compat;')
79
# eval('use Apache2; use Apache2::Const; use Apache2::ServerUtil;');
80
}
81
elsif ($ENV{MOD_PERL}) {
82
eval('use Apache qw(exit)')
83
}
84
85
$LNG ={ # Language constants
86
'' =>undef # see also '-tn' definitions; htmlSubmitSpl()
87
,-die =>sub{CORE::die(@_)}
88
,-warn =>sub{CORE::warn(@_)}
89
,'' =>{'' =>['', '']
90
,-lang =>['en', '']
91
,-charset =>['windows-1252','']
92
93
,-style =>['Style', 'HTML/XML style decoration URL']
94
,'-frame=set' =>['Frameset', 'Frameset form']
95
,-affected =>['affected', 'rows affected']
96
,-fetched =>['fetched', 'rows fetched']
97
98
,-key =>['Key', 'Key of the record']
99
,-wkey =>['Lock key', 'Key to lock update of the record']
100
,-wikn =>['Name', 'May contain name of the record']
101
,-ridRef =>['References','References to another records']
102
,-rvcActPtr =>['Versioning','When record is been saving, its old version record is to be created pointing to it']
103
,-rvcChgState =>['Changing', 'Record is under change without versioning, files may be attached']
104
,-rvcCkoState =>['Check out', 'Record is checked out, without versioning, files may be attached']
105
,-rvcDelState =>['Deleted', 'Record is deleted logically']
106
,-racWriter =>['Writers', 'Writers of the record']
107
,-racReader =>['Readers', 'Readers of the reord']
108
,-racActor =>['Actors', 'Actors of the record']
109
,-racManager =>['Managers', 'Managers of the record']
110
,-racPrincipal =>['Principals','Principals of the record']
111
,-racUser =>['Users', 'Users of the record']
112
113
,'Error' =>['Error', 'Error']
114
,'rfaUplEmpty' =>['empty', 'Empty filehandle']
115
,'recUpdAclStp' =>['', 'Record updation prohibited to you']
116
,'recUpdVerStp' =>['', 'Editing record\'s version prohibited']
117
,'recDelAclStp' =>['', 'Record deletion prohibited to you']
118
,'recReadAclStp'=>['', 'Record reading prohibited to you']
119
,'fldReqStp' =>['required', 'value required']
120
,'fldChkStp' =>['constraint','constraint violated']
121
122
,'home' =>['Home', 'Home screen']
123
,'schpane' =>['Navigation','Navigation/Search pane']
124
,'back' =>['<', 'Back screen']
125
,'login' =>['Login', 'Login as personated user']
126
,'frmCall' =>['Go', 'Goto/execute choise']
127
,'frmCallOpn' =>['Open']
128
,'frmCallNew' =>['Create for','Create new record to insert into']
129
,'frmHelp' =>['Help', 'Help screen']
130
,'frmErr' =>['Error', 'Error screen']
131
,'frmName' =>['Form', 'Form choice']
132
,'frmLso' =>['Selection', "Records selections, may overlap other query conditions specified, may be switched off by '--x' choices"]
133
,'frmLsoff' =>['------------x', 'Switch off selections below']
134
,'frmLsc' =>['Ordering', 'Records ordering, may overlap other query conditions spacified']
135
,'frmName1' =>['Create', 'Create new record with form choosen to insert into database']
136
,'recNew' =>['Create', 'Create new record to insert into database']
137
,'recRead' =>['Read', 'Read record from the database; escape edit mode discarding changes']
138
,'recEdit' =>['Edit', 'Edit this record to update in the database']
139
,'recPrint' =>['Print', 'Printable form']
140
,'recXML' =>['XML', 'XML form']
141
,'recHist' =>['History', 'History of changes form']
142
,'recIns' =>['Insert', 'Insert this data into database as a new record']
143
,'recUpd' =>['Save', 'Update this record or save data into database']
144
,'recDel' =>['Delete', 'Delete this record in the database']
145
,'recForm' =>['Form', 'Recheck this data on server']
146
,'recList' =>['List', 'List records, execute query']
147
,'recQBF' =>['Query', 'Specify records to be listed']
148
,'recQBFReset' =>['Reset', 'Reset query conditions to default']
149
150
,'-query' =>['Query', 'Data query specification']
151
,'-qkeyord' =>['SEEK', 'Key seek relation']
152
,'-qjoin' =>['JOIN', 'FROM database query clause addition to use for WHERE']
153
,'-qwhere' =>['WHERE', 'WHERE database query clause']
154
,'-qwheredbm' =>['Perl', "{fieldname} (eq|[gt][lt]) 'value' and|or {fieldname} <>==value..."]
155
,'-qwheredbi' =>['SQL', "fieldname <>= 'value' AND|OR...; #ftext('string'), #urole('role'), #urole('role','name')"
156
,[["#ftext('string')","full text search substitution, alike FULL TEXT"]
157
,["#urole(role)", "user role, alike UROLE: author, authors, actor, actors, manager, managers, principal, principals, user, users"]
158
,["#urole(role, user)", "user role and name, alike UROLE and UNAME"]
159
,['See also', "SQL query syntax"]
160
]]
161
,'-qurole' =>['UROLE', 'Role of User']
162
,'-quname' =>['UNAME', 'Name of User']
163
,'-qftext' =>['FULL TEXT', 'Full-text search string']
164
,'-qversion' =>['VERSIONS', 'Including old versions of records']
165
,'-qorder' =>['ORDER BY', 'ORDER BY database query clause']
166
,'-qlimit' =>['LIMIT', 'LIMIT database query clause']
167
,'-qdisplay' =>['DISPLAY', 'Columns to display in list']
168
,'-qurl' =>['URL', 'Query URL constructed, press \'Form\' to refresh']
169
170
,'rfafolder' =>['Files', 'File Attachments']
171
,'rfauplfld' =>['Upload', 'File to upload']
172
,'rfaupdate' =>['+/-', 'Upload file, close or delete attachments selected']
173
,'rfaopen' =>['...', 'Opened file attachments to be closed']
174
,'rfaclose' =>['Close']
175
,'rfadelm' =>['Delete', 'Mark file attachments to be deleted']
176
177
,'ddlbopen' =>['...', 'Open values']
178
,'ddlbopenl' =>['>', 'Open values recursion']
179
,'ddlbsubmit' =>['Set', 'Assign value selected']
180
,'ddlbreset' =>['c', 'Clear value']
181
,'ddlbclose' =>['x', 'Close values']
182
,'ddlbfind' =>['..', 'Find value in the list']
183
184
,'tvmVersions' =>['All Versions', 'All records and their versions']
185
,'tvmHistory' =>['All News', 'All news, updates, deletions']
186
,'tvmReferences'=>['All References', 'All references to records']
187
,'tvdIndex' =>['All Contents', 'Table of contents']
188
,'tvdFTQuery' =>['All Files Find', 'Full-text query on files']
189
,'-qftwhere' =>['FTQuery', 'Full-text query condition']
190
,'-qftord' =>['FTOrder', 'Full-text search result set sort order']
191
,'-qftlimit' =>['FTLimit', 'Full-text search result set limit']
192
193
,'table' =>['Table', 'Table or recfile name']
194
,'id' =>['ID', 'Record ID', 'id']
195
,'ir' =>['IR', "Refered ID"]
196
,'idrm' =>['AboveID', "Record, above this, 'id' or 'table'//'id'"]
197
,'idpr' =>['PrevID', "Record, previous to this, 'id' or 'table'//'id'"]
198
,'hierarchy' =>['hierarchy']
199
,'cuser' =>['Ins by', 'User, record inserted by']
200
,'creator' =>['Ins by', 'User, record inserted by']
201
,'ctime' =>['Ins time', 'Date and time, record inserted when']
202
,'uuser' =>['Upd by', 'User, record updated by']
203
,'updater' =>['Upd by', 'User, record updated by']
204
,'utime' =>['Upd time', 'Date and time, record updated when']
205
,'idnv' =>['Ver of', 'Actual record ID, points to the actual and fresh version']
206
,'vtime' =>['Ver time', 'Date and time, version recorded when']
207
,'status' =>['State', 'State of the record']
208
,'todo' =>['todo']
209
,'done' =>['done']
210
,'deleted' =>['deleted']
211
,'edit' =>['edit']
212
,'chk-out' =>['chk-out']
213
,'all' =>['all']
214
,'auser' =>['Actor', 'Actor of the record, user name']
215
,'actor' =>['Actor', 'Actor of the record, user name']
216
,'arole' =>['Actors', 'Role of the actor of the record or additional actor user']
217
,'actors' =>['Actors', 'Actors of the record, users and groups, comma delimited']
218
,'puser' =>['Principal', 'Principal of the record, user name']
219
,'principal' =>['Principal', 'Principal of the record, user name']
220
,'prole' =>['Principals','Role of the principal of the record or additional principal user']
221
,'principals' =>['Principals','Principals of the record, users and groups, comma delimited']
222
,'manager' =>['Manager', 'Manager of the record, user name']
223
,'muser' =>['Manager', 'Manager of the record, user name']
224
,'mrole' =>['Managers', 'Role of the manager of the record, group or user']
225
,'managers' =>['Managers', 'Managers of the record, users and groups, comma delimited']
226
,'owner' =>['Owner', 'Owner of the record, user name']
227
,'orole' =>['Owners', 'Role of the owner of the record or additional owner']
228
,'owners' =>['Owners', 'Owners of the record, users and groups, comma delimited']
229
,'user' =>['User', 'User of the record, user name']
230
,'users' =>['Users', 'Users of the record, users and groups, comma delimited']
231
,'author' =>['Author', 'Author of the record, user name']
232
,'authors' =>['Authors', 'Authors of the record, comma delimited']
233
,'rrole' =>['Readers', 'Readers of the record, group or role']
234
,'readers' =>['Readers', 'Readers of the record, users and groups, comma delimited']
235
,'mailto' =>['MailTo', 'Receipients of e-mail of the record status current, comma delimited']
236
,'record' =>['Record', 'Class/type of the record described by']
237
,'object' =>['Object', 'Object of the record described by']
238
,'project' =>['Project', 'Project, related to the record']
239
,'cost' =>['Cost', 'Cost of the record described by']
240
,'doctype' =>['Doctype', 'Type of the document contained']
241
,'subject' =>['Subject', 'Subject, Title, Brief description']
242
,'comment' =>['Comment', "Comment text or HTML. Special URL protocols: 'urlh://' (this host), 'urlr://' (this application), 'urlf://' (file attachments), 'key://' (record id or table${RISM1}id), 'wikn://' (wikiname). Bracket URL notations: [[xxx://...]], [[xxx://...][label]], [[xxx://...|label]]. Starting text with condition may be used for embedded query"]
243
,'-htmlopt' =>['Optional HTML', "Field may contain HTML, start text with HTML tag for this case, otherwise plain text will be supposed."]
244
,'-hrefs' =>['Hyperlinks','Hyperlinks in the text will be recognized and highlighted:'
245
,[['urlh://',"This host URL"]
246
,['urlr://',"This script URL, use urlr://?param=value;..."]
247
,['urlf://',"Files attached to the record"]
248
,['key://id','Open the record with ID given in this table']
249
,['key://table//id', 'Record in the particular table']
250
,['wikn://name', "Named record"]
251
,['[[xxx://...]]', 'Without escaping key:// or wikn:// (not in HTML)']
252
,['[[...|label]]', 'Text to highlight (not in HTML)']
253
,['[[...][label]]', 'Another syntax (not in HTML)']
254
]]
255
,'cargo' =>['Cargo', 'Additional data']
256
}
257
,'ru' =>{'' =>['', '']
258
,-lang =>['ru-RU', '']
259
,-charset =>['windows-1251','']
260
261
,-style =>['Ñòèëü', 'Ãèïåðññûëêà ñòèëåâîé äåêîðàöèè HTML/XML']
262
,'-frame=set' =>['Êàäðèðîâàíèå','Ôîðìà â âèäå íàáîðà ôðåéìîâ']
263
,-affected =>['çàòðîíóòî', 'ñòðîê çàòðîíóòî']
264
,-fetched =>['âûáðàíî', 'ñòðîê âûáðàíî']
265
,-key =>['Êëþ÷', 'Êëþ÷ çàïèñè']
266
,-wkey =>['Êëþ÷ áëê.', 'Êëþ÷ áëîêèðîâêè îáíîâëåíèÿ çàïèñè']
267
,-wikn =>['Èìÿ', 'Ìîæåò ñîäåðæàòü èìÿ çàïèñè']
268
,-ridRef =>['Ññûëêè', 'Ññûëêè íà äðóãèå çàïèñè']
269
,-rvcActPtr =>['Âåðñèîíèðîâàíèå','Ïðè ñîõðàíåíèè çàïèñè, ñîçäàåòñÿ çàïèñü åå ïðåæíåé âåðñèè, óêàçûâàþùàÿ íà àêòóàëüíóþ ñâåæóþ çàïèñü']
270
,-rvcChgState =>['Èçìåíåíèå', 'Èçìåíåíèå çàïèñè áåç âåðñèîíèðîâàíèÿ, âîçìîæíî ïðèñîåäèíåíèå ôàéëîâ']
271
,-rvcCkoState =>['Èçâëå÷åíî', 'Çàïèñü èçâëå÷åíà äëÿ èçìåíåíèÿ, áåç âåðñèîíèðîâàíèÿ, âîçìîæíî ïðèñîåäèíåíèå ôàéëîâ']
272
,-rvcDelState =>['Óäàëåíî', 'Çàïèñü óäàëåíà ëîãè÷åñêè']
273
,-racWriter =>['Ïèñàòåëè', 'Ìîãóò èçìåíÿòü çàïèñü']
274
,-racReader =>['×èòàòåëè', 'Ìîãóò ÷èòàòü çàïèñü']
275
,-racActor =>['Èñïîëíèòåëè','Èñïîëíèòåëè çàïèñè']
276
,-racManager =>['Ìåíåäæåðû', 'Ìåíåäæåðû çàïèñè']
277
,-racPrincipal =>['Èíèöèàòîðû','Èíèöèàòîðû çàïèñè']
278
,-racUser =>['Ïîëüçîâàòåëè','Ïîëüçîâàòåëè çàïèñè']
279
280
,'Error' =>['Îøèáêà', 'Îøèáêà']
281
,'rfaUplEmpty' =>['ïóñòî', 'Ïóñòîé ìàíèïóëÿòîð ôàéëà']
282
,'recUpdAclStp' =>['', 'Èçìåíåíèå çàïèñè íå ðàçðåøåíî ïîëíîìî÷èÿìè äîñòóïà ïîëüçîâàòåëÿ']
283
,'recUpdVerStp' =>['', 'Èçìåíåíèå ïðåæíåé âåðñèè çàïèñè çàïðåùåíî']
284
,'recDelAclStp' =>['', 'Óäàëåíèå çàïèñè íå ðàçðåøåíî ïîëíîìî÷èÿìè äîñòóïà ïîëüçîâàòåëÿ']
285
,'recReadAclStp'=>['', '×òåíèå çàïèñè íå ðàçðåøåíî ïîëíîìî÷èÿìè äîñòóïà ïîëüçîâàòåëÿ']
286
,'fldReqStp' =>['òðåáóåòñÿ', 'çíà÷åíèå òðåáóåòñÿ']
287
,'fldChkStp' =>['îãðàíè÷åíèå','îãðàíè÷åíèå íàðóøåíî']
288
289
,'home' =>['Íà÷àëî', 'Íà÷àëüíàÿ ñòðàíèöà']
290
,'schpane' =>['Íàâèãàòîð', 'Ïàíåëü íàâèãàöèè/ïîèñêà']
291
,'back' =>['<', 'Ïðåäûäóùàÿ ñòðàíèöà']
292
,'login' =>['Âîéòè', 'Îòêðûòü ïåðñîíèôèöèðîâàííûé ñåàíñ']
293
,'frmCall' =>['Âûï', 'Âûïîëíèòü ïåðåõîä, äåéñòâèå, ïîèñê']
294
,'frmCallOpn' =>['Îòêðûòü']
295
,'frmCallNew' =>['Ñîçäàòü äëÿ', 'Ñîçäàòü íîâóþ çàïèñü, ÷òîáû çàòåì âñòàâèòü åå â']
296
,'frmHelp' =>['Ñïðàâêà', 'Ñïðàâî÷íàÿ ñòðàíèöà']
297
,'frmErr' =>['Îøèáêà', 'Ñîîáùåíèå îá îøèáêå']
298
,'frmName' =>['Ôîðìà', 'Âûáîð ôîðìû']
299
,'frmLso' =>['Âûáîðêà', "Âûáîðêè çàïèñåé, ìîãóò ïåðåêðûâàòü äðóãèå çàäàííûå óñëîâèÿ çàïðîñà, îòêëþ÷àþòñÿ âûáîðîì '--x'"]
300
,'frmLsoff' =>['------------x', 'Îòêëþ÷èòü íèæåóêàçàííûé îòáîð']
301
,'frmLsc' =>['Óïîðÿäî÷åíèå','Óïîðÿäî÷åíèå çàïèñåé, ìîæåò ïåðåêðûâàòü äðóãèå çàäàííûå óñëîâèÿ çàïðîñà']
302
,'frmName1' =>['Ñîçäàòü', 'Ñîçäàòü íîâóþ çàïèñü âûáðàííîé ôîðìû, ÷òîáû çàòåì âñòàâèòü åå â áàçó äàííûõ']
303
,'recNew' =>['Ñîçäàòü', 'Ñîçäàòü íîâóþ çàïèñü, ÷òîáû çàòåì âñòàâèòü åå â áàçó äàííûõ']
304
,'recRead' =>['×èòàòü', '(Ïåðå)÷èòàòü çàïèñü èç áàçû äàííûõ; ïåðåéòè îò ðåäàêòèðîâàíèÿ çàïèñè ê ïðîñìîòðó ñ ïîòåðåé ðåçóëüòàòîâ ðåäàêòèðîâàíèÿ']
305
,'recEdit' =>['Ïðàâèòü', 'Íà÷àòü ðåäàêòèðîâàíèå (èçìåíåíèå) çàïèñè']
306
,'recPrint' =>['Ïå÷àòü', 'Ïðåäñòàâëåíèå äëÿ ïå÷àòàíèÿ']
307
,'recXML' =>['XML', 'Ïðåäñòàâëåíèå XML']
308
,'recHist' =>['Èñòîðèÿ', 'Ïðåäñòàâëåíèå èñòîðèè èçìåíåíèé']
309
,'recIns' =>['Âñòàâèòü', 'Äîáàâèòü ðåçóëüòàòû ðåäàêòèðîâàíèÿ â áàçó äàííûõ êàê íîâóþ çàïèñü']
310
,'recUpd' =>['Ñîõðàíèòü', 'Ñîõðàíèòü ðåçóëüòàòû ðåäàêòèðîâàíèÿ (èçìåíåíèÿ) çàïèñè â áàçå äàííûõ']
311
,'recDel' =>['Óäàëèòü', 'Óäàëèòü ýòó çàïèñü èç áàçû äàííûõ']
312
,'recForm' =>['Ôîðì', 'Ïåðåçàãðóçèòü ôîðìó ñ ñåðâåðà, ïåðåâû÷èñëèòü äàííûå']
313
,'recList' =>['Âûáðàòü', '(Ïåðå)÷èòàòü ïðåäñòàâëåíèå, âûáðàòü çàïèñè ñîãëàñíî óñëîâèþ âûáîðêè (ïîèñêà)']
314
,'recQBF' =>['Çàïðîñ', 'Çàäàíèå óñëîâèÿ âûáîðêè (ïîèñêà) çàïèñåé']
315
,'recQBFReset' =>['Ñáðîñ', 'Ñáðîñ óñëîâèÿ âûáîðêè äàííûõ â óìîë÷àíèÿ']
316
317
,'-query' =>['Çàïðîñ', 'Ñïåöèôèêàöèÿ âûáîðêè çàïèñåé']
318
,'-qkeyord' =>['SEEK', 'Íàïðàâëåíèå ïîèñêà ïî êëþ÷ó']
319
,'-qjoin' =>['JOIN', 'Äîïîëíåíèå ê êîíñòðóêöèè çàïðîñà FROM, äëÿ WHERE']
320
,'-qwhere' =>['WHERE', 'Êîíñòðóêöèÿ çàïðîñà WHERE']
321
,'-qurole' =>['UROLE', 'Ðîëü ïîëüçîâàòåëÿ']
322
,'-quname' =>['UNAME', 'Èìÿ ïîëüçîâàòåëÿ']
323
,'-qftext' =>['FULL TEXT', 'Ñòðîêà ïîëíîòåêñòîâîãî ïîèñêà']
324
,'-qversion' =>['VERSIONS', 'Âêëþ÷åíèå ïðåæíèõ âåðñèé çàïèñåé']
325
,'-qorder' =>['ORDER BY', 'Êîíñòðóêöèÿ çàïðîñà ORDER BY']
326
,'-qlimit' =>['LIMIT', 'Êîíñòðóêöèÿ çàïðîñà LIMIT']
327
,'-qdisplay' =>['DISPLAY', 'Ñïèñîê ñòîëáöîâ ïðåäñòàâëåíèÿ']
328
,'-qurl' =>['URL', 'Èòîãîâûé URL çàïðîñà, îáíîâëÿåòñÿ íàæàòèåì \'Ôîðì\'']
329
330
,'rfafolder' =>['Ôàéëû', 'Ïðèñîåäèíåííûå ôàéëû']
331
,'rfauplfld' =>['Çàãðóçèòü', 'Ôàéë äëÿ çàãðóçêè']
332
,'rfaupdate' =>['+/-', 'Çàãðóçèòü ôàéë, çàêðûòü èëè óäàëèòü âûáðàííûå ïðèñîåäèíåíèÿ ôàéëîâ']
333
,'rfaopen' =>['...', 'Îòêðûòûå ïðèñîåäèíåííûå ôàéëû, êîòîðûå ìîæíî çàêðûòü']
334
,'rfaclose' =>['Çàêðûòü']
335
,'rfadelm' =>['Óäàëèòü', 'Ïîìåòèòü ïðèñîåäèíåíèÿ ôàéëîâ äëÿ óäàëåíèÿ']
336
337
,'ddlbopen' =>['...', 'Îòêðûòü ñïèñîê çíà÷åíèé']
338
,'ddlbopenl' =>['>', 'Îòêðûòü ðåêóðñèþ çíà÷åíèé']
339
,'ddlbsubmit' =>['Ïðèñâ.', 'Ïðèñâîèòü âûáðàííîå çíà÷åíèå']
340
,'ddlbreset' =>['c', 'Ñáðîñèòü çíà÷åíèå']
341
,'ddlbclose' =>['x', 'Çàêðûòü ñïèñîê çíà÷åíèé']
342
,'ddlbfind' =>['..', 'Íàéòè çíà÷åíèå â ñïèñêå']
343
344
,'tvmVersions' =>['Âñå Âåðñèè', 'Âñå çàïèñè è èõ âåðñèè']
345
,'tvmHistory' =>['Âñå Íîâîñòè', 'Âñå íîâûå, èçìåíåííûå, óäàëåííûå çàïèñè']
346
,'tvmReferences'=>['Âñå Ññûëêè', 'Âñå ññûëêè íà çàïèñè']
347
,'tvdIndex' =>['Âñå Ñîäåðæàíèå', 'Îãëàâëåíèå']
348
,'tvdFTQuery' =>['Ïîèñê ôàéëîâ', 'Ïîëíîòåêñòîâûé ïîèñê â ôàéëàõ']
349
,'-qftwhere' =>['FTQuery', 'Óñëîâèå ïîëíîòåêñòîâîãî ïîèñêà']
350
,'-qftord' =>['FTOrder', 'Ñîðòèðîâêà ðåçóëüòàòîâ ïîëíîòåêñòîâîãî ïîèñêà']
351
,'-qftlimit' =>['FTLimit', 'Îãðàíè÷åíèå ÷èñëåííîñòè ðåçóëüòàòîâ ïîëíîòåêñòîâîãî ïîèñêà']
352
353
,'table' =>['Òàáëèöà', 'Èìÿ òàáëèöû èëè ôàéëà çàïèñåé']
354
,'id' =>['ID', 'Èäåíòèôèêàòîð çàïèñè', 'id']
355
,'ir' =>['Ññûëêà', "Ññûëêà íà èäåíòèôèêàòîð çàïèñè"]
356
,'idrm' =>['Ãëàâíàÿ', "Èäåíòèôèêàòîð âûøåñòîÿùåé çàïèñè, 'id' ëèáî 'table'//'id'"]
357
,'idpr' =>['Ïðåäø', "Èäåíòèôèêàòîð ïðåäøåñòâóþùåé çàïèñè, 'id' ëèáî 'table'//'id'"]
358
,'hierarchy' =>['èåðàðõèÿ']
359
,'cuser' =>['Ñîçäàë', 'Êåì áûëà ñîçäàíà çàïèñü']
360
,'creator' =>['Ñîçäàë', 'Êåì áûëà ñîçäàíà çàïèñü']
361
,'ctime' =>['Ñîçä-å', 'Êîãäà çàïèñü áûëà ñîçäàíà']
362
,'uuser' =>['Èçìåíèë', 'Êåì áûëà ïîñëåäíèé ðàç èçìåíåíà çàïèñü']
363
,'updater' =>['Èçìåíèë', 'Êåì áûëà ïîñëåäíèé ðàç èçìåíåíà çàïèñü']
364
,'utime' =>['Èçìåí-å', 'Êîãäà ïîñëåäíèé ðàç áûëà èçìåíåíà çàïèñü']
365
,'idnv' =>['Áûâø', 'Èäåíòèôèêàòîð àêòóàëüíîé çàïèñè, óêàçûâàåò íà àêòóàëüíóþ (ïîñëåäíþþ) âåðñèþ']
366
,'vtime' =>['Çàïèñàíî', 'Êîãäà áûëà çàïèñàíà ýòà âåðñèÿ']
367
,'status' =>['Ñòàòóñ', 'Ñòàòóñ çàïèñè, ñîñòîÿíèå èëè ðåçóëüòàò äåÿòåëüíîñòè']
368
,'todo' =>['ñäåëàòü']
369
,'done' =>['çàâåðøåíî']
370
,'deleted' =>['óäàëåíî']
371
,'edit' =>['ðåäàêò-å']
372
,'chk-out' =>['chk-out']
373
,'all' =>['âñå']
374
,'auser' =>['Èñï-ëü', 'Èñïîëíèòåëü çàïèñè, ïîëüçîâàòåëü']
375
,'actor' =>['Èñï-ëü', 'Èñïîëíèòåëü çàïèñè, ïîëüçîâàòåëü']
376
,'arole' =>['Èñï-ëè', 'Ðîëü èëè ãðóïïà èñïîëíèòåëÿ çàïèñè, ëèáî äîáàâî÷íûé èñïîëíèòåëü']
377
,'actors' =>['Èñï-ëè', 'Èñïîëíèòåëè çàïèñè, ïîëüçîâàòåëè è ãðóïïû, ÷åðåç çàïÿòóþ']
378
,'puser' =>['Èíèö-ð', 'Èíèöèàòîð çàïèñè, ïîëüçîâàòåëü']
379
,'principal' =>['Èíèö-ð', 'Èíèöèàòîð çàïèñè, ïîëüçîâàòåëü']
380
,'prole' =>['Èíèö-ðû', 'Ðîëü èëè ãðóïïà èíèöèàòîðà çàïèñè, ëèáî äîáàâî÷íûé èíèöèàòîð']
381
,'principals' =>['Èíèö-ðû', 'Èíèöèàòîðû çàïèñè, ïîëüçîâàòåëè è ãðóïïû, ÷åðåç çàïÿòóþ']
382
,'manager' =>['Ìåíåäæåð', 'Óïðàâëÿþùèé çàïèñüþ, ïîëüçîâàòåëü']
383
,'muser' =>['Ìåíåäæåð', 'Óïðàâëÿþùèé çàïèñüþ, ïîëüçîâàòåëü']
384
,'mrole' =>['Ìåíåäæåðû', 'Ðîëü óïðàâëÿþùåãî çàïèñüþ, ãðóïïà èëè ïîëüçîâàòåëü']
385
,'managers' =>['Ìåíåäæåðû', 'Óïðàâëÿþùèå çàïèñüþ, ïîëüçîâàòåëè è ãðóïïû, ÷åðåç çàïÿòóþ']
386
,'owner' =>['Âëàäåëåö', 'Âëàäåëåö çàïèñè, ïîëüçîâàòåëü']
387
,'orole' =>['Âëàäåëüöû', 'Ðîëü èëè ãðóïïà âëàäåëüöà çàïèñè, ëèáî äîáàâî÷íûé âëàäåëåö']
388
,'owners' =>['Âëàäåëüöû', 'Âëàäåëüöû çàïèñè, ïîëüçîâàòåëè è ãðóïïû, ÷åðåç çàïÿòóþ']
389
,'user' =>['Ïîëüç', 'Ïîëüçîâàòåëü çàïèñè']
390
,'users' =>['Ïîëüç-ëè', 'Ïîëüçîâàòåëè çàïèñè, ïîëüçîâàòåëè è ãðóïïû, ÷åðåç çàïÿòóþ']
391
,'author' =>['Àâòîð', 'Àâòîð çàïèñè, ïîëüçîâàòåëü']
392
,'authors' =>['Àâòîðû', 'Àâòîðû çàïèñè, ïîëüçîâàòåëè è ãðóïïû, ÷åðåç çàïÿòóþ']
393
,'rrole' =>['×èòàòåëè', 'Ðîëü èëè ãðóïïà ÷èòàòåëåé çàïèñè']
394
,'readers' =>['×èòàòåëè', '×èòàòåëè çàïèñè, ïîëüçîâàòåëè è ãðóïïû, ÷åðåç çàïÿòóþ']
395
,'mailto' =>['ýÏî÷òîé', 'Ïîëó÷àòåëè ñîîáùåíèé ýëåêòðîííîé ïî÷òû îá ýòîé çàïèñè, ÷åðåç çàïÿòóþ']
396
,'record' =>['Çàïèñü', 'Êëàññ èëè òèï çàïèñåé']
397
,'object' =>['Îáúåêò', 'Îáúåêò èëè êëþ÷åâîå ñëîâî, ê êîòîðîìó îòíîñèòñÿ çàïèñü']
398
,'project' =>['Ïðîåêò', 'Íàïðàâëåíèå, îáúåêò, ïðîöåññ, ñòàòüÿ ðàñõîäîâ, ê êîòîðîé îòíîñèòñÿ çàïèñü']
399
,'cost' =>['Çàòðàòû', 'Çàòðàòû íà âûïîëíåíèå îïèñûâàåìîãî çàïèñüþ']
400
,'doctype' =>['Òèï äîê.', 'Òèï äîêóìåíòà, ñîäåðæàùåãîñÿ â çàïèñè']
401
,'subject' =>['Òåìà', 'Òåìà èëè çàãëàâèå çàïèñè']
402
,'comment' =>['Êîììåíò', "Òåêñò èëè HTML êîììåíòàðèÿ. Ãèïåðññûëêè ìîãóò áûòü íà÷àòû ñ 'urlh://' (êîìïüþòåð), 'urlr://' (ýòî ïðèëîæåíèå), 'urlf://' (ïðèñîåäèíåííûå ôàéëû), 'key://' (êëþ÷ çàïèñè èëè òàáëèöà${RISM1}êëþ÷), 'wikn://' (èìÿ çàïèñè); ìîãóò áûòü â ñêîáî÷íîé çàïèñè [[xxx://...]], [[xxx://...][label]], [[xxx://...|label]]. Íà÷àëî òåêñòà óñëîâèå ìîæåò èñïîëüçîâàòüñÿ äëÿ âñòðîåííîé âûáîðêè çàïèñåé"]
403
,'cargo' =>['Êàðãî', 'Äîïîëíèòåëüíûå äàííûå']
404
}
405
,'itf8enc_ru' => sub{my $i; $_[0] =~s/([^\x00-\x7f])/$i=ord($1); ($i >=192) ||($i ==168) ||($i ==184) ? (($i ==184) || ($i >=240) ? "\xD1" : "\xD0") .chr(($i ==168) ||($i ==184) ? $i -39 : $i >=240 ? $i -112 : $i -48) : " "/ge}
406
,'itf8dec_ru' => sub{my ($i,$j); $_[0] =~s/(\xD0[\x90-\xBF]|\xD1[\x80-\x8F]|\xD1\x91|\xD0\x81)/$i=substr($1,0,1); $j=ord(substr($1,1,1)); $i eq "\xD0" ? chr($j ==129 ? 168 : ($j +48)) : chr($j ==145 ? 184 : ($j +112))/ge}
407
};
408
409
$IMG={ # Images (from Apache)
410
'home' =>'portal.gif'
411
,'schpane' =>'folder.gif'
412
,'schframe' =>'folder.gif'
413
,'back' =>'back.gif'
414
,'login' =>'small/key.gif'
415
,'frmCall' =>'hand.up.gif'
416
,'frmHelp' =>'unknown.gif'
417
,'recNew' =>'generic.gif'
418
,'recRead' =>'up.gif'
419
,'recEdit' =>'quill.gif'
420
,'recPrint' =>'p.gif'
421
,'recXML' =>'script.gif'
422
,'recHist' =>'text.gif'
423
,'recIns' =>'burst.gif'
424
,'recUpd' =>'down.gif'
425
,'recDel' =>'broken.gif'
426
,'recForm' =>'forward.gif'
427
,'recList' =>'text.gif'
428
,'recQBF' =>'index.gif'
429
,'recQBFReset' =>'pie0.gif'
430
,'rfafolder' =>'folder.open.gif'
431
};
432
433
1;
434
435
436
437
#######################
438
439
440
sub new {
441
0
0
1
my $c=shift;
442
0
my $s;
443
0
0
if (ref($_[0]) eq 'DBIx::Web') {
444
0
$s =shift;
445
0
$s->DESTROY();
446
}
447
else {
448
0
0
0
shift if scalar(@_) && !defined($_[0])
0
449
&& (scalar(@_) > int(scalar(@_)/2)*2);
450
0
$s ={};
451
0
bless $s, $c;
452
}
453
0
$s =$s->initialize(@_);
454
}
455
456
457
458
sub initialize {
459
0
0
1
my $s =shift;
460
0
my %opt =@_;
461
0
$CACHE->{$s} ={};
462
0
0
$CACHE->{-new} =$CACHE->{-new} +1 if defined($CACHE->{-new});
463
0
0
$s->set(-env=>$opt{-env}) if $opt{-env};
464
465
0
0
0
%$s =(
466
# -env =>undef # Environment variables setup
467
-title =>'' # Application's title
468
# ,-locale =>'' # Application's locale
469
# ,-lang =>undef # Application's language
470
# ,-charset =>undef # Application's charset
471
# ,-lng =>'' # User's language
472
# ,-lnglbl =>'' # -lbl key
473
# ,-lngcmt =>'' # -cmt key
474
475
,-debug =>0 # Debug Mode
476
,-die =>$LNG->{-die} # die / croak / confess: &{$s->{-die} }('error')
477
# ,-diero =>undef # die runtime option inside cgiRun()
478
,-warn =>$LNG->{-warn} # warn / carp / cluck : &{$s->{-warn}}('warning')
479
,-ermu =>'' # err markip user
480
,-ermd =>'' # err markup delimiter
481
# ,-end0 =>undef # 'end' before trigger
482
,-endh =>{} # 'end' before hash
483
# ,-end1 =>undef # 'end' after trigger
484
485
# ,-var =>undef # Variables {}, see varLoad, varStore
486
,-log =>1 # Log file switch/handle, see logOpen
487
,-logm =>100 # Log list max size
488
489
,-c => { # Cache for computed values
490
# ,-startinit =>undef # Started by initialize
491
# ,-pth_tmp =>undef # Temporary files path, see pthForm('tmp')
492
# ,-pth_var =>undef # Variable files path, see pthForm('var')
493
# ,-pth_log =>undef # Log files path, see pthForm('log')
494
# ,-logm =>[] # Log list
495
# ,-user =>undef # User Name
496
# ,-unames =>[] # User Names
497
# ,-ugroups =>[] # User Groups
498
}
499
500
# ,-path =>'./dbix-web' # Path to file store, default below
501
# ,-url =>'/dbix-web' # URL to file store, default below
502
# ,-urf =>'file://./dbix-web'# Filesystem URL to file store, default below
503
504
505
,-host =>undef # Host Name, default below
506
# ,-dbi =>undef # DBI object, if used
507
# ,-dbiarg =>undef # DBI connection arguments string or array
508
# ,-dbidsn =>undef # DBI connection string from -dbiarg
509
# ,-dbiph =>undef # DBI placeholders ('?') dialect switch
510
# ,-dbiACLike =>undef # DBI ACL LIKE options: rlike regexp,...
511
# ,-dbiexpl =>undef # DBI explain switch: 0/1
512
# ,-cgi =>undef # CGI object
513
,-serial =>1 # Serialised: 1 - updates, 2 - updates & reads, 3 - reads
514
,-keyqn =>1 # query key ''/undef compatibility
515
# ,-output =>undef # output sub{} instead of 'print'
516
517
,-table =>{} # database files
518
# -field=>[name=>{}]
519
# -mdefld=>{name=>{}}
520
# -key =>[field]
521
# -keycmp=>sub{} # key compare dbm sub{}
522
# -ixcnd=>sub{}||1 # index condition
523
# -ixrec=>sub{} # form index record
524
# -optrec # optional records
525
# -dbd =>'dbi'|'dbm' # database store
526
# -recXXX # trigger or implementation
527
528
# -subst # substitute another
529
# -cgcXXX=>''|sub{} # cgi call implementation
530
# -cgvXXX=>''|sub{} # cgi call presentation
531
532
# -frmLso # form query option
533
# -query # query condition hash
534
# -qfilter # filters rows fetched
535
# -qhref # query hyperlink hash or sub{}
536
# -qhrcol # q h left columns
537
# -qflghtml # !empty flag when '!h'
538
# -qfetch # query fetch sub{}
539
# -limit # query limit rows
540
541
# -recRead # recRead condition hash
542
543
# ,-user =>undef # User Name sub{} or value, default below
544
,-userln =>1 # User local short names switch
545
# ,-usernt =>undef # User syntax alike WinNT
546
# ,-udisp =>undef # User display group comments '-ug<>dc' or boolean
547
# ,-udispq =>undef # User display quick always
548
# ,-unames =>[] # User Names sub{} or value
549
# ,-ugroups =>[] # User Groups sub{} or value
550
# ,-udflt =>sub{} # User Domains filter
551
# ,-unflt =>sub{} # User Names filter
552
# ,-ugflt =>sub{} # User Groups filter
553
# ,-AuthUserFile # Apache Users file, optional
554
# ,-AuthGroupFile # Apache Groups file, optional
555
# ,-w32ldap =>[[win=>ldap]] # Windows ADSI LDAP users/groups store
556
# ,-ldap =>''||[]||{} # LDAP constructor arguments, LDAP usage option
557
# ,-ldapsrv =>''||[]||{} # LDAP constructor arguments
558
# ,-ldapbind =>''||[]||{} # LDAP bind arguments (version => 3)
559
# ,-ldapsearch =>{} # LDAP search defaults and basic filter
560
# ,-ldapfu =>'' # LDAP users filter
561
# ,-ldapfg =>'' # LDAP groups filter
562
,-ldapattr =>['uid','cn'] # LDAP internal and external names
563
# ,-fswtr =>undef # File Store Writers, defaults in code
564
# ,-fsrdr =>undef # File Store Readers
565
,-w32IISdpsn =>($ENV{SERVER_SOFTWARE}||'') =~/IIS/ ? 1 : 0 # MsIIS deimpersonation
566
# ,-w32xcacls =>undef # Use WinNT 'xcacls' instead of 'cacls'
567
568
# ,&recXXX # DML command keywords
569
# -table -form || record form class
570
# -from -join[01]
571
# -data
572
# -key -where
573
# -urole -uname
574
# -ftext -version
575
# -filter -limit
576
# -order -keyord -group
577
# -save -optrec -test -sel
578
# DML record attributes
579
# -new -file -fupd -editable
580
581
# Record Manipulation Options:
582
# ,-dbd =>undef # default database engine
583
,-autocommit =>1 # autocommit database mode
584
# ,-limit =>undef||number # limit of selection
585
# ,-affect =>undef||1 # rows number to affect by DML
586
# ,-affected # rows number affected by DML
587
# ,-fetched # rows number fetched by DBL
588
# ,-limited # rows number limited by DBL
589
# ,-index =>boolean # include materialized views support
590
,-idsplit =>1 # split complex rec ID to table and row ID: 0 || sub{}
591
,-wikn => # wikiname fields possible
592
['name','subject']
593
# ,-wikq =>undef # wikiquery filter sub{} for recWikn()
594
595
# Record Access Control rooles:
596
,-rac =>1 # switch on
597
,-racAdmWtr =>'Administrators,root'
598
,-racAdmRdr =>'Administrators,root'
599
# ,-racReader =>[fieldnames] # readers fieldnames
600
# ,-racWriter =>[fieldnames] # writers fieldnames
601
602
# Record Version Control rooles:
603
# ,-rvcInsBy =>'fieldname' # field for user name record inserted by
604
# ,-rvcInsWhen =>'fieldname' # field for time record inserted when
605
# ,-rvcUpdBy =>'fieldname' # field for user name record updated by
606
# ,-rvcUpdWhen =>'fieldname' # field for time record updated when
607
# ,-rvcVerWhen =>'fieldname' # field for time version created when
608
# ,-rvcActPtr =>'fieldname' # field for actual record version pointer
609
# ,-rvcChgState=>[fld=>states] # changeble states of record
610
# ,-rvcCkoState=>[fld=>state ] # check-out state of record
611
# ,-rvcDelState=>[fld=>state ] # deleted state of record
612
613
# Record File Attachments rooles:
614
,-rfa =>1 # switch on
615
# ,-rfdName =>sub{} # 'rfdName' formula for key processing
616
617
# Record ID References
618
# ,-ridRef =>[] # reference fields
619
620
# Record Manipulation Triggers:
621
# ,-recTrim0A =>sub{} # 'recTrim' trigger before UI action
622
# ,-recForm =>'form'|sub{} # 'recForm' UI implementation
623
# ,-recForm0A =>sub{} # 'recForm' trigger before UI action
624
# ,-recForm0C =>sub{} # 'recForm' trigger before command
625
# ,-recForm0R =>sub{} # 'recForm' trigger before row
626
# ,-recFlim0R =>sub{} # 'recForm' limiter before row
627
# ,-recForm1C =>sub{} # 'recForm' trigger after command
628
# ,-recForm1A =>sub{} # 'recForm' trigger after UI action
629
# ,-recEdt0A =>sub() # 'recEdt' trigger before UI action
630
# ,-recEdt0R =>sub() # 'recEdt' trigger before row
631
# ,-recChg0R =>sub() # 'recChg' trigger before row
632
# ,-recChg0W =>sub() # 'recChg' trigger before write (and -recInsID)
633
# ,-recEdt1A =>sub() # 'recEdt' trigger after UI action
634
# ,-recNew =>'form'|sub{} # 'recNew' UI implementation
635
# ,-recNew0C =>sub{} # 'recNew' trigger before command
636
# ,-recNew0R =>sub{} # 'recNew' trigger before row
637
# ,-recNew1C =>sub{} # 'recNew' trigger after command
638
# ,-recIns =>'form'|sub{} # 'recIns' UI implementation
639
# ,-recIns0C =>sub{} # 'recIns' trigger before row command
640
# ,-recIns0R =>sub{} # 'recIns' trigger before row
641
# ,-recInsID =>sub{} # 'recIns' trigger for key generation
642
# ,-recIns1R =>sub{} # 'recIns' trigger after row
643
# ,-recIns1C =>sub{} # 'recIns' trigger after row command
644
# ,-recUpd =>'form'|sub{} # 'recUpd' UI implementation
645
# ,-recUpd0C =>sub{} # 'recUpd' trigger before command
646
# ,-recUpd0R =>sub{} # 'recUpd' trigger before each row
647
# ,-recUpd1C =>sub{} # 'recUpd' trigger after command
648
# ,-recDel =>'form'|sub{} # 'recDel' UI implementation
649
# ,-recDel0C =>sub{} # 'recDel' trigger before command
650
# ,-recDel0R =>sub{} # 'recDel' trigger before each row
651
# ,-recDel1C =>sub{} # 'recDel' trigger after command
652
# ,-recSel0C =>sub{} # 'recSel' trigger before command
653
# ,-recRead =>'form'|sub{} # 'recRead' UI implementation
654
# ,-recRead0C =>sub{} # 'recRead' trigger before row command
655
# ,-recRead0R =>sub{} # 'recRead' trigger before row command
656
# ,-recRead1R =>sub{} # 'recRead' trigger after row command
657
# ,-recRead1C =>sub{} # 'recRead' trigger after row command
658
# ,-recList =>'form'|sub{} # 'recList' UI implementation
659
660
,-tn =>{ # Template naming, see also 'ns' sub
661
'' =>''
662
,-guest =>'guest' # guest user name
663
,-guests =>'guests' # guest user group
664
,-users =>'users' # authenticated user default group
665
,-dbd =>'dbm' # defaultest data engine
666
667
,-id =>'id' # record identifier
668
,-key =>['id'] # record key
669
,-rvcInsBy =>'cuser' # user, record inserted by
670
,-rvcInsWhen =>'ctime' # time, record inserted when
671
,-rvcUpdBy =>'uuser' # user, record updated by
672
,-rvcUpdWhen =>'utime' # time, record updated when
673
,-rvcVerWhen =>'vtime' # time, version created when
674
# 'auser' # actor user
675
# 'arole' # actor roles
676
# 'puser' # principal user
677
# 'prole' # principal roles
678
,-rvcActPtr =>'idnv' # id of new version of record
679
# 'idrm' # id of master record
680
# 'idrr' # id of root reference
681
# 'idpr' # id of previous record in cause chain
682
# 'idpt' # point to record
683
# 'idlr' # location record pointer
684
,-rvcState =>'status' # state of record
685
,-rvcAllState =>['ok','no','do','progress','delay','chk-out','edit','deleted']
686
,-rvcFinState =>['status'=>'ok','no','deleted']
687
,-rvcChgState =>['status'=>'edit','chk-out']
688
,-rvcCkoState =>['status'=>'chk-out']
689
,-rvcDelState =>['status'=>'deleted']
690
,-ridSubject =>[qw(record object subject)] # subject fields | sub{}
691
,'tvmVersions' =>'versions' # versions view name
692
,'tvmHistory' =>'history' # history view name
693
,'tvmReferences'=>'references' # references view name
694
,'tvdIndex' =>'index' # index view name
695
,'tvdFTQuery' =>'fulltext' # full-text view name
696
}
697
# CGI server user interface
698
# ,-httpheader =>{}
699
# ,-htmlstart =>{}
700
,-icons =>'/icons' # Icons URL
701
# ,-logo =>'' # Logotype to display
702
# ,-search =>'' # '_search' frame URL
703
,-login =>'/cgi-bin/ntlm/'# Login URL
704
# ,-menuchs =>[[]]
705
# ,-menuchs1 =>[[]]
706
# ,-form =>{} # user interface forms, see '-table'
707
# ,-pcmd =>{} # command input parameters
708
# ,-pdta =>{} # data input
709
# ,-pout =>{} # parameters output (cursor)
710
);
711
712
0
0
0
if (!$opt{-path}
0
713
|| ($opt{-path} =~/^(?:DocumentRoot|-DocumentRoot)$/i)) {
714
0
0
my $pth =$^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0;
715
0
0
0
$pth = $ENV{DOCUMENT_ROOT}
0
0
0
0
0
0
0
0
716
? $ENV{DOCUMENT_ROOT} .'/'
717
: $pth =~/^(.+?[\\\/]wwwroot[\\\/])/i
718
? $1
719
: $pth =~/^(.+?[\\\/]inetpub[\\\/])/i
720
? $1
721
: $pth =~/^(.+?[\\\/])cgi-bin[\\\/]/i && -d ($1 .'htdocs')
722
? $1 .'htdocs/'
723
: $pth =~/^(.+?[\\\/]apache[\\\/])/i && -d ($1 .'htdocs')
724
? $1 .'htdocs/'
725
: $pth =~/^(.+[\\\/])[^\\\/]*$/
726
? $1
727
: -d '../htdocs'
728
? '../htdocs/'
729
: -d '../wwwroot'
730
? '../wwwroot/'
731
: './';
732
0
$opt{-path} =$pth .'dbix-web';
733
}
734
elsif ($opt{-path} =~/^(?:ServerRoot|-ServerRoot|-path)$/i) {
735
0
0
my $pth =$^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0;
736
0
0
0
$pth = ($^O eq 'MSWin32') && ($pth =~/^(.+?[\\\/]inetpub[\\\/])/i)
0
0
0
0
0
0
0
0
0
737
? $1
738
: $ENV{DOCUMENT_ROOT} && ($ENV{DOCUMENT_ROOT} =~/^(.+[\\\/])[^\\\/]*$/)
739
? $1
740
: $pth =~/^(.+?[\\\/])cgi-bin[\\\/]/i && -d ($1 .'htdocs')
741
? $1 .'/'
742
: $pth =~/^(.+?[\\\/]apache[\\\/])/i && -d ($1 .'htdocs')
743
? $1 .'/'
744
: $pth =~/^(.+[\\\/])[^\\\/]*$/
745
? $1
746
: -d '../htdocs'
747
? '../'
748
: -d '../wwwroot'
749
? '../'
750
: './';
751
0
$opt{-path} =$pth .'dbix-web';
752
}
753
0
$RISM2 ='.rfd'; # for set(-cgibus)
754
755
0
$s->set(%opt);
756
757
0
0
$s->{-url} =cgibus($s) ? '/cgi-bus' : '/dbix-web'
0
758
if !$s->{-url};
759
0
0
$s->set(-locale=>POSIX::setlocale(&POSIX::LC_CTYPE()))
760
if !$s->{-locale};
761
0
0
0
$s->set(-die=>($ENV{GATEWAY_INTERFACE}||'') =~/CGI/ ? 'CGI::Carp qw(fatalsToBrowser warningsToBrowser)' : 'Carp')
0
762
if !$opt{-die};
763
0
0
0
$s->set(-host=>
0
764
($ENV{COMPUTERNAME}||$ENV{HOSTNAME}||eval('use Sys::Hostname;hostname')||'localhost')
765
=~/^([\d.]+|[\w\d_]+)/ ? $1 : 'unknown'
766
)
767
if !$s->{-host};
768
0
0
0
0
$s->set(-user=>sub{$ENV{REMOTE_USER}||$ENV{USERNAME}||$_[0]->{-tn}->{-guest}})
769
0
0
if !$s->{-user};
770
$s->set(-recTrim0A=>sub{ # $self, {command}, {data}
771
0
0
foreach my $k (keys %{$_[2]}) {
0
772
0
0
next if !defined($_[2]->{$k});
773
0
0
if ($_[2]->{$k} =~/^\s+/) {$_[2]->{$k} =$'}
0
774
0
0
if ($_[2]->{$k} =~/\s+$/) {$_[2]->{$k} =$`}
0
775
}
776
0
$_[2]})
777
0
0
if !$s->{-recTrim0A};
778
$s->set(-recInsID=>sub{
779
# !!! database lookup may be better and faster,
780
# but appropriate insulation level may be needed
781
0
0
$_[0]->varLock();
782
0
$_[2]->{'id'} =lc($_[0]->{-host})
783
.strpad($_[0],$_[0]->{-var}->{-table}->{$_[1]->{-table}}->{-recInsID}
784
=dwnext($_[0],$_[0]->{-var}->{-table}->{$_[1]->{-table}}->{-recInsID}));
785
0
$_[0]->varStore();
786
0
$_[2]->{'id'}})
787
0
0
if !$s->{-recInsID};
788
0
0
0
if ($ENV{MOD_PERL_API_VERSION}
0
789
&& ($ENV{MOD_PERL_API_VERSION} >=2)) {
790
# Apache2::ServerUtil->server->push_handlers("PerlCleanupHandler"
791
# ,sub{eval{$s->end}; eval('Apache2::Const::DECLINED;')});
792
}
793
elsif ($ENV{MOD_PERL}) {
794
0
Apache->push_handlers("PerlCleanupHandler"
795
0
0
,sub{eval{$s->end}; eval('Apache::DECLINED;')});
0
0
796
}
797
0
0
$ENV{TMP} =$ENV{TEMP} =$ENV{TMP}||$ENV{tmp}||$ENV{TEMP}||$ENV{temp}
798
||$ENV{TMPDIR} # see CGI.pm source
799
||$s->pthForm('tmp');
800
0
$s->{-c}->{-startinit} =1;
801
0
$s
802
}
803
804
805
sub class {
806
0
0
1
substr($_[0], 0, index($_[0],'='))
807
}
808
809
810
sub set {
811
0
0
0
1
return(keys(%{$_[0]})) if scalar(@_) ==1;
0
812
0
0
return($_[0]->{$_[1]}) if scalar(@_) ==2;
813
0
my ($s, %opt) =@_;
814
0
foreach my $k (keys(%opt)) {
815
0
$s->{$k} =$opt{$k};
816
}
817
0
0
if ($opt{-env}) {
818
0
0
my $env =$s->{-env} =ref($opt{-env}) eq 'CODE' ? &{$opt{-env}}(@_) : $opt{-env};
0
819
0
0
if (ref($env) eq 'HASH') {
820
0
foreach my $k (keys %$env) {
821
0
0
if (defined($env->{$k})){$ENV{$k} =$env->{$k}}
0
0
822
else {delete($ENV{$k})}
823
}
824
}
825
}
826
0
0
if ($opt{-die}) {
827
0
my ($s, $he, $hw) =($_[0]);
828
0
0
if (ref($opt{-die})) {}
0
0
829
elsif ($opt{-die} =~/^(perl|core)$/i) {
830
0
$s->{-warn} =$LNG->{-warn}; $s->{-die} =$LNG->{-die};
0
831
}
832
elsif ($opt{-die}) {
833
0
0
my $m =($s->{-die} =~/^([^\s]+)\s*/ ? $1 : $s->{-die}) .'::';
834
0
($he, $hw) =($SIG{__DIE__}, $SIG{__WARN__});
835
0
0
$s->{-warn} =eval('use ' .$s->{-die} .';\\&' .$m .($s->{-debug} ?'cluck' :'carp' ));
836
0
0
$s->{-die} =eval('use ' .$s->{-die} .';\\&' .$m .($s->{-debug} ?'confess' :'croak'));
837
0
0
0
$he =($he ||'') ne ($SIG{__DIE__}||'') ? $SIG{__DIE__} : undef;
0
838
0
0
0
$hw =($hw ||'') ne ($SIG{__WARN__}||'') ? $SIG{__WARN__} : undef;
0
839
}
840
0
0
0
$SIG{__DIE__} =sub{ return if ineval();
841
0
my $s =$SELF;
842
0
0
$s =undef if !isa($s, 'DBIx::Web');
843
0
0
$s && eval{$s->logRec('Die', ($_[0] =~/(.+)[\n\r]+$/ ? $1 : $_[0]))};
0
0
844
0
0
$s && eval{$s->recRollback()};
0
845
0
0
ref($he) && &$he};
0
846
0
0
0
$SIG{__WARN__} =sub{ return if ineval();
847
0
my $s =$SELF;
848
0
0
$s =undef if !isa($s, 'DBIx::Web');
849
0
0
$s && eval{$s->logRec('Warn',($_[0] =~/(.+)[\n\r]+$/ ? $1 : $_[0]))};
0
0
850
0
0
ref($hw) && &$hw};
0
851
}
852
0
0
if (exists $opt{-locale}) {
853
0
$s->{-lng} ='';
854
0
$s->{-lnglbl} ='';
855
0
$s->{-lngcmt} ='';
856
0
0
$s->{-lang} =lc($opt{-locale} =~/^(\w\w)/ ? $1 : 'en');
857
0
0
$s->{-charset} =$opt{-locale} =~/\.(.+)$/ ? $1 : '1252';
858
}
859
0
0
if (exists $opt{-lng}) {
860
0
$s->{-lng} =lc($s->{-lng});
861
0
0
$s->{-lnglbl} =$s->{-lng} ? '-lbl' .'_' .$s->{-lng} : '';
862
0
0
$s->{-lngcmt} =$s->{-lng} ? '-cmt' .'_' .$s->{-lng} : '';
863
}
864
0
0
if (exists $opt{-autocommit}) {
865
0
0
$s->{-dbi}->{AutoCommit} =$opt{-autocommit} if $s->{-dbi};
866
}
867
0
0
0
if ($opt{-cgibus} && !ref($opt{-cgibus})) {
868
$s->{-recInsID} =sub{ # recIns() row ID generation trigger
869
# cgi-bus 'gwo.cgi'
870
0
0
0
$_[2]->{'id'} =($_[0]->user =~/^([^@]+)@(.+)$/
871
? $2 .'\\' .$1
872
: $_[0]->user)
873
0
.'/' .$_[0]->strtime('yyyymmddhhmmss')};
874
$s->{-rfdName} =sub{ # convert record's key into directory name
875
# cgi-bus 'gwo.cgi', '-ksplit, tmsql::fsname()
876
# 'rfdName()'/'-rfdName'
877
0
0
local $_ =$_[1];
878
0
my $r ='';
879
0
0
return($r) if !$_;
880
0
while ($_ =~/([\\\/])/) {
881
0
$_ =$';
882
0
my $v =$` .$1; $v =~s/([^a-zA-Z0-9])/uc sprintf("_%02x",ord($1))/eg;
0
0
883
0
$r .=$v .'/'
884
};
885
$r .= join('/'
886
0
0
0
,map { if (defined($_) && $_ ne '') {
0
0
887
0
my $v =$_;
888
0
$v =~s/([^a-zA-Z0-9])/uc sprintf("_%02x",ord($1))/eg;
0
889
0
$v
890
}
891
else {return()}
892
} substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,8,2),substr($_,10));
893
0
$r
894
0
};
895
0
$RISM2 ='$'; # record identification end special mark
896
# tmsql 'sub fsname'
897
# rmlIdSplit() / -idsplit, cgiForm(), ui...
898
}
899
0
0
0
if ($opt{-urf} && (ref($opt{-urf}) eq 'CODE')) {
900
0
$s->{-urf} =$opt{-urf}= &{$opt{-urf}}($s);
0
901
}
902
0
0
0
if ($opt{-urf} && (substr($opt{-urf},0,1) eq '-')) {
903
0
0
0
$s->{-urf} = $opt{-urf} ne '-path'
0
904
? $s->{$opt{-urf}}
905
: $s->{-cgibus} && cgibus($s)
906
?('file://' .cgibus($s))
907
:('file://' .$s->{$opt{-urf}})
908
}
909
$s
910
0
}
911
912
913
sub lng {
914
0
0
0
1
my $l =$LNG->{$_[0]->{-lng}} || $LNG->{''};
915
0
my $m;
916
0
@_ <3
917
? ($m =$l->{$_[1]} ||$LNG->{''}->{$_[1]}) && ($m->[0] ||$m->[1]) ||$_[1]
918
: @_ <4
919
? ( (($m =$l->{$_[2]} ||$l->{'-' .$_[2]}) && $m->[$_[1]])
920
|| (($m =$LNG->{''}->{$_[2]} ||$LNG->{''}->{'-' .$_[2]}) && $m->[$_[1]])
921
|| $_[2])
922
0
0
0
: eval {my $r =lng(@_[0..2]);
0
0
923
0
0
my $v =!ref($_[3]) ? $_[3] : ref($_[3]) eq 'CODE' ? &{$_[3]}(@_) : strdata($_[0], $_[3]);
0
0
924
0
0
$v ='undef' if !defined($v);
925
0
0
$r =~s/\$_/$v/ge ? $r : "$r $v"
0
926
}
927
}
928
929
930
sub lang {
931
0
0
0
0
my $l =$LNG->{$_[0]->{-lang}} || $LNG->{''};
932
0
my $m;
933
0
@_ <3
934
? ($m =$l->{$_[1]} ||$LNG->{''}->{$_[1]}) && ($m->[0] ||$m->[1]) ||$_[1]
935
: @_ <4
936
? ( (($m =$l->{$_[2]} ||$l->{'-' .$_[2]}) && $m->[$_[1]])
937
|| (($m =$LNG->{''}->{$_[2]} ||$LNG->{''}->{'-' .$_[2]}) && $m->[$_[1]])
938
|| $_[2])
939
0
0
0
: eval {my $r =lng(@_[0..2]);
0
0
940
0
0
my $v =!ref($_[3]) ? $_[3] : ref($_[3]) eq 'CODE' ? &{$_[3]}(@_) : strdata($_[0], $_[3]);
0
0
941
0
0
$v ='undef' if !defined($v);
942
0
0
$r =~s/\$_/$v/ge ? $r : "$r $v"
0
943
}
944
}
945
946
947
sub lnghash { # locale hash (self, index, array)
948
0
return $_[2]
949
0
? { map {($_, lng($_[0],$_[1],$_))
950
0
0
0
0
1
} ref($_[2]) eq 'ARRAY' ? @{$_[2]} : ()}
0
951
: ($LNG->{$_[0]->{-lng}} || $LNG->{''})
952
}
953
954
955
sub lngslot { # localised slot (self, object, keyname)
956
0
0
0
0
$_[1]->{$_[2] .'_' .$_[0]->{-lng}} || $_[1]->{$_[2]}
957
}
958
959
960
sub lnglbl { # localised label (self, object,...)
961
0
0
0
foreach my $e (@_[1..$#_]) {
962
0
0
next if !ref($e);
963
0
0
my $v =$e->{$_[0]->{-lnglbl}} || $e->{-lbl};
964
0
0
next if !$v;
965
0
0
return(ref($v) ? &$v(@_) : $v)
966
}
967
0
0
0
!ref($_[$#_]) && $_[1]->{$_[$#_]} ? lng($_[0],0,$_[1]->{$_[$#_]}) : ''
968
}
969
970
971
sub lngcmt { # localised comment (self, object,...)
972
0
0
0
foreach my $e (@_[1..$#_]) {
973
0
0
next if !ref($e);
974
0
0
my $v =$e->{$_[0]->{-lngcmt}} || $e->{-cmt} || $e->{$_[0]->{-lnglbl}} || $e->{-lbl};
975
0
0
next if !$v;
976
0
0
return(ref($v) ? &$v(@_) : $v)
977
}
978
0
0
0
!ref($_[$#_]) && $_[1]->{$_[$#_]} ? lng($_[0],1,$_[1]->{$_[$#_]}) : ''
979
}
980
981
982
sub charset { # character set name, as for web
983
0
0
0
0
return($LNG->{''}->{-charset}->[0]) if !$_[0]->{-charset};
984
0
0
$_[0]->{-charset} =~/^\d/ ? 'windows-' .$_[0]->{-charset} : $_[0]->{-charset}
985
}
986
987
988
sub charpage { # character page name, as for Encode
989
0
0
0
0
charset($_[0]) =~/^windows-(\d+)/ ? "cp$1" : charset($_[0]);
990
}
991
992
sub ineval { # is inside eval{}?
993
# for PerlEx and mod_perl
994
# see CGI::Carp::ineval comments and errors
995
0
0
0
0
0
return $^S if !($ENV{GATEWAY_INTERFACE}
0
996
&& ($ENV{GATEWAY_INTERFACE} =~/PerlEx/))
997
&& !$ENV{MOD_PERL};
998
0
my ($i, @a) =(1);
999
0
while (@a =caller($i)) {
1000
# $_[0] && $_[0]->logRec('ineval',$i,$a[0],$a[1],$a[2],$a[3]);
1001
0
0
return(0) if $a[0] =~/^(?:PerlEx::|Apache::Perl|Apache::Registry|Apache::ROOT|ModPerl::ROOT|ModPerl::RegistryCoker)/i;
1002
0
0
return(1) if $a[3] eq '(eval)';
1003
0
$i +=1;
1004
}
1005
}
1006
1007
1008
sub die {
1009
0
0
0
0
1
&{$_[0]->{-die}}($_[0]->{-ermu}
0
1010
.(($#_ <2) && ($_[1] !~/[\r\n]$/)
1011
? ($_[1] .$_[0]->{-ermd})
1012
: join('',@_[1..$#_])))
1013
}
1014
1015
1016
sub warn {
1017
0
0
1
&{$_[0]->{-warn}}(@_[1..$#_])
0
1018
}
1019
1020
1021
sub diags { # Health and Inspector
1022
0
0
0
my ($s, $o) =@_; # (-html,all,perl,env,cgi,cgiparam)
1023
0
0
$o ='-' if !$o;
1024
0
0
$CACHE->{-new} =1 if !defined($CACHE->{-new});
1025
0
0
$CACHE->{-destroy} =0 if !defined($CACHE->{-destroy});
1026
0
my $r ='***HEALTH: ';
1027
0
my ($rs, $rc, $rp) =(undef, 0, '');
1028
0
0
0
0
$rs =sub{ if (!$_[0] ||!ref($_[0]) ||(ref($_[0]) eq 'CODE')) {}
0
0
0
0
0
1029
elsif (ref($_[0]) && ($_[0]=~/hash/i)) {
1030
0
0
0
if (($_[0] eq $s) && $_[1]) {
1031
0
$rc +=1; $rp .=$_[1] .';';
0
1032
0
return(0)
1033
}
1034
0
foreach my $k (keys %{$_[0]}) {
0
1035
0
0
0
&$rs($_[0]->{$k}, ($_[1] || '') ."{$k}") if ref($_[0]->{$k})
1036
}
1037
}
1038
elsif (ref($_[0]) && ($_[0]=~/array/i)) {
1039
0
for(my $i=0; $i <=$#{$_[0]}; $i++) {
0
1040
0
0
0
&$rs($_[0]->[$i], ($_[1] || '') ."[$i]") if ref($_[0]->[$i])
1041
}
1042
0
}};
1043
0
&$rs($s, '');
1044
0
0
$r .=($CACHE->{-new} ? 'new=' .$CACHE->{-new} .' ' : '')
0
0
1045
.($CACHE->{-destroy} ? 'DESTROY=' .$CACHE->{-destroy} .' ' : '')
1046
.($rc ? 'self recurse=' .$rp .' ' : '')
1047
.getlogin();
1048
1049
0
0
$r .="\n===Perl: \$^X=$^X; \$]=$]; \@INC=" .join(', ', map{"'$_'"} @INC) .'; getlogin=' .getlogin()
0
1050
if ($o =~/\b(?:perl|all)\b/i);
1051
0
0
$r .="\n===\%ENV: " .join(', ', map {"$_=" .(defined($ENV{$_}) ? "'" .$ENV{$_} ."'" : 'undef')
0
0
1052
} qw(SERVER_SOFTWARE SERVER_PROTOCOL DOCUMENT_ROOT GATEWAY_INTERFACE MOD_PERL PERLXS PERL_SEND_HEADER REMOTE_USER TMP TEMP SCRIPT_NAME PATH_INFO PATH_TRANSLATED REQUEST_METHOD REQUEST_URI QUERY_STRING REDIRECT_QUERY_STRING CONTENT_TYPE CONTENT_LENGTH))
1053
if ($o =~/\b(?:env|all)\b/i);
1054
0
$r .="\n===CGI: " .join(', '
1055
0
0
,(map { my $v =eval("\$CGI::$_");
1056
0
0
("\$$_=" .(defined($v) ? "'$v'" : 'undef'))
1057
} qw (VERSION TAINTED MOD_PERL PERLEX XHTML NOSTICKY NPH PRIVATE_TEMPFILES TABINDEX CLOSE_UPLOAD_FILES POST_MAX HEADERS_ONCE USE_PARAM_SEMICOLONS))
1058
0
0
0
,(map { my $v =$s->url(!$_ ? () : ($_=>1));
0
1059
0
0
0
(($_||'%url') .'=' .(defined($v) ? "'$v'" : 'undef'))
1060
} '', qw(-absolute -relative -base))
1061
,'-self_url=' .($s->cgi->self_url()||'')
1062
)
1063
if $s->{-cgi} && ($o =~/\b(?:cgi|all)\b/i);
1064
0
0
$r .="\n===CGI param: " .join(', '
1065
0
0
0
,map {("$_=" .(defined($s->cgi->param($_)) ? "'" .$s->cgi->param($_) ."'" : 'undef'))
1066
} $s->cgi->param
1067
)
1068
if $s->{-cgi} && ($o =~/\b(?:cgiparam|all)\b/i);
1069
0
0
$o =~/\b(?:html)\b/i
1070
? join(" ", split /[\r\n]/, $s->htmlEscape($r))
1071
: $r
1072
}
1073
1074
1075
sub cgibus { # (self, set) -> is cgi-bus mode?
1076
0
0
0
0
return($_[0]->{-cgibus}) if !ref($_[0]->{-cgibus});
1077
0
local $_;
1078
0
0
$_ =&{$_[0]->{-cgibus}}($_[0]
0
1079
, $_ =$_[0]->{-pcmd} && ($_[0]->{-pcmd}->{-table} || $_[0]->{-pcmd}->{-form})
1080
|| $_[0]->cgi->param('_table') || $_[0]->cgi->param('_form') || $_[0]->cgi->param('_key')
1081
|| 'default'
1082
, $_[1]);
1083
0
0
$_[0]->set(-cgibus=>$_) if $_[1];
1084
0
$_
1085
}
1086
1087
1088
sub start { # start session
1089
0
0
1
my $s =shift;
1090
0
my %o =@_;
1091
0
0
if (!$s->{-c}->{-startinit}) {
1092
0
$CACHE->{$s} ={};
1093
0
$s->{-c} ={};
1094
}
1095
0
delete $s->{-c}->{-startinit};
1096
0
$s->{-fetched} =0;
1097
0
$s->{-limited} =0;
1098
0
$s->{-affected}=0;
1099
0
0
0
$s->{-var}->{'_handle'}->destroy if $s->{-var} && $s->{-var}->{'_handle'};
1100
0
0
0
$s->w32IISdpsn() if (($ENV{SERVER_SOFTWARE}||'') =~/IIS/)
0
0
0
0
1101
&& ((defined($s->{-w32IISdpsn})
1102
? $s->{-w32IISdpsn} ||0
1103
: 2) >1)
1104
&& !$s->cgi->param('_qftwhere');
1105
0
0
0
unless ((($ENV{SERVER_SOFTWARE}||'') =~/IIS/)
0
1106
&& $s->cgi->param('_qftwhere')) {
1107
0
0
$s->varLoad(!$s->{-serial} ? 0 : $s->{-serial} >2 ? LOCK_EX : $s->{-serial} >1 ? LOCK_SH : $s->{-serial} >0 ? LOCK_SH : 0);
0
0
0
1108
0
0
0
$s->logOpen() if $s->{-log} && !ref($s->{-log});
1109
0
0
$s->{-log}->lock(0) if ref($s->{-log});
1110
}
1111
0
$s->set(@_);
1112
0
$s
1113
}
1114
1115
1116
sub end { # end session
1117
0
0
1
my $s =shift;
1118
0
$s->logRec('end');
1119
0
0
&{$s->{-end0}}($s) if $s->{-end0};
0
1120
0
0
if ($s->{-dbi}) {
1121
# $s->recCommit();
1122
0
eval{$s->{-dbi}->disconect};
0
1123
0
$s->{-dbi} =undef;
1124
}
1125
0
0
if ($s->{-cgi}) {
1126
0
eval{$s->{-cgi}->DESTROY()};
0
1127
0
$s->{-cgi} =undef;
1128
0
$CGI::Q =undef;
1129
}
1130
0
foreach my $k (sort keys %{$s->{-endh}}) {eval{&{$s->{-endh}->{$k}}($s)}};
0
0
0
0
1131
0
$s->{-endh} ={};
1132
0
0
$s->smtp(undef) if $s->{-smtp};
1133
0
0
0
if ($s->{-var} && $s->{-var}->{'_handle'}) {
1134
0
$s->{-var}->{'_handle'}->destroy;
1135
0
delete $s->{-var}->{'_handle'};
1136
}
1137
0
0
if (ref($s->{-log})) {
1138
0
$s->{-log}->destroy;
1139
0
$s->{-log} =undef;
1140
}
1141
0
0
eval{$s->{-c}->{-ldap}->unbind} if $s->{-c}->{-ldap};
0
1142
0
$s->{-c} ={};
1143
0
$CACHE->{$s} ={};
1144
0
0
&{$s->{-end1}}($s) if $s->{-end1};
0
1145
0
$s
1146
}
1147
1148
1149
sub DESTROY {
1150
0
0
my $s =shift;
1151
0
0
0
$CACHE->{-destroy} =($CACHE->{-destroy} ||0) +1
1152
if defined($CACHE->{-new});
1153
0
0
if ($s->{-cgi}) {
1154
0
eval{$s->{-cgi}->DESTROY()};
0
1155
0
delete $s->{-cgi};
1156
0
$CGI::Q =undef;
1157
}
1158
0
$s->{-endh} =undef;
1159
0
0
$s->smtp(undef) if $s->{-smtp};
1160
0
0
0
if ($s->{-var} && $s->{-var}->{'_handle'}) {
1161
0
eval{$s->{-var}->{'_handle'}->destroy};
0
1162
0
delete $s->{-var}->{'_handle'};
1163
}
1164
0
0
if (ref($s->{-log})) {
1165
0
eval{$s->{-log}->destroy};
0
1166
0
$s->{-log} =undef;
1167
}
1168
0
0
eval{$s->{-c}->{-ldap}->unbind} if $s->{-c}->{-ldap};
0
1169
0
$s->{-c} =undef;
1170
0
delete $CACHE->{$s};
1171
0
$s
1172
}
1173
1174
1175
sub setup { # Setup script execution
1176
0
0
1
my ($s) =@_;
1177
1178
0
print "Writing sample '.htaccess-$VERSION' file...\n";
1179
0
0
my $pth =$s->pthForm('tmp') && $s->{-path};
1180
0
$pth =~s/\\/\//g;
1181
0
0
0
$s->hfNew('+>', ($pth .'/.htaccess-' .$VERSION))->lock(LOCK_EX)
1182
->store( "# Default data and pulic directory tree configuration.\n"
1183
."# Should be included in 'httpd.conf'.\n"
1184
."# Include " .($pth .'/.htaccess-' .$VERSION) ."\n"
1185
."\n"
1186
."#\n"
1187
."#\tLoadModule ntlm_module modules/mod_ntlm.so\n"
1188
."#\n"
1189
."#\n"
1190
."#\tLoadModule sspi_auth_module modules/mod_auth_sspi.so\n"
1191
."#\n"
1192
."\n"
1193
."#\tAllowOverride All\n"
1194
."\tAllowOverride Limit AuthConfig\n"
1195
."\tOptions -FollowSymLinks\n"
1196
."\tAccessFileName .htaccess\n"
1197
."\tOrder Allow,Deny\n"
1198
."\tAllow from All\n"
1199
."#\t\n"
1200
."#\t\tAuthType NTLM\n"
1201
."#\t\tNTLMAuth On\n"
1202
."#\t\tNTLMAuthoritative On\n"
1203
."#\t\tNTLMOfferBasic On\n"
1204
."#\t\n"
1205
."#\t\n"
1206
."#\t\tAuthType SSPI\n"
1207
."#\t\tSSPIAuth On\n"
1208
."#\t\tSSPIAuthoritative On\n"
1209
."#\t\tSSPIOfferBasic On\n"
1210
."#\t\n"
1211
.($s->{-AuthUserFile}
1212
?("\tAuthUserFile " .$s->{-AuthUserFile} ."\n")
1213
:("#\tAuthUserFile " .($pth ."/var/ualist") ."\n"))
1214
."\tAuthGroupFile " .($s->{-AuthGroupFile} ||($pth ."/var/uagroup")) ."\n"
1215
."\n"
1216
."#Alias /dbix-web/rfa/ \"$pth/\"\n"
1217
)
1218
->destroy;
1219
0
$s->pthForm('rfa');
1220
1221
0
print "Executing , some SQL DML error messages may be ignored...\n\n";
1222
0
local $s->{-dbiargpv} =$s->{-dbiarg};
1223
0
local $s->{-affect} =undef;
1224
0
local $s->{-rac} =undef;
1225
0
my $row;
1226
0
my $cmd ='';
1227
0
my $cmt ='';
1228
0
while ($row =) { $row = if 0;
0
1229
0
chomp($row);
1230
0
0
0
if ($cmd && ($row =~/^#/)) {
1231
0
my $v;
1232
0
chomp($cmd);
1233
0
0
print $cmt ||$cmd, " -> ";
1234
0
local $SELF =$s;
1235
0
local $_ =$s;
1236
0
0
if ($cmd =~/^\s*\{/) {
1237
0
$v =eval($cmd);
1238
0
0
print $@ ? $@ : 'ok'
1239
}
1240
else {
1241
0
$v =$s->dbi->do($cmd);
1242
0
0
print $s->dbi->err ? $s->dbi->errstr : 'ok'
1243
}
1244
0
0
print ': ', defined($v) ? $v : 'undef', "\n\n";
1245
0
$cmd ='';
1246
0
$cmt ='';
1247
}
1248
0
0
0
if ($row =~/^\s*#*\s*$/ || $row =~/^\s+#/ || $row eq '') {
0
0
1249
next
1250
0
}
1251
elsif ($row =~/^#/) {
1252
0
$cmt =$row
1253
}
1254
else {
1255
0
0
$cmd .=($cmd ? "\n" : '') .$row
1256
}
1257
}
1258
$s
1259
0
}
1260
1261
1262
#########################################################
1263
# Misc Data methods
1264
#########################################################
1265
1266
1267
sub dwnext { # next digit-word string value
1268
# self, string, ? min length
1269
0
0
0
1
my $v =$_[1] ||'0';
1270
0
for(my $i =1; $i <=length($v); $i++) {
1271
0
0
next if ord(substr($v,-$i,1)) >=ord('z');
1272
0
0
substr($v,-$i,1)=chr(ord(substr($v,-$i,1) eq '9' ? chr(ord('a')-1) : substr($v,-$i,1)) +1);
1273
0
0
substr($v,-$i+1)='0' x ($i-1) if $i >1;
1274
0
0
0
return($_[2] && length($v) <$_[2] ? '0' x ($_[2] -length($v)) .$v : $v)
1275
}
1276
0
$v =chr(ord('0')+1) .('0' x length($v));
1277
0
0
0
$_[2] && length($v) <$_[2] ? '0' x ($_[2] -length($v)) .$v : $v
1278
}
1279
1280
1281
sub grep1 { # first non-empty value
1282
# self, list
1283
# self, sub{}, list
1284
0
0
1
local $_;
1285
0
0
if (ref($_[1]) ne 'CODE') {
1286
0
0
foreach (@_[1..$#_]) {return($_) if $_}
0
1287
}
1288
else {
1289
0
my $t;
1290
0
0
foreach (@_[2..$#_]) {$t =&{$_[1]}(); return $t if $t}
0
0
0
1291
}
1292
0
return(())
1293
}
1294
1295
1296
sub shiftkeys { # shift keys from array
1297
0
0
1
my ($s,$a,$e) =@_; # (self, array, string regexp | sub{} condition)
1298
0
local $_;
1299
0
my @r;
1300
0
while (scalar(@$a)) {
1301
0
0
if ( ref($e)
0
1302
? &$e($s, $_ =$a->[0], 0)
1303
: $a->[0] =~/^(?:$e)$/) {
1304
0
push @r, shift @$a, shift @$a;
1305
}
1306
else {
1307
last
1308
0
}
1309
}
1310
@r
1311
0
}
1312
1313
1314
sub splicekeys { # splice keys from array
1315
0
0
1
my ($s,$a,$e) =@_; # (self, array, string regexp | sub{} condition)
1316
0
local $_;
1317
0
my $i =0;
1318
0
my @r;
1319
0
0
while (scalar(@$a) && ($i <=$#$a)) {
1320
0
0
if ( ref($e)
0
1321
? &$e($_[0], $_ =$a->[$i], $i)
1322
: $a->[$i] =~/^(?:$e)$/) {
1323
0
push @r, $a->[$i], $a->[$i+1];
1324
0
splice @$a,$i,2;
1325
}
1326
else {
1327
0
$i +=2
1328
}
1329
}
1330
@r
1331
0
}
1332
1333
1334
sub hreverse { # reverse hierarchy
1335
# (data, old delim, new delim) -> {value => reversed,...}
1336
0
0
1
my($s, $d, $m1, $m2) =@_;
1337
0
0
0
if (defined($m1)) {}
0
0
0
1338
0
elsif (!ref($d) && $d && ($d =~/\\/)) {$m1 ='\\'; $m2 ='/'}
0
1339
0
else {$m1 ='/'; $m2 ='\\'}
1340
0
0
if (!ref($d)) {
0
0
0
1341
0
0
return(!$d ? $d : join($m2, reverse split /\Q$m1\E/, $d))
1342
}
1343
elsif (ref($d) eq 'ARRAY') {
1344
0
my($r, $e) =({});
1345
0
for(my $i =0; $i <=$#$d; $i++) {
1346
0
$e =$d->[$i];
1347
0
0
if (ref($e)) {
1348
0
0
$r->{$e->[0]} =[join($m2, reverse split /\Q$m1\E/, $e->[0])
1349
,@$e[1..$#$e]]
1350
if defined($e->[0]);
1351
}
1352
else {
1353
0
0
$r->{$e} =join($m2, reverse split /\Q$m1\E/, $e)
1354
if defined($e);
1355
}
1356
}
1357
0
return($r);
1358
}
1359
elsif (ref($d) eq 'HASH') {
1360
0
my($r, $e) =({});
1361
0
foreach $e (keys %$d) {
1362
0
0
if (ref($d->{$e})) {
1363
0
$r->{$e} =[join($m2, reverse split /\Q$m1\E/, $d->{$e}->[0])
1364
0
0
,@{$d->{$e}}[1..$#{$d->{$e}}]]
0
1365
if defined($d->{$e}->[0]);
1366
}
1367
else {
1368
0
0
$r->{$e} =join($m2, reverse split /\Q$m1\E/, $d->{$e})
1369
if defined($d->{$e});
1370
}
1371
}
1372
0
return($r)
1373
}
1374
elsif (ref($d)) {
1375
0
my($r, $e) =({});
1376
0
while (defined($e =$d->fetch())) {
1377
0
0
$r->{$e->[0]} =$#$e >0
0
1378
? [join($m2, reverse split /\Q$m1\E/, $e->[0]), @$e[1..$#$e]]
1379
: join($m2, reverse split /\Q$m1\E/, $e->[0])
1380
if defined($e->[0]);
1381
}
1382
0
return($r);
1383
}
1384
else {
1385
0
return($d)
1386
}
1387
}
1388
1389
1390
sub max { # maximal number
1391
0
0
0
0
1
(($_[1]||0) >($_[2]||0) ? $_[1] : $_[2])||0
0
0
1392
}
1393
1394
1395
sub min { # minimal number
1396
0
0
0
0
1
(($_[1]||0) >($_[2]||0) ? $_[2] : $_[1])||0
0
0
1397
}
1398
1399
1400
sub orarg { # argument of true result
1401
0
0
1
shift(@_);
1402
0
0
my $s =ref($_[0]) ? shift
0
1403
:index($_[0], '-') ==0 ? eval('sub{' .shift(@_) .' $_}')
1404
:eval('sub{' .shift(@_) .'($_)}');
1405
0
local $_;
1406
0
0
foreach (@_) {return $_ if &$s($_)};
0
1407
undef
1408
0
}
1409
1410
1411
sub strpad { # string padding
1412
# self, string, ?pad char, ?min length
1413
0
0
0
0
1
length($_[1]) <$NLEN ? ($_[2]||'0') x ($_[3] ||$NLEN -length($_[1])) .$_[1] : $_[1];
0
1414
}
1415
1416
1417
sub strdata { # Stringify any data structure
1418
0
0
1
my $v =$_[1]; # self, data
1419
0
!defined($v)
1420
? ''
1421
: !ref($v)
1422
? $v # ($v =~s/([\x00-\x1f\\])/sprintf("\\x%02x",ord($1))/eg ? $v : $v)
1423
: isa($v, 'ARRAY')
1424
0
? join(', ', map {my $v =$_;
1425
0
ref($v)
1426
0
0
? do {my $x =strdata($_[0],$v);
0
0
1427
0
$x =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg;
0
1428
0
'(' .$x .')'
1429
}
1430
: !defined($v)
1431
? ''
1432
0
: $v =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg
1433
? $v
1434
: $v
1435
} @$v)
1436
: isa($v, 'HASH')
1437
0
0
? join(', ', map {my ($k, $v) =($_, $_[1]->{$_});
0
0
0
1438
0
$k =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg;
0
1439
0
ref($v)
1440
0
0
? do {my $x =strdata($_[0],$v);
0
0
1441
0
$x =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg;
0
1442
0
$k .'=(' .$x .')'
1443
}
1444
: !defined($v)
1445
? "$k="
1446
0
: $v =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg
1447
? "$k=$v"
1448
: "$k=$v"
1449
} sort keys %$v)
1450
: $v
1451
}
1452
1453
1454
sub strdatah { # Stringify hash data structure
1455
0
0
0
1
return(strdata(@_)) if $#_ <2;
1456
0
my $r ='';
1457
0
for (my $i =1; $i <$#_; $i +=2) {
1458
0
my ($k, $v) =@_[$i, $i+1];
1459
0
$k =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg;
0
1460
0
$r .=$k .'='
1461
.(!defined($v)
1462
? ''
1463
: ref($v)
1464
0
0
? do {my $x =strdata($_[0],$v);
0
0
1465
0
$x =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg;
0
1466
0
'(' .$x .')'
1467
}
1468
0
: $v =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg
1469
? $v
1470
: $v)
1471
.','
1472
}
1473
0
chop($r);
1474
0
$r
1475
}
1476
1477
1478
sub strquot { # Quote and Escape string
1479
0
0
1
my $v =$_[1];
1480
0
0
return('undef') if !defined($v);
1481
0
$v =~s/([\\'])/\\$1/g;
1482
0
$v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg;
0
1483
0
0
$v =~/^\d+$/ ? $v : ('\'' .$v .'\'');
1484
}
1485
1486
1487
sub strHTML { # Stringify HTML, convert to pure text
1488
0
0
0
1
my $h =defined($_[1]) ? $_[1] : '';
1489
0
my $t ='';
1490
0
0
$h =$' if $h =~/^[\s\r\n]+/;
1491
0
$h =~s/>[\r\n]+>
1492
0
$h =~s/[\r\n]+/ /g;
1493
0
while ($h =~/) {
1494
0
$t .=$`;
1495
0
$h =$';
1496
0
0
0
if (($h =~/^\/(?:h\d|div|p)\s*>\s*<\/(?:th|td)/i)
0
0
1497
|| ($h =~/^\/(?:li)\s*>\s*<(?:li|\/ul)/i)) {
1498
0
0
$t .="\n" if $t !~/^\s*$/;
1499
0
$h =$';
1500
}
1501
elsif ( ($h =~/^\/(?:h\d|div|p|td|th|tr|code|kbd|ul)/i)
1502
|| ($h =~/^(?:br|hr|li|table)/i)) {
1503
0
0
$t .="\n" if $t !~/^\s*$/
1504
}
1505
0
0
$h =$' if $h =~/>/;
1506
}
1507
0
$t .=$h;
1508
0
$t =$_[0]->htmlUnescape($t);
1509
0
$t =~s/\n{2,}/\n\n/g;
1510
0
$t
1511
}
1512
1513
1514
sub strDiff { # Strings difference
1515
# (-opt, old, new) -> changes
1516
# 'h'tml conversion if ishtml();
1517
# 'w'ords, 'r'ows, 's'entences input break;
1518
# 'b'rief, 'p'lane output
1519
0
0
1
my ($s,$o,$s1,$s2) =@_;
1520
0
my $r ='';
1521
0
0
$o ='-br' if !$o;
1522
0
0
$s1 ='' if !defined($s1);
1523
0
0
$s2 ='' if !defined($s2);
1524
0
0
0
$s1 =$s->strHTML($s1) if ($o =~/h/) && $s->ishtml($s1);
1525
0
0
0
$s2 =$s->strHTML($s2) if ($o =~/h/) && $s->ishtml($s2);
1526
0
0
0
return($s2) if ($s1 eq '') || ($s2 eq '');
1527
0
0
my $br =sub{ my ($h, $t)=($_[0], '');
1528
0
while ($h =~/([^\n]{100})/) {
1529
0
$t .=$`; $h =$';
0
1530
0
my $v =$1;
1531
0
0
if ($v =~/[ \t]$/) {
0
0
0
1532
0
$t .=$` ."\n"
1533
}
1534
elsif ($h =~/^[ \t]/) {
1535
0
$t .=$v ."\n"
1536
}
1537
elsif ($v !~/[ \t]/) {
1538
0
$t .=$v
1539
}
1540
elsif ($v =~/\s+([^\s]+)$/) {
1541
0
$t .=$` ."\n";
1542
0
$h =$1 .$h
1543
}
1544
}
1545
0
$t .=$h;
1546
0
$t
1547
0
};
1548
0
0
if (0) {}
0
1549
0
0
elsif (($o =~/w/) # words diff
1550
&& eval('use Algorithm::Diff; 1')) {
1551
0
0
my $cat =sub{ my($b,$v)=@_[1..2]; # (buf, sign, acc, last)
1552
0
$_[2] ='';
1553
0
0
0
if (($b =~/^=/) && ($o =~/b/)) {
1554
0
0
$v =$' if $v =~/^[\s\n]+/;
1555
0
0
$v =$` if $v =~/[\s\n]+$/;
1556
0
$v =~/\n+/;
1557
0
0
if ($_[0] eq '') {
0
0
1558
0
0
$v =$1 if $v =~/\n+([^\n]+)$/
1559
}
1560
elsif ($_[3]) {
1561
0
0
$v =$1 if $v =~/^([^\n]+)\n+/
1562
}
1563
elsif ($v =~/\n+/) {
1564
0
my $t =$`;
1565
0
0
if ($' =~/\n+([^\n]+)$/) {
1566
0
$v =$t ."\n...\n" .$1
1567
}
1568
}
1569
0
$v =' ' .$v;
1570
}
1571
0
0
$v =&$br($v) if $o =~/p/;
1572
0
$v =~s/\n/\n$b /g;
1573
0
$_[0] .=$b .$v ."\n";
1574
0
};
1575
0
$s1 =~s/([^ \t])\n/$1 \n/g; $s1 =~s/\n([^ \t])/\n $1/g;
0
1576
0
$s2 =~s/([^ \t])\n/$1 \n/g; $s2 =~s/\n([^ \t])/\n $1/g;
0
1577
0
my ($p, $ax, $ay, $au) =('','','','');
1578
0
foreach my $d (Algorithm::Diff::sdiff([split /[ \t]+/, $s1],[split /[ \t]+/, $s2])) {
1579
0
0
if ($p ne $d->[0]) {
1580
0
0
&$cat($r,'-:',$ax) if length($ax) >0;
1581
0
0
&$cat($r,'+:',$ay) if length($ay) >0;
1582
0
0
&$cat($r,'=:',$au) if length($au) >0;
1583
}
1584
0
$p =$d->[0];
1585
0
0
$ax .=' ' .$d->[1] if $p eq '-';
1586
0
0
$ax .=' ' .$d->[1] if $p eq 'c';
1587
0
0
$ay .=' ' .$d->[2] if $p eq '+';
1588
0
0
$ay .=' ' .$d->[2] if $p eq 'c';
1589
0
0
$au .=' ' .$d->[1] if $p eq 'u';
1590
}
1591
0
0
&$cat($r,'-:',$ax,1) if length($ax) >0;
1592
0
0
&$cat($r,'+:',$ay,1) if length($ay) >0;
1593
0
0
&$cat($r,'=:',$au,1) if length($au) >0;
1594
}
1595
elsif (eval('use Algorithm::Diff; 1')) { # strings diff
1596
0
0
if ($o =~/r/) { # row break
0
1597
0
$s1 =&$br($s1);
1598
0
$s2 =&$br($s2);
1599
}
1600
elsif ($o =~/s/) { # sentence break
1601
0
$s1 =~s/\.[ \t]+/\.\n/;
1602
0
$s2 =~s/\.[ \t]+/\.\n/;
1603
}
1604
0
0
my $cat =sub{ my($b,$v)=@_[1..2]; # (buf, sign, acc, last)
1605
0
$_[2] ='';
1606
0
0
0
if (($b =~/^=/) && ($o =~/b/)) {
1607
0
0
$v =$' if $v =~/^[\s\n]+/;
1608
0
0
$v =$` if $v =~/[\s\n]+$/;
1609
0
$v =~/\n+/;
1610
0
0
if ($_[0] eq '') {
0
0
1611
0
0
$v =$1 if $v =~/\n+([^\n]+)$/
1612
}
1613
elsif ($_[3]) {
1614
0
0
$v =$1 if $v =~/^([^\n]+)\n+/
1615
}
1616
elsif ($v =~/\n+/) {
1617
0
my $t =$`;
1618
0
0
if ($' =~/\n+([^\n]+)$/) {
1619
0
$v =$t ."\n...\n" .$1
1620
}
1621
}
1622
}
1623
else {
1624
0
chomp($v)
1625
}
1626
0
0
$v =&$br($v) if $o =~/p/;
1627
0
$v =~s/\n/\n$b /g;
1628
0
$_[0] .=$b .' ' .$v ."\n";
1629
0
};
1630
0
my ($p, $ax, $ay, $au) =('','','','');
1631
0
foreach my $d (Algorithm::Diff::sdiff([split /\n+/, $s1],[split /\n+/, $s2])) {
1632
0
0
if ($p ne $d->[0]) {
1633
0
0
&$cat($r,'-:',$ax) if length($ax) >0;
1634
0
0
&$cat($r,'+:',$ay) if length($ay) >0;
1635
0
0
&$cat($r,'=:',$au) if length($au) >0;
1636
}
1637
0
$p =$d->[0];
1638
0
0
$ax .=$d->[1] ."\n" if $p eq '-';
1639
0
0
$ax .=$d->[1] ."\n" if $p eq 'c';
1640
0
0
$ay .=$d->[2] ."\n" if $p eq '+';
1641
0
0
$ay .=$d->[2] ."\n" if $p eq 'c';
1642
0
0
$au .=$d->[1] ."\n" if $p eq 'u';
1643
}
1644
0
0
&$cat($r,'-:',$ax,1) if length($ax) >0;
1645
0
0
&$cat($r,'+:',$ay,1) if length($ay) >0;
1646
0
0
&$cat($r,'=:',$au,1) if length($au) >0;
1647
}
1648
else { # simplest diff
1649
0
0
0
$r = ($s1 eq '') || ($s2 eq '')
0
0
1650
? $s2
1651
: (length($s1) >255) && (length($s2) >255)
1652
? '...Algorithm::Diff should be used...'
1653
: $s2;
1654
}
1655
0
$r
1656
}
1657
1658
1659
sub htfrDiff { # html reformat for difference
1660
0
0
$_[1] =~/ \n*[-+=]:/
1661
? ""
1668
: $_[1]
1669
}
1670
1671
1672
sub datastr { # Data structure from String
1673
# (for data structure strings only!)
1674
# self, string, ?unescape
1675
0
0
1
my $v =$_[1];
1676
0
0
$v =~s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg if $_[2];
0
1677
0
0
$v =~/^[^\(\)]+[=]/
1678
0
? {map { my ($n, $v) =(/^\s*([^=]+)\s*=\s*(.*)$/ ? ($1,$2) : ());
1679
0
0
0
!defined($n) ||($n eq '')
0
0
0
0
1680
? ()
1681
: !defined($v)
1682
? ($n =>$v)
1683
: $v =~/^\(/
1684
? ($n =>datastr($_[0], substr($v,1,-1), 1) ||undef)
1685
0
: $v =~s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg
1686
? ($n =>$v)
1687
: ($n =>$v)
1688
} split /\s*[,;]\s*/, $v}
1689
: $v =~/[,;]/
1690
0
0
0
? [grep {defined($_)} map {
0
0
1691
0
0
!defined($_)
0
0
1692
? ()
1693
: /^\(/
1694
? datastr($_[0], substr($_,1,-1), 1) ||undef
1695
0
: s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg
1696
? $_
1697
: $_
1698
} split / *[,;] */, $v]
1699
0
: $v =~s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg
1700
? $v
1701
: $v
1702
}
1703
1704
sub dsdClone { # Clone data structure
1705
0
0
!ref($_[1]) ? $_[1]
1706
0
: ref($_[1]) eq 'ARRAY' ? [map {ref($_) ? dsdClone($_[0], $_) : $_} @{$_[1]}]
0
1707
0
0
0
1
: ref($_[1]) eq 'HASH' ? {map {($_, dsdClone($_[0], $_[1]->{$_}))} keys %{$_[1]}}
0
0
0
1708
: $_[1]
1709
}
1710
1711
1712
sub dsdMk { # Data structure dump to string
1713
0
0
1
my ($s, $d) =@_;
1714
0
eval('use Data::Dumper');
1715
0
my $o =Data::Dumper->new([$d]);
1716
0
$o->Indent(1);
1717
0
$o->Dump();
1718
}
1719
1720
1721
sub dsdQuot { # Quote and Escape data structure
1722
0
$#_ <2 # (self, ?'=>', data struct)
1723
? dsdQuot($_[0],'=> ',$_[1])
1724
: !ref($_[2]) # (, hash delim, value) -> stringified
1725
? strquot($_[0],$_[2])
1726
: ref($_[2]) eq 'ARRAY'
1727
0
? '[' .join(', ', map {dsdQuot(@_[0..1],$_)
1728
0
} @{$_[2]}) .']'
1729
: ref($_[2]) eq 'HASH'
1730
0
? '{' .join(', ', map {$_ .$_[1] .dsdQuot(@_[0..1],$_[2]->{$_})
1731
0
0
0
1
} sort keys %{$_[2]}) .'}'
0
0
0
1732
: strquot($_[0],$_[2])
1733
}
1734
1735
1736
sub dsdParse { # Data structure dump string to perl structure
1737
0
0
1
my ($s, $d) =@_;
1738
0
eval('use Safe');
1739
0
Safe->new()->reval($d)
1740
}
1741
1742
1743
sub strtime { # Stringify Time
1744
0
0
1
my $s =shift;
1745
0
0
0
my $msk =@_ ==0 || $_[0] =~/^\d+$/i ? 'yyyy-mm-dd hh:mm:ss' : shift;
1746
0
0
my @tme =@_ ==0 ? localtime(time) : @_ ==1 ? localtime($_[0]) : @_;
0
1747
0
$msk =~s/yyyy/%Y/;
1748
0
$msk =~s/yy/%y/;
1749
0
$msk =~s/mm/%m/;
1750
0
$msk =~s/mm/%M/i;
1751
0
$msk =~s/dd/%d/;
1752
0
$msk =~s/hh/%H/;
1753
0
$msk =~s/hh/%h/i;
1754
0
$msk =~s/ss/%S/;
1755
#eval('use POSIX');
1756
0
POSIX::strftime($msk, @tme)
1757
}
1758
1759
1760
sub timestr { # Time from String
1761
0
0
1
my $s =shift;
1762
0
0
0
my $msk =@_ <2 || !$_[1] ? 'yyyy-mm-dd hh:mm:ss' : shift;
1763
0
my $ts =shift;
1764
0
my %th;
1765
0
while ($msk =~/(yyyy|yy|mm|dd|hh|MM|ss)/) {
1766
0
my $m=$1; $msk =$';
0
1767
0
0
last if !($ts =~/(\d+)/);
1768
0
my $d =$1; $ts =$';
0
1769
0
0
0
$d -=1900 if $m eq 'yyyy' ||$m eq '%Y';
1770
0
$m =chop($m);
1771
0
0
0
$m ='M' if $m eq 'm' && $th{$m};
1772
0
0
$m =lc($m) if $m ne 'M';
1773
0
$th{$m}=$d;
1774
}
1775
#eval('use POSIX');
1776
0
0
POSIX::mktime($th{'s'}||0,$th{'M'}||0,$th{'h'}||0,$th{'d'}||0,($th{'m'}||1)-1,$th{'y'}||0,0,0,(localtime(time))[8])
0
0
0
0
0
1777
}
1778
1779
1780
sub timeadd { # Adjust time to years, months, days,...
1781
0
0
1
my $s =$_[0];
1782
0
my @t =localtime($_[1]);
1783
0
my $i =5;
1784
0
0
foreach my $a (@_[2..$#_]) {$t[$i] += ($a||0); $i--}
0
0
1785
#eval('use POSIX');
1786
0
POSIX::mktime(@t[0..5],0,0,$t[8])
1787
}
1788
1789
1790
sub cptran { # Translate strings between codepages
1791
0
0
1
my ($s,$f,$t,@s) =@_;
1792
0
0
0
if (($] >=5.008) && eval("use Encode; 1")) {
1793
0
0
map {$_= /oem|866/i ? 'cp866'
0
0
0
0
1794
: /ansi|1251/i ? 'cp1251'
1795
: /koi/i ? 'koi8-r'
1796
: /8859-5/i ? 'iso-8859-5'
1797
: $_
1798
} $f, $t;
1799
0
0
0
map {Encode::is_utf8($_)
0
0
1800
? ($_ =Encode::encode($t, $_, 0))
1801
: Encode::from_to($_, $f, $t, 0)
1802
if defined($_) && ($_ ne '')
1803
} @s;
1804
}
1805
else {
1806
0
foreach my $v ($f, $t) { # See also utf8enc, utf8dec
1807
0
0
if ($v =~/oem|866/i) {$v ='€‚ƒ„…ð†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™œ›šžŸ ¡¢£¤¥ñ¦§¨©ª«¬®¯àáâãäåæçèéìëêíîï'}
0
0
0
0
0
1808
0
elsif ($v =~/ansi|1251/i) {$v ='ÀÁÂÃÄŨÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÜÛÚÝÞßàáâãäå¸æçèéêëìíîïðñòóôõö÷øùüûúýþÿ'}
1809
0
elsif ($v =~/koi/i) {$v ='áâ÷çäå³öúéêëìíîïðòóôõæèãþûýøùÿüàñÁÂ×ÇÄÅ£ÖÚÉÊËÌÍÎÏÐÒÓÔÕÆÈÃÞÛÝØÙßÜÀÑ'}
1810
elsif ($v =~/8859-5/i) {$v ='°±²³´µ¡¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÌËÊÍÎÏÐÑÒÓÔÕñÖ×ØÙÚÛÜÝÞßàáâãäåæçèéìëêíîï'}
1811
}
1812
0
0
map {eval("~tr/$f/$t/") if defined($_)} @s;
0
1813
}
1814
0
0
@s >1 ? @s : $s[0];
1815
}
1816
1817
1818
sub ishtml { # Looks like HTML?
1819
0
0
0
1
($_[1] ||'') =~m/^<(?:(?:B|BIG|BLOCKQUOTE|CENTER|CITE|CODE|DFN|DIV|EM|I|KBD|P|SAMP|SMALL|SPAN|STRIKE|STRONG|STYLE|SUB|SUP|TT|U|VAR)\s*>|(?:BR|HR)\s*\/{0,1}>|(?:A|BASE|BASEFONT|DIR|DIV|DL|!DOCTYPE|FONT|H\d|HEAD|HTML|IMG|IFRAME|MAP|MENU|OL|P|PRE|TABLE|UL)\b)/i
1820
}
1821
1822
1823
1824
sub htmlEscape {
1825
0
join '',
1826
0
0
0
1
map { my $v =$_; return('') if !defined($_);
0
1827
0
$v =~s{&}{&}gso;
1828
0
$v =~s{<}{<}gso;
1829
0
$v =~s{>}{>}gso;
1830
0
$v =~s{"}{"}gso;
1831
0
$v
1832
} @_[1..$#_]
1833
}
1834
1835
1836
sub htmlEscBlnk {
1837
0
join '',
1838
0
0
0
0
0
map { my $v =$_; return(' ') if !defined($_) || $_ eq '';
0
1839
0
$v =~s{&}{&}gso;
1840
0
$v =~s{<}{<}gso;
1841
0
$v =~s{>}{>}gso;
1842
0
$v =~s{"}{"}gso;
1843
0
$v
1844
} @_[1..$#_]
1845
}
1846
1847
1848
sub htmlSubmitSpl { # Special html buttons format
1849
# Additional Named Entities for HTML
1850
# ms-help://MS.MSDNQTR.v90.en/vbafpd11/html/fphowHTMLCharSets_HV03091409.htm
1851
# return($_[0]->cgi->submit(@_[1..$#_]))
1852
0
0
0
my ($s, %o) =@_;
1853
0
0
$o{-class} =$s->{-c}->{-htmlclass} ? 'Input ' .$s->{-c}->{-htmlclass} : 'Input'
0
1854
if !$o{-class};
1855
0
0
if (!$o{-value}) {
1856
0
$o{-value} =$s->lng(0,'ddlbopen');
1857
0
0
$o{-title} =$s->lng(1,'ddlbopen') if !$o{-title};
1858
0
0
$o{-style} ="width: 2em;" if !$o{-style};
1859
}
1860
0
0
join(' ','
1861
0
,(map { my ($k, $t) =($_, $_ =~/^-(.+)/ ? $1 : $_);
1862
0
0
$t .'="'
0
1863
.( $t =~/^value$/i
1864
? ( $o{$k} eq '...'
1865
? '…'
1866
: htmlEscape($s, $o{$k})
1867
)
1868
: htmlEscape($s, $o{$k})
1869
) .'"'
1870
} sort keys %o)
1871
,'>')
1872
}
1873
1874
1875
sub htmlUnescape {
1876
0
join '',
1877
0
0
0
1
map { my $v =$_; return('') if !defined($_);
0
1878
0
$v =~s[&(.*?);]{
1879
0
local $_ = $1;
1880
0
0
/^amp$/i ? "&" :
0
0
0
1881
/^quot$/i ? '"' :
1882
/^gt$/i ? ">" :
1883
/^lt$/i ? "<" :
1884
$_;
1885
}gex;
1886
0
$v
1887
} @_[1..$#_]
1888
}
1889
1890
1891
sub urlEscape {
1892
0
join '',
1893
0
0
0
1
map { my $v =$_; return('') if !defined($_);
0
1894
0
$v =~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
0
1895
0
$v
1896
} @_[1..$#_]
1897
}
1898
1899
1900
sub urlUnescape {
1901
0
join '',
1902
0
0
0
1
map { local $_ =$_; return('') if !defined($_);
0
1903
0
tr/+/ /;
1904
0
s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
0
1905
0
$_
1906
} @_[1..$#_]
1907
}
1908
1909
1910
sub urlCat {
1911
0
0
0
1
my $r =$_[1] =~/\?/ ? ($_[1] .$HS) : ($_[1] .'?');
1912
0
for (my $i =2; $i <$#_; $i+=2) {$r .=urlEscape($_[0], $_[$i]) .'=' .urlEscape($_[0], $_[$i+1]) .$HS}
0
1913
0
chop($r); $r
0
1914
}
1915
1916
1917
sub urlCmd {
1918
0
0
0
1
my $r =($_[1]||'') .'?';
1919
0
for (my $i =2; $i <$#_; $i+=2) {
1920
0
0
$r .=urlEscape($_[0], $_[$i] =~/^-/ ? '_' .$' : $_[$i])
0
1921
.'='
1922
.urlEscape($_[0], ref($_[$i+1]) ? strdata($_[0], $_[$i+1]) : $_[$i+1])
1923
.$HS
1924
0
} chop($r); $r
0
1925
}
1926
1927
1928
sub xmlEscape {
1929
0
join '',
1930
0
0
0
1
map { my $v =$_; return('') if !defined($v);
0
1931
0
$v =~s/([\\"<>])/sprintf('\\x%02x',ord($1))/ge;
0
1932
# $v =~s/([\\"<])/\\$1/g;
1933
# $v =~s/([^\w\d ,<.>\/?:;"'\[\]{}`~!@#$%^&*()-_=+\\|])/ ord($1) < 0x20 ? sprintf('\\x%02x',ord($1)) : $1/ge;
1934
0
$v =~s/([\x00-\x1F])/sprintf('\\x%02x',ord($1))/ge;
0
1935
0
$v
1936
} @_[1..$#_]
1937
}
1938
1939
1940
sub xmlAttrEscape {
1941
0
0
1
xmlEscape(@_)
1942
}
1943
1944
1945
sub xmlTagEscape {
1946
0
join '',
1947
0
0
0
1
map { my $v =$_; return('') if !defined($v);
0
1948
0
$v =~s/([\\"<>])/sprintf('\\x%02x',ord($1))/ge;
0
1949
# $v =~s/([\\"<])/\\$1/g;
1950
# $v =~s/([^\w\d\s\n ,<.>\/?:;"'\[\]{}`~!@#$%^&*()-_=+\\|])/ ord($1) < 0x20 ? sprintf('\\x%02x',ord($1)) : $1/eg;
1951
0
$v =~s/([\x00-\x08\x0B-\x0C\x0E-\x1F]|[&])/sprintf('\\x%02x',ord($1))/eg;
0
1952
# \t=0x09; \n=0x0A; \r=0x0D;
1953
0
$v
1954
} @_[1..$#_]
1955
}
1956
1957
1958
sub xmlUnescape {
1959
0
join '',
1960
0
0
0
1
map { my $v =$_; return('') if !defined($v);
0
1961
0
$v =~s/\\\\/\\/g;
1962
0
0
$v =~s|(\\+)([<"])| int(length($1)/2)*2 == length($1) ? ('\\' x (length($1)-1) .$2) : ($1 .$2)|ge;
0
1963
0
0
$v =~s|(\\+)(x\d+)| int(length($1)/2)*2 == length($1) ? ('\\' x (length($1)-1) .chr(hex($2))) : ($1 .$2)|ge;
0
1964
0
$v
1965
} @_[1..$#_]
1966
}
1967
1968
1969
sub lsTag { # Attribute list to tag strings list
1970
0
0
0
my($c, $v, $n);# htmlEscape, urlEscape, tagEscape, self, tagname, attr=>value,...
1971
0
0
$#_+1 !=2*int(($#_+1)/2)
0
1972
? 0
1973
: substr($_[$#_],0,1) eq "\n"
1974
? ($n =$_[$#_])
1975
: ($c =$_[$#_]);
1976
1
0
1
980
((!ref($_[$[+4])
1
459
1
1196
0
1977
? ('<', $_[$[+4]
1978
0
,(map {$_[$_]
1979
? (defined($_[$_+1])
1980
? (' ', substr($_[$_],0,1) eq '-' ? substr($_[$_],1) : $_[$_], '="'
1981
0
, &{$_[$_] ne 'href' ? $_[$[] : $_[$[+1]}
1982
($_[$[+3], !ref($_[$_+1]) ? $_[$_+1] : strdata($_[$[+3], $_[$_+1]))
1983
, '"')
1984
: ())
1985
0
0
: eval{$c =$_[$_]; $v =$_[$_+1]; ()}
0
0
0
0
0
1986
} map {$_*2+3} $[+1..int(($#_-3)/2) )
1987
,(!defined($c)
1988
? ' />'
1989
: $c eq '0'
1990
? '>'
1991
: ('>'
1992
0
, (ref($v) eq 'CODE') && ($v =&{$v}) && 0
1993
? ()
1994
: ref($v) eq 'ARRAY'
1995
? &lsTag(@_[$[..$[+3], $v)
1996
: defined($v)
1997
0
? &{$_[$[+2]}($_[$[+3], $v)
1998
: ()
1999
, '', $_[$[+4], '>') )
2000
)
2001
: ref($_[$[+4]) eq 'ARRAY'
2002
0
0
? (map {ref($_) ne 'ARRAY' ? &{$_[$[+2]}($_[$[+3], $_) : lsTag(@_[$[..$[+3], @$_)} @{$_[$[+4]})
0
2003
0
0
: ref($_[$[+4]) eq 'HASH' && eval{$v =$_[$[+4]; $c =$v->{'-'}||$v->{'-tag'}||'tag'}
2004
? ('<', $c
2005
0
0
,(map {defined($v->{$_})
2006
?(' '
2007
, substr($_,0,1) eq '-' ? substr($_, 1) : $_, '="'
2008
0
0
, &{$_ ne 'href' ? $_[$[] : $_[$[+1]}
0
0
2009
($_[$[+3], !ref($v->{$_}) ? $v->{$_} : strdata($_[$[+3], $v->{$_}))
2010
,'"')
2011
:()
2012
}
2013
0
sort grep {$_ && $_ !~/^-(tag|data|)$/} keys %$v)
2014
0
0
, (grep {exists($v->{$_}) && eval{$v =$v->{$_}}} '', '-data')
2015
? ('>'
2016
0
,(ref($v) eq 'CODE') && ($v =&{$v}) && 0
2017
? ()
2018
: ref($v) eq 'ARRAY'
2019
? &lsTag(@_[$[..$[+3], $v)
2020
: defined($v)
2021
0
0
0
? &{$_[$[+2]}($_[$[+3], $v)
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
2022
: ()
2023
,'',$c,'>')
2024
: exists($v->{0})
2025
? '>'
2026
: ' />'
2027
)
2028
: ()
2029
), !$n ? () : $n)
2030
}
2031
2032
2033
sub htlsTag { # Attribute list to html strings list
2034
0
0
1
lsTag(\&htmlEscape, \&urlEscape, \&htmlEscape, @_)
2035
}
2036
2037
2038
sub xmlsTag { # Attribute list to xml strings list
2039
0
0
1
lsTag(\&xmlAttrEscape, \&xmlAttrEscape, \&xmlTagEscape, @_)
2040
}
2041
2042
2043
sub utf8enc { # Encode to UTF8, see also cptran()
2044
0
0
0
my $r =$_[1];
2045
0
0
0
if (($] >=5.008) && eval("use Encode; 1")) {
2046
# return($r) if Encode::is_utf8($r);
2047
0
0
my $cp =eval('!${^ENCODING}') && $_[0]->charpage();
2048
0
0
eval("use encoding '$cp', STDIN=>undef, STDOUT=>undef") if $cp;
2049
0
$r =Encode::encode_utf8($r);
2050
0
0
eval('no encoding') if $cp;
2051
0
return($r);
2052
}
2053
0
0
my $t =$LNG->{'utf8enc_' .($_[0]->{-lang}||'')};
2054
0
0
return($r) if !$t;
2055
0
&$t($r);
2056
0
$r;
2057
}
2058
2059
2060
sub utf8dec { # Decode from UTF8, see also cptran()
2061
0
0
0
my $r =$_[1];
2062
0
0
0
if (($] >=5.008) && eval("use Encode; 1")) {
2063
0
0
my $cp =eval('!${^ENCODING}') && $_[0]->charpage();
2064
0
0
eval("use encoding '$cp', STDIN=>undef, STDOUT=>undef") if $cp;
2065
0
$r =Encode::decode_utf8($r,0);
2066
0
0
eval('no encoding') if $cp;
2067
0
0
$r =Encode::encode($cp,$r,0) if $cp;
2068
0
return($r);
2069
}
2070
0
0
my $t =$LNG->{'utf8dec_' .($_[0]->{-lang}||'')};
2071
0
0
return($r) if !$t;
2072
0
&$t($r);
2073
0
$r;
2074
}
2075
2076
2077
2078
#########################################################
2079
# Misc Utility methods
2080
#########################################################
2081
2082
2083
sub cgi { # CGI object
2084
0
0
0
1
return($_[0]->{-cgi}) if $_[0]->{-cgi};
2085
0
0
0
if (!eval("use CGI (); 1") ||!eval("use CGI (); 1")) {
2086
0
0
my $e =$@ ||'undef';
2087
0
$_[0]->logRec('error',"use CGI -> $e");
2088
# eval('use CGI::Carp'); CGI::Carp::croak("use CGI -> $e\n");
2089
0
&{$_[0]->{-die}}("use CGI -> $e\n");
0
2090
}
2091
1
1
12
no warnings; # consider also $CGI::Q - default CGI object - due to bugs
1
2
1
8185
2092
0
$_[0]->{-cgi} =$CGI::Q =eval('local $^W =0; CGI->new()');
2093
0
0
if (!$_[0]->{-cgi}) {
2094
0
0
my $e =$@ ||'undef';
2095
0
$_[0]->logRec('error',"CGI::new() -> $e");
2096
# eval('use CGI::Carp'); CGI::Carp::croak("CGI::new() -> $e\n");
2097
0
&{$_[0]->{-die}}("CGI::new() -> $e\n");
0
2098
}
2099
0
0
if ($_[0]->{-cgi}->{'.cgi_error'}) {
2100
0
$_[0]->{-c}->{'.cgi_error'} =$_[0]->{-cgi}->{'.cgi_error'};
2101
0
$_[0]->logRec('error','CGI::new() -> ' .$_[0]->{-cgi}->{'.cgi_error'})
2102
}
2103
0
$CGI::XHTML =0;
2104
0
0
$CGI::USE_PARAM_SEMICOLONS =$HS eq ';' ? 1 : 0;
2105
0
0
0
if ((($ENV{SERVER_SOFTWARE}||'') =~/IIS/i)
0
0
2106
|| ($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER})) {
2107
0
$CGI::NPH =1
2108
}
2109
0
0
if ($ENV{PERLXS}) {
2110
}
2111
0
0
0
if (($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/) {
2112
}
2113
0
$_[0]->{-cgi}
2114
}
2115
2116
2117
sub url { # CGI script URL
2118
0
0
0
0
if ($#_ >0) {
2119
0
local $^W =0;
2120
0
0
my $v =($_[0]->{-cgi}||$_[0]->cgi)->url(@_[1..$#_]);
2121
0
0
0
if ($v) {}
0
0
0
0
0
0
2122
elsif (!($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {}
2123
elsif (($#_ >2) ||(($#_ ==2) && !$_[2])) {}
2124
elsif ($_[1] eq '-relative') {
2125
0
$v =$ENV{SCRIPT_NAME};
2126
0
0
$v =$1 if $v =~/[\\\/]([^\\\/]+)$/;
2127
}
2128
elsif ($_[1] eq '-absolute') {
2129
0
$v =$ENV{SCRIPT_NAME}
2130
}
2131
0
return($v)
2132
}
2133
0
0
return($_[0]->{-c}->{-url})
2134
if $_[0]->{-c}->{-url};
2135
0
local $^W =0;
2136
0
$_[0]->{-c}->{-url} =$_[0]->cgi->url();
2137
0
0
0
if ($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/)) {
0
2138
0
0
0
$_[0]->{-c}->{-url} .=
0
0
2139
(($_[0]->{-c}->{-url} =~/\/$/) ||($ENV{SCRIPT_NAME} =~/^\//) ? '' : '/')
2140
.$ENV{SCRIPT_NAME}
2141
if ($_[0]->{-c}->{-url} !~/\w\/\w/) && $ENV{SCRIPT_NAME};
2142
}
2143
0
$_[0]->{-c}->{-url}
2144
}
2145
2146
2147
sub dbi { # DBI connection object
2148
0
0
0
1
return ($_[0]->{-dbi}) if $_[0]->{-dbi};
2149
0
0
$_[0]->{-dbidsn} =ref($_[0]->{-dbiarg}) ? $_[0]->{-dbiarg}->[0] : $_[0]->{-dbiarg};
2150
$_[0]->{-dbi} =$_[0]->dbiConnect()
2151
0
0
|| &{$_[0]->{-die}}($_[0]->lng(0,'dbi') .": DBI::conect() -> failure\n");
2152
0
$_[0]->{-dbi}->{AutoCommit} =$_[0]->{-autocommit};
2153
0
0
if (!$_[0]->{-dbistart}) {
0
0
2154
}
2155
elsif (ref($_[0]->{-dbistart}) eq 'CODE') {
2156
0
&{$_[0]->{-dbistart}}(@_)
0
2157
}
2158
elsif (ref($_[0]->{-dbistart}) eq 'ARRAY') {
2159
0
foreach my $v (@{$_[0]->{-dbistart}}) {
0
2160
0
$_[0]->logRec('dbi',$v);
2161
0
eval{$_[0]->{-dbi}->do($v)};
0
2162
0
0
next if !$_[0]->{-dbi}->err;
2163
0
$_[0]->logRec($_[0]->lng(0,'Error'), $_[0]->{-dbi}->errstr);
2164
}
2165
}
2166
else {
2167
0
$_[0]->logRec('dbi',$_[0]->{-dbistart});
2168
0
eval{$_[0]->{-dbi}->do($_[0]->{-dbistart})};
0
2169
0
0
if ($_[0]->{-dbi}->err) {
2170
0
$_[0]->logRec($_[0]->lng(0,'Error'), $_[0]->{-dbi}->errstr);
2171
}
2172
}
2173
0
$_[0]->{-dbi}
2174
}
2175
2176
2177
sub dbiEng { # DBI engine name
2178
0
0
0
0
if ($_[1]) { # (? name ) -> match | () -> dsn
2179
0
my $v =$_[1];
2180
0
0
($_[0]->{-dbidsn} || $_[0]->{Driver}->{Name}) =~/\bDBI:\Q$v\E\b/i
2181
}
2182
else {
2183
0
0
$_[0]->{-dbidsn} || $_[0]->{Driver}->{Name}
2184
}
2185
}
2186
2187
2188
sub dbiConnect {# DBI connecting with optional DBI:Proxy:hostname=127.0.0.1
2189
0
0
0
0
eval('use PerlEx::DBI') if $ENV{GATEWAY_INTERFACE} =~/PerlEx/;
2190
0
0
eval('use Apache::DBI') if $ENV{MOD_PERL};
2191
0
0
return(undef) if !eval("use DBI; 1;");
2192
0
0
my $c=ref($_[0]->{-dbiarg}) ? $_[0]->{-dbiarg}->[0] : $_[0]->{-dbiarg};
2193
0
0
if ($c =~/^DBI:Proxy:hostname=127\.0\.0\.1;/i) {
2194
# "dbi:Proxy:hostname=127.0.0.1;port=3334;proxy_no_finish=1;dsn=DBI:mysql:"
2195
# dbi->{Driver}->{Name} eq 'Proxy'
2196
0
my $i =2;
2197
0
my $r;
2198
0
0
while (!$r && $i) {
2199
0
0
$r =DBI->connect(ref($_[0]->{-dbiarg}) ? @{$_[0]->{-dbiarg}} : $_[0]->{-dbiarg});
0
2200
0
0
return($r) if $r;
2201
0
0
if (--$i) {
2202
0
0
my $h =$c=~/hostname=([^;]+)/ ? $1 : '';
2203
0
0
my $p =$c=~/port=([^;]+)/ ? $1 : '';
2204
0
my $x =$^X; # \\?\D:\Share\B\Perl\bin\PerlIS.dll
2205
0
0
$x =$' if $x =~/^\\\\\?\\/;
2206
0
0
$x =$` .'perl.exe' if $x =~/(?:PerlIS|PerlEx)\d*\.dll$/i;
2207
0
my $a ="$x -e\"use DBI::ProxyServer; DBI::ProxyServer::main('--localaddr'=>'$h','--localport'=>'$p')\"";
2208
# '--mode'=>'single','--logfile'=>'STDERR','--debug'=>1
2209
# $_[0]->die($a);
2210
0
0
if ($^O eq 'MSWin32') {
2211
0
$_[0]->logRec("Win32::Process($x, $a)");
2212
0
eval('use Win32::Process');
2213
0
$Win32::Process::Create::ProcessObj =$Win32::Process::Create::ProcessObj;
2214
0
Win32::Process::Create($Win32::Process::Create::ProcessObj
2215
,$x
2216
,$a
2217
,0
2218
,&CREATE_NEW_CONSOLE
2219
,'.')
2220
||
2221
0
0
&{$_[0]->{-die}}("Win32::Process($x, $a) -> $! $^E\n");
2222
}
2223
elsif (1) {
2224
0
$_[0]->logRec("system($a)");
2225
0
system(1,$a)
2226
0
0
&& &{$_[0]->{-die}}("system($a) -> $!\n");
2227
}
2228
2229
}
2230
}
2231
0
return($r)
2232
}
2233
(0 && $_[0]->{-autocommit}
2234
0
&& (eval{DBI->connect_cached(ref($_[0]->{-dbiarg}) ? @{$_[0]->{-dbiarg}} : $_[0]->{-dbiarg})}))
2235
0
0
|| (eval{DBI->connect(ref($_[0]->{-dbiarg}) ? @{$_[0]->{-dbiarg}} : $_[0]->{-dbiarg})})
0
2236
}
2237
2238
2239
sub dbiQuote { # DBI quote string
2240
0
0
1
$_[0]->dbi->quote(@_[1..$#_])
2241
}
2242
2243
2244
sub dbiUnquote { # DBI unquote string
2245
0
0
0
1
return($_[1]) if !defined($_[1]);
2246
0
0
my ($q,$r) =$_[1] =~/^(['"])(.*)['"]$/ ? ($1, $2) : (undef, $_[1]);
2247
0
0
return($r) if !$q;
2248
0
my $q1 =substr($_[0]->dbi->quote($q),1,-1);
2249
0
$r =~s/\Q$q1\E/$q/eg;
0
2250
0
$q ='\\'; $q1 =substr($_[0]->dbi->quote($q),1,-1);
0
2251
0
0
$r =~s/\Q$q1\E/$q/eg if $q ne $q1;
0
2252
0
$r
2253
}
2254
2255
2256
sub dbiLikesc { # DBI escape 'like'
2257
0
0
1
join('', map {my $v =$_; $v =~s/([\\%_])/\\$1/g; $v} @_[1..$#_])
0
0
0
2258
}
2259
2260
2261
sub hfNew { # New file handle object
2262
0
0
1
local $SELF =$_[0];
2263
0
0
DBIx::Web::FileHandle->new(-parent=>$_[0]
0
2264
,@_ >2 ? (-mode=>$_[1], -name=>$_[2])
2265
:@_ >1 ? (-name=>$_[1])
2266
: ())
2267
}
2268
2269
2270
sub ccbNew { # New condition code block object
2271
0
0
1
local $SELF =$_[0];
2272
0
DBIx::Web::ccbHandle->new($_[1])
2273
}
2274
2275
2276
sub dbmNew { # New isam datafile object
2277
0
0
1
local $SELF =$_[0];
2278
0
0
DBIx::Web::dbmHandle->new(-parent=>$_[0], @_ >2 ? @_[1..$#_] : (-name=>$_[1]))
2279
}
2280
2281
2282
sub dbmTable { # Get isam datafile object
2283
0
0
0
1
return(&{$_[0]->{-die}}('Bad table \'' .$_[1] .'\'' .$_[0]->{-ermd})) if !$_[1];
0
2284
0
0
0
$CACHE->{$_[0]}->{'-dbm/' .$_[1]}
2285
||($CACHE->{$_[0]}->{'-dbm/' .$_[1]}
2286
=$_[0]->dbmNew( -name =>$_[0]->pthForm('dbm'
2287
,( $_[0]->{-table}->{$_[1]}
2288
&& $_[0]->{-table}->{$_[1]}->{-expr}
2289
|| $_[1]))
2290
,-table =>$_[0]->{-table}->{$_[1]}
2291
,-lock =>LOCK_SH))->opent
2292
}
2293
2294
2295
sub dbmTableClose { # Close isam datafile object if opened
2296
0
0
0
0
return(&{$_[0]->{-die}}('Bad table \'' .$_[1] .'\'' .$_[0]->{-ermd})) if !$_[1];
0
2297
0
0
if ($_[1] eq '*') {
2298
# $_[0]->logRec('dbmTableClose',$_[1]);
2299
0
foreach my $k (keys %{$CACHE->{$_[0]}}) {
0
2300
0
0
next if $k !~/^-dbm\//;
2301
0
dbmTableClose($_[0], $')
2302
}
2303
0
return($_[0])
2304
}
2305
0
0
return($_[0]) if !$CACHE->{$_[0]}->{'-dbm/' .$_[1]};
2306
# $_[0]->logRec('dbmTableClose',$_[1]);
2307
0
$CACHE->{$_[0]}->{'-dbm/' .$_[1]}->close();
2308
0
delete $CACHE->{$_[0]}->{'-dbm/' .$_[1]};
2309
0
$_[0]
2310
}
2311
2312
2313
sub dbmTableFlush { # Reopen isam datafile object if opened
2314
0
0
0
0
return(&{$_[0]->{-die}}('Bad table \'' .$_[1] .'\'' .$_[0]->{-ermd})) if !$_[1];
0
2315
0
0
if ($_[1] eq '*') {
2316
# $_[0]->logRec('dbmTableFlush',$_[1]);
2317
0
foreach my $k (keys %{$CACHE->{$_[0]}}) {
0
2318
0
0
next if $k !~/^-dbm\//;
2319
0
dbmTableFlush($_[0], $')
2320
}
2321
0
return($_[0])
2322
}
2323
0
0
return($_[0]) if !$CACHE->{$_[0]}->{'-dbm/' .$_[1]};
2324
# $_[0]->logRec('dbmTableFlush',$_[1]);
2325
0
$CACHE->{$_[0]}->{'-dbm/' .$_[1]}->close();
2326
0
$CACHE->{$_[0]}->{'-dbm/' .$_[1]}->opent();
2327
}
2328
2329
2330
2331
sub osCmd { # OS Command
2332
# -'i'gnore retcode
2333
0
0
1
my $s =shift;
2334
0
0
my $opt =substr($_[0],0,1) eq '-' ? shift : '';
2335
0
0
my $sub =ref($_[$#_]) eq 'CODE' ? pop : undef;
2336
0
my $r;
2337
my $o;
2338
0
local(*RDRFH, *WTRFH);
2339
0
$s->logRec('osCmd', @_);
2340
0
0
0
if (($^O eq 'MSWin32') # !!! arguments may need to be quoted
2341
|| ($^X =~/(?:perlis|perlex)\d*\.dll$/i)) { # ISAPI, DB_File operation problem hacks
2342
0
0
if (!$sub) {
2343
0
0
0
if (($opt !~/h/)
0
2344
&& ($^X =~/(?:perlis|perlex)\d*\.dll$/i
2345
? $_[0] !~/^(?:xcopy|xcacls|cacls)/ # !!! problematic programs
2346
: 1)
2347
) {
2348
0
my $c =join(' ', @_) .' 2>&1';
2349
0
$o =[`$c`];
2350
}
2351
else {
2352
0
0
eval('Win32::SetChildShowWindow(0)') if $] >=5.008;
2353
0
0
if (system(@_) ==-1) {
2354
0
$o =[$!,$^E];
2355
0
$r =-1;
2356
}
2357
0
0
eval('Win32::SetChildShowWindow()') if $] >=5.008;
2358
}
2359
}
2360
else { # !!! command's output will be lost
2361
open(WTRFH, '|-', join(' ', @_) .' >nul 2>&1') && defined(*WTRFH)
2362
0
0
0
|| return(&{$_[0]->{-die}}(join(' ',$s->lng(0,'osCmd'),@_) .' -> ' .$! .$_[0]->{-ermd})||0);
0
2363
0
my $ls =select(); select(WTRFH); $| =1;
0
0
2364
0
0
&$sub($s) if $sub;
2365
0
select($ls);
2366
0
eval{close(WTRFH)};
0
2367
}
2368
}
2369
else {
2370
0
eval('use IPC::Open2');
2371
0
my $pid = IPC::Open2::open2(\*RDRFH, \*WTRFH, @_);
2372
0
0
if ($pid) {
2373
0
0
if ($sub) {
2374
0
my $select =select();
2375
0
select(WTRFH);
2376
0
$| =1;
2377
0
&$sub($s);
2378
0
select($select);
2379
}
2380
0
0
$o =[] if $opt !~/h/;
2381
0
waitpid($pid,0);
2382
}
2383
else {
2384
0
$o =[$!,$^E];
2385
0
$r =-1;
2386
}
2387
}
2388
0
0
$r =$?>>8 if !$r;
2389
0
0
0
if ($r && ($r >0) && ($opt =~/i/)) {
0
2390
0
0
if (!$o){$o =['exit ' .$r]}
0
0
2391
else {push @$o, 'exit ' .$r}
2392
}
2393
return(&{$s->{-die}}(join(' ',$s->lng(0,'osCmd'),@_)
2394
0
0
0
.(!$o ? ' ' : join("\n", ' -> ', @{$o||[]}, ''))
0
2395
."-> $r"
2396
.$s->{-ermd})||0)
2397
if $r && $opt !~/i/;
2398
0
0
if ($o) {foreach my $e (@$o) {
0
2399
0
chomp($e);
2400
0
$s->logRec('osCmd',$e)
2401
}}
2402
0
0
0
!$r ? $o ||[] : undef
2403
}
2404
2405
2406
sub nfopens { # opened files (`net file`)
2407
# (mask, ?container)
2408
0
0
0
0
return(undef) if $^O ne 'MSWin32';
2409
0
0
my $rc =$_[2]||[];
2410
0
0
my $mask =$_[1]||''; $mask =~s/\//\\/ig;
0
2411
#[map {chomp($_); $_} map {/^\d+\s+(.+)\s+\d+[\n\r\s]*$/ ? $1 : $_} grep /^\d+\s*\Q$mask\E/i, `net file`]
2412
my $o =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); Win32::OLE->GetObject("WinNT://'
2413
0
0
.(eval{Win32::NodeName()}||$ENV{COMPUTERNAME}) .'/lanmanserver")');
2414
0
0
return(undef) if !$o;
2415
0
0
if (ref($rc) eq 'HASH') {
2416
0
%$rc =map {(substr($_->{Path}, length($mask)+1), $_->{User} .': ' .substr($_->{Path}, length($mask)+1))
2417
0
0
} grep {(eval{$_->{Path}}||'') =~/^\Q$mask\E/i
0
2418
} Win32::OLE::in($o->Resources());
2419
# %$rc =(1=>'1.1',2=>'2.1',3=>'3.1');
2420
0
0
$rc =undef if !%$rc
2421
}
2422
else {
2423
0
@$rc =map {eval{substr($_->{Path}, length($mask)+1)}
0
2424
0
0
} grep {(eval{$_->{Path}}||'') =~/^\Q$mask\E/i # $_->GetInfo;
0
2425
} Win32::OLE::in($o->Resources());
2426
0
0
$rc =undef if !@$rc
2427
}
2428
0
$rc
2429
}
2430
2431
2432
sub nfclose { # close opened files (`net file /close`)
2433
# (mask, [filelist])
2434
0
0
0
0
return(0) if $^O ne 'MSWin32';
2435
0
0
my $mask =$_[1]||''; $mask =~s/\//\\/ig;
0
2436
0
0
my $list =$_[2]||[];
2437
my $o =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); Win32::OLE->GetObject("WinNT://'
2438
0
0
.(eval{Win32::NodeName()}||$ENV{COMPUTERNAME}) .'/lanmanserver")');
2439
0
0
return(0) if !$o;
2440
0
0
0
foreach my $f (grep {$_ && (eval{$_->{Path}}||'')=~/^\Q$mask\E/i
0
2441
} Win32::OLE::in($o->Resources())) {
2442
0
0
my $n =eval{$f->{Path} =~/^\Q$mask\E[\\\/]*(.+)/i ? $1 : undef};
0
2443
0
0
0
next if !$n || !grep /^\Q$n\E$/i, @$list;
2444
0
$_[0]->osCmd('net','file',$f->{Name},'/close');
2445
}
2446
1
2447
0
}
2448
2449
2450
sub output { # Output to user, like print, but redefinable
2451
0
0
0
1
(!$_[0]->{-output} ? print @_[1..$#_] : &{$_[0]->{-output}}(@_))
0
0
2452
&& $_[0]
2453
}
2454
2455
2456
sub outhtm { # Output HTML tag
2457
0
0
1
output($_[0], htlsTag(@_))
2458
}
2459
2460
sub outhtml { # Output HTML tag
2461
0
0
1
output($_[0], htlsTag(@_))
2462
}
2463
2464
2465
sub outxml { # Output XML tag
2466
0
0
1
output($_[0], xmlsTag(@_))
2467
}
2468
2469
2470
sub smtp { # SMTP object
2471
# (| undef | sub{})
2472
0
0
0
0
1
if (!$_[0]->{-smtp}) {}
0
0
2473
elsif ((scalar(@_) >1) && !$_[1]) {
2474
0
0
$_[0]->{-smtp}->quit() if $_[0]->{-smtp};
2475
0
delete $_[0]->{-smtp};
2476
}
2477
elsif ($_[0]->{-smtp}) {
2478
0
0
if (ref($_[1])) {
2479
0
local $^W=undef;
2480
0
return(&{$_[1]}($_[0],$_[0]->{-smtp}));
0
2481
}
2482
0
0
return($_[0]->{-smtp}) if $_[0]->{-smtp};
2483
}
2484
0
$_[0]->{-smtp} =eval {
2485
0
local $^W=undef;
2486
0
eval("use Net::SMTP");
2487
0
0
$_[0]->{-smtphost}
2488
? Net::SMTP->new($_[0]->{-smtphost})
2489
: CORE::die('name required')
2490
};
2491
0
0
0
return(&{$_[0]->{-die}}("SMTP host '" .$_[0]->{-smtphost} ."': $@\n"))
0
2492
if !$_[0]->{-smtp} ||$@;
2493
0
0
return(&{$_[1]}($_[0],$_[0]->{-smtp})) if ref($_[1]);
0
2494
0
$_[0]->{-smtp};
2495
}
2496
2497
2498
sub smtpAdr { # SMTP address translate
2499
0
0
0
0
0
($_[1] =~/^([^\\]+)\\(.+)$/
0
2500
? $2
2501
: $_[1])
2502
.((index($_[1],'@') <0) && $_[0]->{-smtpdomain}
2503
? '@' .$_[0]->{-smtpdomain}
2504
: '')
2505
}
2506
2507
2508
sub smtpAdrd { # SMTP address displayable translate
2509
0
0
0
0
return($_[1]) if $_[1] =~/;
2510
0
0
my $d =$_[0]->udisp($_[1]) ||$_[1];
2511
0
0
unless ($d =~s/<([^<>]+)>/'<' .$_[0]->smtpAdr($_[1]) .'>'/e) {
0
2512
0
$d .=' <' .$_[0]->smtpAdr($_[1]) .'>'
2513
}
2514
$d
2515
0
}
2516
2517
2518
sub smtpSend { # SMTP mail msg send
2519
0
0
1
my ($s, %a) =@_;
2520
0
0
return($s) if !$s->{-smtphost};
2521
0
0
local $s->{-smtpdomain} =$s->{-smtpdomain}
2522
0
0
|| ($s->{-smtphost} && $s->smtp(sub{$_[1]->domain()}))
2523
|| 'nothing.net';
2524
0
0
local $s->{-pcmd} =$s->{-pcmd} ||{};
2525
0
local $s->{-pcmd}->{-frame} =undef;
2526
0
0
$a{-from} =$a{-from} ||$a{-sender} ||$s->user;
2527
0
0
$a{-from} =&{$a{-from}}($s,\%a) if ref($a{-from}) eq 'CODE';
0
2528
0
$a{-from} =$s->smtpAdrd($a{-from});
2529
0
0
$a{-to} =&{$a{-to}}($s,\%a) if ref($a{-to}) eq 'CODE';
0
2530
0
0
0
$a{-to} =[grep {$_} split /\s*[,;]\s*/, ($a{-to} =~/^\s*(.*)\s*$/ ? $1 : $a{-to})]
0
0
0
2531
if $a{-to} && !ref($a{-to}) && ($a{-to} =~/[,;]/);
2532
0
$a{-to} =ref($a{-to})
2533
0
0
? [map {$s->smtpAdrd($_)} @{$a{-to}}]
0
0
2534
: $s->smtpAdrd($a{-to})
2535
if $a{-to};
2536
0
0
$a{-sender} =$s->smtpAdr($a{-sender} ||$a{-from} ||$s->user);
2537
0
0
$a{-recipient} =$a{-recipient} ||$a{-to};
2538
0
0
$a{-recipient} =&{$a{-recipient}}($s,\%a) if ref($a{-recipient}) eq 'CODE';
0
2539
0
0
0
$a{-recipient} =[grep {$_} split /\s*[,;]\s*/, ($a{-recipient} =~/^\s*(.*)\s*$/ ? $1 : $a{-recipient})]
0
0
0
2540
if $a{-recipient} && ref($a{-recipient}) && ($a{-recipient} =~/[,;]/);
2541
0
0
return($s) if !$a{-recipient};
2542
0
$a{-recipient} =ref($a{-recipient})
2543
0
0
? [map {$s->smtpAdr($_)} @{$a{-recipient}}]
0
2544
: $s->smtpAdr($a{-recipient});
2545
0
0
if (!defined($a{-data})) {
2546
0
0
my $koi =(($a{-charset}||$s->charset()) =~/1251/);
2547
0
$a{-subject} = ref($a{-subject}) eq 'CODE'
2548
0
0
? &{$a{-subject}}($s,\%a)
2549
: ref($a{-subject})
2550
? join(' ', map {
2551
0
!defined($a{-pout}->{$_})
2552
? ()
2553
: ($a{-pout}->{$_})
2554
0
0
0
} @{$a{-subject}})
0
0
0
2555
: $a{-pout}
2556
? $s->mdeSubj($a{-pout})
2557
: ''
2558
if ref($a{-subject}) ||!defined($a{-subject});
2559
0
$a{-data} ='';
2560
0
0
$a{-data} .='From: ' .($koi ? $s->cptran('ansi','koi',$a{-from})
2561
: $a{-from})
2562
."\cM\cJ";
2563
0
0
$a{-data} .='Subject: '
2564
.($koi
2565
? $s->cptran('ansi','koi',$a{-subject})
2566
: $a{-subject}) ."\cM\cJ";
2567
0
$a{-data} .='To: '
2568
.($koi
2569
0
? $s->cptran('ansi','koi', ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to})
2570
0
0
: (ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}))
0
0
0
2571
."\cM\cJ"
2572
if $a{-to};
2573
0
$a{-data} .="MIME-Version: 1.0\cM\cJ";
2574
0
0
0
$a{-data} .='Content-type: ' .($a{-pout} ||$a{-html} ? 'text/html' : 'text/plain')
0
2575
.'; charset=' .($a{-charset}||$s->charset())
2576
."\cM\cJ";
2577
0
0
$a{-data} .='Content-Transfer-Encoding: ' .($a{-encoding} ||'8bit') ."\cM\cJ";
2578
0
$a{-data} .="\cM\cJ";
2579
0
0
if ($a{-pout}) {
2580
0
0
$a{-form} =$a{-form} || $a{-pcmd} && ($a{-pcmd}->{-form} ||$a{-pcmd}->{-table});
2581
0
$a{-data} .=do{ local $s->{-c}->{-httpheader} =1;
0
2582
# local $s->{-htmlstart} ={ref($s->{-htmlstart}) ? %{$s->{-htmlstart}} : (), -xbase=>$s->url};
2583
0
$s->htmlStart($a{-form})};
2584
0
$a{-data} .=' ' ."\n";
2585
0
0
local $s->{-output} =sub{$a{-data} .=join('',@_[1..$#_])};
0
2586
# local $a{-pout} ={%{$a{-pout}}}; # read-only supposed
2587
0
0
local $a{-pcmd} ={($a{-pcmd} ? %{$a{-pcmd}} : ())
0
2588
, -edit=>undef, -print=>1, -mail=>1
2589
, -cmd=>'recRead', -cmg=>'recRead'};
2590
0
local $s->{-pout} =$a{-pout};
2591
0
local $s->{-pcmd} =$a{-pcmd};
2592
0
0
$s->cgiForm($a{-form}
2593
, $a{-pcmd}->{-cmdf} ||$a{-pcmd}->{-cmdt}
2594
, $a{-pcmd}
2595
, $a{-pout}
2596
);
2597
0
$a{-data} .=$s->htmlEnd();
2598
}
2599
0
0
$a{-data} .=$a{-html} ||$a{-text} ||'';
2600
# $s->logRec('smtpSend',%a);
2601
# $s->logRec('smtpSend',$a{-data});
2602
}
2603
0
0
return($s) if !$s->{-smtphost};
2604
0
$s->logRec('smtpSend',$a{-recipient});
2605
0
local $^W=undef;
2606
0
$s->smtp->mail($a{-sender} =~/<\s*([^<>]+)\s*>/ ? $1 : $a{-sender})
2607
0
0
||return(&{$_[0]->{-die}}("SMTP sender \'" .$a{-sender} ."'" .$_[0]->{-ermd}));
0
2608
0
0
0
$s->smtp->to(ref($a{-recipient})
2609
0
? (map { $_ && /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})
0
2610
: $a{-recipient})
2611
0
0
||return(&{$_[0]->{-die}}("SMTP recipient \'"
0
0
2612
.(ref($a{-recipient}) ? join(', ',$a{-recipient}) : $a{-recipient}) ."'" .$_[0]->{-ermd}));
2613
0
$s->smtp->data($a{-data})
2614
0
0
||return(&{$_[0]->{-die}}("SMTP data \'" .$a{-data} ."'" .$_[0]->{-ermd}));
2615
0
$s->smtp->dataend()
2616
0
0
||return(&{$_[0]->{-die}}("SMTP dataend" .$_[0]->{-ermd}));
2617
0
$s;
2618
}
2619
2620
2621
2622
#########################################################
2623
# Filesystem methods
2624
#########################################################
2625
2626
2627
sub pthForm { # Form filesystem path for 'tmp'|'log'|'var'|'dbm'|'rfa'
2628
0
0
0
1
join('/', $_[0]->{-c}->{'-pth_' .$_[1]} ||pthForm_(@_), @_[2..$#_]);
2629
}
2630
2631
2632
sub pthForm_{
2633
0
0
0
0
my $p =($_[0]->{-c}->{'-pth_' .$_[1]}
2634
=($_[1] eq 'tmp' && ($ENV{TMP} ||$ENV{tmp} ||$ENV{TEMP} ||$ENV{temp}))
2635
||($_[0]->{-cgibus} && ($_[1] eq 'rfa') && $_[0]->{-cgibus})
2636
||join('/', $_[0]->{-path}, $_[1]));
2637
0
0
if (!-d $p) {
2638
0
0
0
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
2639
0
$_[0]->pthMk($p);
2640
0
0
$_[0]->hfNew('+>', "$p/.htaccess")->lock(LOCK_EX)
2641
->store("\nOrder Deny,Allow\nDeny from All\n \n")
2642
->destroy
2643
if $_[1] ne 'rfa';
2644
0
0
0
if ($ENV{OS} && $ENV{OS}=~/Windows_NT/i) {
2645
0
$p =~s/\//\\/g;
2646
0
0
$_[0]->osCmd($_[0]->{-w32xcacls} ? 'xcacls' : 'cacls'
2647
,"\"$p\""
2648
,'/T','/C'
2649
,'/E' # for 'rfa' or late $_[0]->{-w32IISdpsn}
2650
,'/G'
2651
0
,(map{(m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_) .':F'
2652
} ref($_[0]->{-fswtr})
2653
? (@{$_[0]->{-fswtr}})
2654
0
0
: ($_[0]->{-fswtr}||eval{Win32::LoginName()}))
2655
,$_[0]->{-w32xcacls}
2656
? '/Y'
2657
: sub{CORE::print "Y\n"})
2658
0
0
0
}
0
0
2659
}
2660
0
$_[0]->{-c}->{'-pth_' .$_[1]}
2661
}
2662
2663
2664
sub pthMk { # Create directory if needed
2665
0
0
0
1
return(1) if -d $_[1];
2666
0
0
0
return(&{$_[0]->{-die}}($_[0]->lng(0,'pthMk') .": mkdir('" .$_[1] ."')" .$_[0]->{-ermd})||0)
2667
if ref($_[1]);
2668
0
0
my $m =$_[1] =~/([\\\/])/ ? $1 : '/';
2669
0
0
my ($a, $v) =$_[1] =~/^([\\\/]+[^\\\/]+[\\\/]|\w:[\\\/]+)(.+)/ ? ($1, $2) : ('', $_[1]);
2670
0
foreach my $e (split /[\\\/]/, $v) {
2671
0
$a .=$e;
2672
0
0
if (!-d $a) {
2673
0
0
0
$_[0]->logRec('mkdir', $a) if !$_[0]->{-log} ||ref($_[0]->{-log});
2674
0
0
0
mkdir($a, 0777) ||return(&{$_[0]->{-die}}($_[0]->lng(0,'pthMk') .": mkdir('$a') -> $!" .$_[0]->{-ermd})||0);
2675
}
2676
0
$a .=$m
2677
}
2678
0
2;
2679
}
2680
2681
2682
sub pthGlob { # Glob directory
2683
0
0
1
my $s =shift;
2684
0
my @ret;
2685
0
0
if (0 && ($^O ne 'MSWin32')) {
2686
CORE::glob(@_)
2687
}
2688
0
elsif (-e $_[0]) {
2689
0
push @ret, $_[0];
2690
@ret
2691
0
}
2692
else {
2693
0
0
my $msk =($_[0] =~/([^\/\\]+)$/i ? $1 : '');
2694
0
my $pth =substr($_[0],0,-length($msk));
2695
0
$msk =~s/\*\.\*/*/g;
2696
0
$msk =~s:(\(\)[].+^\-\${}[|]):\\$1:g;
2697
0
$msk =~s/\*/.*/g;
2698
0
$msk =~s/\?/.?/g;
2699
0
local (*DIR, $_);
2700
opendir(DIR, $pth eq '' ? './' : $pth)
2701
0
0
0
|| return(&{$s->{-die}}($s->lng(0,'pthGlob') .": opendir('$pth') -> $! ($^E)" .$s->{-ermd})||0);
0
2702
0
while(defined($_ =readdir(DIR))) {
2703
0
0
0
next if $_ eq '.' || $_ eq '..' || $_ !~/^$msk$/i;
0
2704
0
push @ret, "${pth}$_";
2705
}
2706
0
0
0
closedir(DIR) || return(&{$s->{-die}}($s->lng(0,'pthGlob') .": closedir('$pth') -> $!" .$s->{-ermd})||0);
2707
@ret
2708
0
}
2709
}
2710
2711
2712
sub pthGlobn { # Glob filenames only
2713
0
0
0
1
map {$_ =~/[\\\/]([^\\\/]+)$/ ? $1 : $_} shift->pthGlob(@_)
0
2714
}
2715
2716
2717
sub pthGlobns { # Glob filenames sorted
2718
1
1
1038
use locale;
1
239
1
7
2719
0
0
0
map {$_ =~/[\\\/]([^\\\/]+)$/ ? $1 : $_
0
0
0
0
2720
0
0
0
} sort { (-d $a) && (!-d $b)
2721
? -1
2722
: (!-d $a) && (-d $b)
2723
? 1
2724
: lc($a) cmp lc($b)
2725
} $_[0]->pthGlob(@_[1..$#_])
2726
}
2727
2728
2729
sub pthRm { # Remove filesystem path
2730
# '-r' - recurse subdirectories, 'i'gnore errors
2731
0
0
1
my $s =shift;
2732
0
0
0
my $opt =$_[0] =~/^\-/ || $_[0] eq '' ? shift : '';
2733
0
my $ret =1;
2734
0
$s->logRec('pthRm',$opt,@_);
2735
0
foreach my $par (@_) {
2736
0
foreach my $e ($s->pthGlob($par)) {
2737
0
0
0
if (-d $e) {
0
2738
0
0
0
if ($opt =~/r/i && !$s->pthRm($opt,"$e/*")) {
0
2739
0
$ret =0
2740
}
2741
elsif (!rmdir($e)) {
2742
0
$ret =0;
2743
0
0
0
$opt =~/i/i || return(&{$_[0]->{-die}}($s->lng(0, 'pthRm') .": rmdir('$e') -> $!" .$_[0]->{-ermd})||0);
2744
}
2745
}
2746
elsif (-f $e && !unlink($e)) {
2747
0
$ret =0;
2748
0
0
0
$opt =~/i/i || return(&{$_[0]->{-die}}($s->lng(0, 'pthRm') .": unlink('$e') -> $!" .$s->{-ermd})||0);
2749
}
2750
}
2751
}
2752
$ret
2753
0
}
2754
2755
2756
sub pthCln { # Clean unused (empty) directory
2757
0
0
0
1
return(0) if !-d $_[1];
2758
0
my ($s, $d) =@_;
2759
0
my @g =$s->pthGlob("$d/*");
2760
0
0
0
return(0) if scalar(@g) >1
0
2761
|| scalar(@g) ==1 && $g[0] !~/\.htaccess$/i;
2762
0
foreach my $f (@g) { unlink($f) };
0
2763
0
0
0
while ($d && rmdir($d)) { $d =($d =~m/^(.+)[\\\/][^\\\/]+$/ ? $1 : '') };
0
2764
0
!-d $d
2765
}
2766
2767
2768
sub pthStamp { # Stamp filesystem path with system ACL, once
2769
0
0
0
0
return($_[1]) if $^O ne 'MSWin32';
2770
0
my ($s, $p) =@_;
2771
0
$p =~s/\//\\/g;
2772
0
0
0
return($p) if lc($s->{-c}->{-pthStamp} ||'') eq lc($p);
2773
0
if (1 || $s->{-c}->{-RevertToSelf}) { # ownership
2774
0
eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0);');
2775
0
$s->logRec('TakeOwnerShip', 'winmgmts:Win32_Directory.Name', $p);
2776
0
my $ow =Win32::OLE->GetObject("winmgmts:{impersonationLevel=Impersonate}!root/CIMV2:Win32_Directory.Name='$p'");
2777
0
0
$s->logRec("Error Win32::OLE::GetObject() -> " .Win32::OLE->LastError())
2778
if !$ow;
2779
0
0
$ow =$ow && $ow->TakeOwnerShip();
2780
0
0
$s->logRec("Error TakeOwnerShip() -> $ow")
2781
if $ow;
2782
}
2783
0
0
$s->osCmd($s->{-w32xcacls} ? 'xcacls' : 'cacls'
2784
, "\"$p\"", '/T','/C','/G'
2785
0
0
,(map { $_ =~/\s/ ? "\"$_\"" : $_
2786
0
} map{(m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_) .':F'
2787
0
0
} ref($s->{-fswtr}) ? (@{$s->{-fswtr}}) : ($s->{-fswtr} ||eval{Win32::LoginName()}))
2788
,$s->{-fsrdr}
2789
0
0
?(map { $_ =~/\s/ ? "\"$_\"" : $_
2790
0
} map{(m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_) .':R'
2791
0
0
} ref($s->{-fsrdr}) ? (@{$s->{-fsrdr}}) : ($s->{-fsrdr}))
2792
:()
2793
,$s->{-w32xcacls}
2794
? '/Y'
2795
0
0
0
: sub{CORE::print "Y\n"});
0
0
0
0
2796
0
$s->{-c}->{-pthStamp} =lc($p);
2797
0
$p
2798
}
2799
2800
2801
sub pthCp { # Copy filesystem path
2802
# -'d'irectory or '*' glob hint; 'r'ecurse subdirectories,
2803
# 'i'gnore errors, 'p'ermission stamp
2804
# file -> file # file -> dir/file # dir -> dir/dir # dir/* -> dir
2805
0
0
0
0
1
my ($s, $opt, $src, $dst) =defined($_[1]) && ($_[1] =~/^-/) ? @_ : ($_[0], '', @_[1..$#_]);
2806
0
0
0
my $mc =($src =~/([\\\/])/) || ($dst =~/([\\\/])/) ? $1 : '/';
2807
0
my $r =1;
2808
0
$s->logRec('pthCp',$opt,$src,$dst);
2809
0
0
if ($opt !~/d/i) {}
0
0
2810
0
elsif ($opt !~/i/i) {
2811
0
$s->pthMk($dst)
2812
}
2813
elsif (!eval{$s->pthMk($dst)}) {
2814
0
$s->logRec('Warn',$s->lng(0, 'pthCp') .": $@");
2815
0
return(0)
2816
}
2817
0
0
if (-f $src) {
2818
0
0
0
my $d1 =($opt =~/d/i) || (-d $dst)
0
2819
? $dst .$mc .($src =~/[\\\/]([^\\\/]+)$/ ? $1 : $src)
2820
: $dst;
2821
0
0
unlink($d1) if (-e $d1);
2822
0
0
0
if ($^O eq 'MSWin32'
0
0
2823
? Win32::CopyFile($src, $d1, 1)
2824
: (eval('use File::Copy (); 1') && File::Copy::syscopy($src, $d1))
2825
) {}
2826
elsif ($opt =~/i/) {
2827
0
$r =0;
2828
0
$s->logRec('Warn', $s->lng(0, 'pthCp') .": FileCopy('$src', '$d1') -> $!")
2829
}
2830
else {
2831
0
0
return(&{$s->{-die}}($s->lng(0, 'pthCp') .": FileCopy('$src', '$d1') -> $!" .$s->{-ermd})||0)
2832
}
2833
0
return($r);
2834
}
2835
0
0
0
if (($opt =~/p/i) && ($opt =~/d/i)) {
2836
0
$s->pthStamp($dst);
2837
}
2838
0
0
0
foreach my $s1 ($s->pthGlob(($opt =~/\*/)
2839
&& !(($src =~/([^\\\/]+)$/) && ($1 =~/\*/))
2840
? $src .$mc .'*'
2841
: $src)) {
2842
0
0
my $d1 =$dst .$mc .($s1 =~/[\\\/]([^\\\/]+)$/ ? $1 : $s1);
2843
0
0
if (-d $s1) {
2844
0
0
next if $opt !~/r/i;
2845
0
0
$r =0 if !$s->pthCp('-rd*' .($opt =~/i/i ? 'i' : ''), $s1, $d1);
0
2846
}
2847
else {
2848
# $s->logRec('copy',$s1,$d1);
2849
0
0
unlink($d1) if -e $d1;
2850
0
0
0
if ($^O eq 'MSWin32'
0
0
2851
? Win32::CopyFile($s1, $d1, 1)
2852
: (eval('use File::Copy (); 1') && File::Copy::syscopy($s1, $d1))) {
2853
}
2854
elsif ($opt =~/i/) {
2855
0
$r =0;
2856
0
$s->logRec('Warn',$s->lng(0, 'pthCp') .": FileCopy('$src', '$d1') -> $!")
2857
}
2858
else {
2859
0
0
return(&{$s->{-die}}($s->lng(0, 'pthCp') .": FileCopy('$src', '$d1') -> $!" .$s->{-ermd})||0)
2860
}
2861
}
2862
}
2863
$r
2864
0
}
2865
2866
2867
2868
#########################################################
2869
# Variables & Logging Methods
2870
#########################################################
2871
2872
2873
sub varFile { # Common variables filename
2874
0
0
1
$_[0]->pthForm('var','var.pl');
2875
}
2876
2877
2878
sub varLoad { # Load common variables
2879
0
0
1
my ($s, $lck) =@_;
2880
0
0
0
return($s->{-var}) if $s->{-var} && !$lck;
2881
0
0
0
$s->{-var}->{'_handle'}->destroy if $s->{-var} && $s->{-var}->{'_handle'};
2882
0
$s->{-var} =undef;
2883
0
my $fn =$s->varFile;
2884
0
my $hf;
2885
0
0
if (!-f $fn) {
2886
0
$s->{-var} ={'id'=>'DBIx-Web-variables'};
2887
0
$s->varStore();
2888
}
2889
# $s->logRec('varLoad', $lck ? ($lck) : (LOCK_SH, $lck));
2890
0
0
$hf =$s->hfNew('+<',$fn)->lock($lck||LOCK_SH);
2891
0
0
$s->{-var} =$hf->{-buf} =$hf->load && $s->dsdParse($hf->{-buf});
2892
0
$s->{-var}->{'_handle'} =$hf;
2893
0
0
if (!$lck) {
2894
# $hf->lock(LOCK_UN |LOCK_NB);
2895
# $hf->close(); # auto LOCK_UN, auto reopen
2896
0
$hf->destroy(); delete $s->{-var}->{'_handle'};
0
2897
}
2898
$s
2899
0
}
2900
2901
2902
sub varLock { # Lock common variables file
2903
0
0
0
0
1
if (!$_[0]->{-var} ||!$_[0]->{-var}->{'_handle'}) {
0
0
0
0
2904
0
0
$_[0]->varLoad($_[1] ||LOCK_EX)
2905
}
2906
elsif ((($_[1] ||LOCK_EX) eq LOCK_EX)
2907
&& (($_[0]->{-var}->{'_handle'}->{-lock} ||0) ne LOCK_EX) ){
2908
0
0
$_[0]->varLoad($_[1] ||LOCK_EX)
2909
}
2910
else {
2911
# $_[0]->logRec('varLock',$_[1] ||LOCK_EX);
2912
0
0
$_[0]->{-var}->{'_handle'}->lock($_[1] ||LOCK_EX)
2913
}
2914
}
2915
2916
2917
sub varStore { # Store common variables
2918
0
0
1
my $s =shift;
2919
0
0
0
my $hf = !$s->{-var} ||!$s->{-var}->{'_handle'}
2920
? $s->hfNew('+>',$s->varFile)
2921
: $s->{-var}->{'_handle'};
2922
0
delete($s->{-var}->{'_handle'});
2923
2924
0
$hf->lock(LOCK_EX)->store($s->dsdMk($s->{-var}))->close();
2925
2926
0
$hf->{-buf} =$s->{-var};
2927
0
$s->{-var}->{'_handle'} =$hf;
2928
0
$s
2929
}
2930
2931
2932
sub logOpen { # Log File open
2933
0
0
0
1
return($_[0]->{-log}) if ref($_[0]->{-log});
2934
0
my $fn =$_[0]->pthForm('log','cmdlog.txt');
2935
0
$_[0]->{-log} =$_[0]->hfNew('+>>', $fn);
2936
0
0
$_[0]->{-log}->select(sub{$|=1});
0
2937
0
$_[0]->{-log}
2938
}
2939
2940
2941
sub logLock { # Log File lock
2942
0
0
0
1
$_[0]->logOpen if !ref($_[0]->{-log});
2943
0
$_[0]->{-log}->lock(@_[1..$#_]);
2944
}
2945
2946
2947
sub logRec { # Add record to log file
2948
0
0
0
0
1
return(1) if !$_[0]->{-log} && !$_[0]->{-logm};
2949
0
0
0
$_[0]->logOpen() if $_[0]->{-log} && !ref($_[0]->{-log});
2950
0
0
0
$_[0]->{-log}->print(strtime($_[0]),"\t"
2951
,$_[0]->{-c} && $_[0]->{-c}->{-user} ||'unknown'
2952
,"\t",logEsc($_[0],@_[1..$#_]),"\n") if $_[0]->{-log};
2953
0
0
0
$_[0]->{-c}->{-logm} =[] if $_[0]->{-logm} && !$_[0]->{-c}->{-logm};
2954
0
0
0
splice @{$_[0]->{-c}->{-logm}}, 2, 2, '...' if $_[0]->{-logm} && scalar(@{$_[0]->{-c}->{-logm}}) >$_[0]->{-logm};
0
0
2955
0
0
push @{$_[0]->{-c}->{-logm}}, $_[0]->logEsc('('
0
0
2956
.($TW32
2957
? (Win32::GetTickCount() -$TW32)/1000
2958
: (time()-$^T))
2959
.') '. $_[1], @_[2..$#_]) if $_[0]->{-logm};
2960
0
1
2961
}
2962
2963
2964
sub logEsc { # Escape list for logging
2965
0
0
0
my $s =$_[0];
2966
0
my $b =" ";
2967
0
my $r =$_[1] .$b;
2968
0
for (my $i=2; $i <=$#_; $i++) {
2969
0
my $v =$_[$i];
2970
0
$r .= ( !defined($v)
2971
? 'undef,'
2972
: ref($v) eq 'ARRAY'
2973
? '[' .join(', '
2974
0
0
0
,map {strquot($s, $_);
2975
} @$v) .'],'
2976
: isa($v,'HASH')
2977
? '{' .join(', '
2978
0
0
0
,map {(defined($_) && $_ =~/^-\w+[\d\w]*$/
0
0
0
0
0
0
0
2979
? $_
2980
: strquot($s, $_)) .'=>' .strquot($s, $v->{$_})
2981
} sort keys %$v) .'},'
2982
: $v =~/^\d+$/
2983
? $v .','
2984
: $v =~/^-\w+[\d\w]*$/
2985
? $v .'=>'
2986
: ($i ==2) &&($_[1] =~/^dbi/)
2987
&&($v =~/^(?:select|insert|update|delete|drop|commit|rollback|fetch)\s+/i)
2988
? $v .';'
2989
: ($i ==2) &&($_[1] =~/^dbi/) &&($v =~/^(?:keDel|kePut|affected|single|fetch)\b/i)
2990
? $v
2991
: (strquot($s, $v) .',')) .$b
2992
}
2993
0
0
$r =~/^(.+?)[\s,;=>]*$/ ? $1 : $r
2994
}
2995
2996
2997
2998
#########################################################
2999
# User & Group names methods
3000
#########################################################
3001
3002
3003
sub user { # current user name
3004
0
0
0
1
return($_[0]->{-userln} ? userln(@_) : $_[0]->{-c}->{-user})
0
3005
if $_[0]->{-c}->{-user};
3006
0
$_[0]->{-c}->{-user} =
3007
0
0
$_[0]->{-user} ? (ref($_[0]->{-user}) ? &{$_[0]->{-user}}(@_) : $_[0]->{-user})
0
0
3008
: $_[0]->{-unames} ? $_[0]->unames->[0]
3009
: $_[0]->{-tn}->{-guest};
3010
0
0
$_[0]->{-c}->{-user} =
0
0
3011
$_[0]->{-usernt}
3012
? ($_[0]->{-c}->{-user} =~/^([^\@]+)\@(.+)$/ ? $2 .'\\' .$1 : $_[0]->{-c}->{-user})
3013
: ($_[0]->{-c}->{-user} =~/^([^\\]+)\\(.+)$/ ? $2 .'@' .$1 : $_[0]->{-c}->{-user});
3014
#$_[0]->logRec('user', $_[0]->{-c}->{-user});
3015
0
0
$_[0]->{-userln} ? userln(@_) : $_[0]->{-c}->{-user}
3016
}
3017
3018
3019
sub userln { # current user local name
3020
0
0
0
1
return($_[0]->{-c}->{-userln}) if $_[0]->{-c}->{-userln};
3021
0
my $s =$_[0];
3022
0
0
my $un=$s->{-c}->{-user} ||$s->user();
3023
0
0
my ($d, $u) = $un =~/^([^\\]+)\\(.+)$/ ? ($1, $2)
0
3024
: $un =~/^([^\@]+)\@(.+)$/ ? ($2, $1)
3025
: ('', $un);
3026
0
0
0
$s->{-c}->{-userln} =
0
0
3027
!$d
3028
? $u
3029
: $^O eq 'MSWin32' && lc($d) eq lc($s->w32domain())
3030
? $u
3031
: eval('use Sys::Hostname; Sys::Hostname::hostname()') =~/\Q$d\E$/i
3032
? $u
3033
: $un
3034
}
3035
3036
3037
sub uguest { # is current user a guest
3038
0
0
1
lc($_[0]->user()) eq lc($_[0]->{-tn}->{-guest})
3039
}
3040
3041
3042
sub unames { # current user names
3043
0
0
0
1
return($_[0]->{-c}->{-unames}) if $_[0]->{-c}->{-unames};
3044
0
$_[0]->{-c}->{-unames} =
3045
0
0
0
$_[0]->{-unames} ? (ref($_[0]->{-unames}) ? &{$_[0]->{-unames}}(@_) : $_[0]->{-unames})
0
0
0
0
0
3046
: $_[0]->{-user} ? [$_[0]->user()
3047
, !defined($_[0]->{-usernt})
3048
&& ($_[0]->user() =~/^([^\\@]+)([\\@])([^\\@]+)$/)
3049
? ($2 eq '@' ? "$3\\$1"
3050
: "$3\@$1")
3051
: ()
3052
, $_[0]->user() ne $_[0]->userln()
3053
? ($_[0]->userln())
3054
: ()
3055
]
3056
: [$_[0]->{-tn}->{-guest}];
3057
0
$_[0]->logRec('unames', $_[0]->{-c}->{-unames});
3058
0
$_[0]->{-c}->{-unames}
3059
}
3060
3061
3062
sub ugroups { # user groups
3063
# (self, ?user) -> [user's groups]
3064
0
0
0
0
1
return($_[0]->{-c}->{-ugroups})
3065
if !$_[1] && $_[0]->{-c}->{-ugroups};
3066
0
return($_[0]->{-c}->{-ugroups} =ref($_[0]->{-ugroups}) eq 'CODE'
3067
0
0
? &{$_[0]->{-ugroups}}(@_)
0
3068
: $_[0]->{-ugroups})
3069
if $_[0]->{-ugroups};
3070
0
my $s =$_[0];
3071
0
0
my $un=$_[1] ||$s->user();
3072
0
0
my $ul=$_[1] ||$s->userln();
3073
0
my $ug=$CACHE->{-ugroups}->{$un};
3074
0
0
if ($ug) {
3075
0
$s->logRec('ugroups', $un, 'cache', $ug);
3076
0
return($ug);
3077
}
3078
0
my $fn=undef;
3079
0
my $rs='';
3080
0
my $rl='';
3081
0
0
0
if (($fn =$s->{-AuthGroupFile}
0
3082
|| $s->{-PlainGroupFile}
3083
|| (( ($s->{-ldap} && $s->ugfile('ugf_ldap'))
3084
|| ($s->{-w32ldap} && $s->ugfile('ugf_w32ldap'))
3085
|| (($^O eq 'MSWin32') && $s->ugfile('ugf_w32'))
3086
) && $s->pthForm('var','uagroup') )
3087
) && -f $fn) {
3088
0
my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH);
3089
0
$ug =[];
3090
0
while(my $r =$fh->readline()) {
3091
0
0
next if $r !~/[:\s](?:\Q$un\E|\Q$ul\E)(?:\s|\Z)/i;
3092
0
0
next if $r !~/^([^:]+):/;
3093
0
push @$ug, $1
3094
}
3095
0
$fh->close();
3096
0
0
$ug =undef if !@$ug;
3097
}
3098
0
elsif (0 # lost code, for example
3099
&& $s->{-ldap}) {
3100
$ug =$s->ldapUgroups($un);
3101
$ug =undef if $ug && !@$ug;
3102
}
3103
0
0
if ($ug) {
3104
0
$rl ='file';
3105
0
0
$un =($rs =~/^([^:]+):/ ? $1 : $rs) if $rs; # !!! not used
0
3106
}
3107
else {
3108
0
$rl ='default';
3109
0
0
$ug =$s->{-ugadd}
0
3110
? []
3111
: [$s->{-tn}->{-guests}, $s->uguest ? () : ($s->{-tn}->{-users})];
3112
}
3113
0
0
if (!defined($s->{-usernt})) {
0
3114
}
3115
elsif ($s->{-usernt}) {
3116
0
0
$ug =[map {$_ =~/\@/ ? () : $_
0
3117
} @$ug]
3118
}
3119
else {
3120
0
0
$ug =[map {$_ =~/\\/ ? () : $_
0
3121
} @$ug]
3122
}
3123
0
0
if ($s->{-ugflt}) {
3124
0
my $fg =$s->{-ugflt};
3125
0
0
$ug =[map {&$fg($s,$_) ? ($_) : ()
0
3126
} @$ug]
3127
}
3128
0
0
if ($s->{-ugadd}) {
3129
0
local $_ =$ug;
3130
0
0
my $ugadd=ref($s->{-ugadd}) eq 'CODE' ? &{$s->{-ugadd}}($s) : $s->{-ugadd};
0
3131
0
0
foreach my $e ( ref($ugadd) eq 'ARRAY'
0
0
3132
? @{$ugadd}
3133
: ref($ugadd) eq 'HASH'
3134
? keys(%$ugadd)
3135
: $ugadd){
3136
0
0
0
push @$ug, $e
3137
if defined($e)
3138
&& !grep /^\Q$e\E$/i, @$ug;
3139
}
3140
}
3141
0
0
if ($s->{-ugflt1}) {
3142
0
local $_ =$un;
3143
0
&{$s->{-ugflt1}}($s, $un, $ul, $ug);
0
3144
}
3145
0
0
$s->logRec('ugroups', $un, $rl, $ug) if $rl;
3146
0
0
$s->{-c}->{-ugroups} =$ug if !$_[1];
3147
0
if (1 || ($ENV{MOD_PERL} || (($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {
3148
0
0
$CACHE->{-ugroups} ={} if !$CACHE->{-ugroups};
3149
0
0
$CACHE->{-ugroups} ={} if %{$CACHE->{-ugroups}} >200;
0
3150
0
$CACHE->{-ugroups}->{$un} =$ug;
3151
}
3152
$ug
3153
0
}
3154
3155
3156
sub ugnames { # current user and group names
3157
# (self, ?user) -> [user's names]
3158
0
0
0
1
if ($_[1]) {
0
3159
# return([$_[1]]);
3160
0
local $_[0]->{-userln} =0;
3161
0
local $_[0]->{-c}->{-user} =$_[1];
3162
0
local $_[0]->{-c}->{-userln} =undef;
3163
0
local $_[0]->{-c}->{-ugroups} =undef;
3164
0
local $_[0]->{-c}->{-unames} =undef;
3165
0
local $_[0]->{-c}->{-ugrexp} =undef;
3166
0
local $_[0]->{-c}->{-ugnames} =undef;
3167
0
my $r =$_[0]->ugnames();
3168
0
return($r)
3169
}
3170
elsif ($_[0]->{-c}->{-ugnames}) {
3171
0
return($_[0]->{-c}->{-ugnames})
3172
}
3173
0
$_[0]->{-c}->{-ugnames} =[map {$_} @{$_[0]->unames()}, map {$_} @{$_[0]->ugroups()}]
0
0
0
0
3174
}
3175
3176
3177
sub ugrexp { # current user and group names regexp source
3178
0
0
0
1
return($_[0]->{-c}->{-ugrexp}) if $_[0]->{-c}->{-ugrexp};
3179
0
my $n =join('|', @{$_[0]->ugnames()}); $n =~s/([\\.?*\$\@])/\\$1/g;
0
0
3180
0
$_[0]->{-c}->{-ugrexp} =eval('sub{(($_[0]=~/(?:^|,|;)\\s*(' .$n .')\\s*(?:,|;|$)/i) && $1)}')
3181
}
3182
3183
3184
sub ugmember { # user group membership
3185
0
0
0
1
my $e =$_[0]->{-c}->{-ugrexp} ||ugrexp($_[0]);
3186
0
foreach my $i (@_[1..$#_]) {
3187
0
0
0
if (ref($i)) {foreach my $j (@$i) {defined($j) && &$e($j) && return(1)}}
0
0
0
0
0
0
3188
else {defined($i) && &$e($i) && return(1)}
3189
}
3190
undef
3191
0
}
3192
3193
3194
sub uadmin { # user admin groups membership
3195
0
0
1
uadmwtr(@_)
3196
}
3197
3198
3199
sub uadmwtr { # user admin writer groups membership
3200
0
0
0
1
return($_[0]->{-c}->{-uadmwtr}) if exists($_[0]->{-c}->{-uadmwtr});
3201
0
0
$_[0]->{-c}->{-uadmwtr} =$_[0]->{-racAdmWtr} && ugmember($_[0], $_[0]->{-racAdmWtr})
3202
}
3203
3204
3205
sub uadmrdr { # user admin reader groups membership
3206
0
0
0
1
return($_[0]->{-c}->{-uadmrdr}) if exists($_[0]->{-c}->{-uadmrdr});
3207
0
0
$_[0]->{-c}->{-uadmrdr} =$_[0]->{-racAdmRdr} && ugmember($_[0], $_[0]->{-racAdmRdr})
3208
}
3209
3210
3211
sub uglist { # User & Group List
3212
0
0
1
my $s =shift; # self, '-ug<>dc@', ?user|group|filter, ?container
3213
0
0
0
my $o =defined($_[0]) && substr($_[0],0,1) eq '-' ? shift : '-ug';
3214
0
0
my $fc=ref($_[0]) eq 'CODE' ? shift : undef;
3215
0
0
0
my $fm=ref($_[0]) ? undef : $_[0] && $o !~/u/ ? [map {lc($_)} @{$s->ugroups(shift)}] : shift;
0
0
0
3216
0
my $fg=$s->{-ugflt};
3217
0
my $fu=$s->{-unflt};
3218
0
0
my $r =shift ||[];
3219
0
my $fn=undef;
3220
0
local $_;
3221
0
0
0
if ($s->{-uglist}) {
0
0
0
0
0
0
3222
0
$r =&{$s->{-uglist}}($s, $o, $r)
0
3223
}
3224
elsif ($s->{-AuthUserFile} ||$s->{-AuthGroupFile}) {
3225
0
my @r;
3226
my $en;
3227
0
$fn =$s->{-AuthGroupFile};
3228
0
0
0
if ($fm && !ref($fm) && -f $fn) {
0
3229
0
my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH);
3230
0
while(my $r =$fh->readline()) {
3231
0
0
next if $r !~/^\Q$fm\E:/i;
3232
0
$r =$'; chomp($r);
0
3233
0
$fm =[map {lc($_)} split /[\t]+/, $r];
0
3234
0
last;
3235
}
3236
0
$fh->close();
3237
0
0
0
return($r) if !ref($fm) || !@$fm;
3238
}
3239
0
0
0
$fm =undef if $fm && (!ref($fm) || !@$fm);
0
3240
0
$fn =$s->{-AuthUserFile};
3241
0
0
0
if ($o =~/u/ && $fn && -f $fn) {
0
3242
0
my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH);
3243
0
while(my $r =$fh->readline()) {
3244
0
0
next if $r !~/^([^:]+):/;
3245
0
$en =$_ =$1;
3246
0
0
0
next if $fu && !&$fu($s,$en)
0
0
3247
|| $fc && !&$fc($s,$en);
3248
0
0
if ($fm) {
3249
0
my($el, $rl) =(lc($en), undef);
3250
0
0
foreach my $e (@$fm) {if ($el eq $e) {$rl =$el; last}};
0
0
0
3251
0
0
next if !$rl;
3252
}
3253
0
push @r, $en;
3254
}
3255
$fh->close()
3256
0
}
3257
0
$fn =$s->{-AuthGroupFile};
3258
0
0
0
if ($o =~/g/ && $fn && -f $fn) {
0
3259
0
my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH);
3260
0
while(my $r =$fh->readline()) {
3261
0
0
next if $r !~/^([^:]+):/;
3262
0
$en =$_ =$1;
3263
0
0
0
next if $fg && !&$fg($s,$en)
0
0
3264
|| $fc && !&$fc($s,$en);
3265
0
0
if ($fm) {
3266
0
my($el, $rl) =(lc($en), undef);
3267
0
0
foreach my $e (@$fm) {if ($el eq $e) {$rl =$el; last}};
0
0
0
3268
0
0
next if !$rl;
3269
}
3270
0
push @r, $en;
3271
}
3272
$fh->close()
3273
0
}
3274
0
$r =ref($r) eq 'HASH'
3275
0
0
? {map {($_ => $_)} @r}
3276
: [@r]
3277
}
3278
elsif ((
3279
$s->{-PlainUserFile}
3280
||($s->{-ldap} && $s->ugfile('ugf_ldap'))
3281
||($s->{-w32ldap} && $s->ugfile('ugf_w32ldap'))
3282
||($^O eq 'MSWin32' && $s->ugfile('ugf_w32'))
3283
)
3284
&& ($fn =$s->{-PlainUserFile} ||$s->pthForm('var','ualist')) && -f $fn) {
3285
0
0
my $dn=!$s->{-userln}
3286
&& (!($s->{-ldap}) && ($^O eq 'MSWin32') && $s->w32domain());
3287
# see ugfile() for domain name qualifications
3288
0
0
0
if ($fm && !ref($fm)) {
3289
0
0
my $fn=$s->{-PlainGroupFile} ||$s->pthForm('var','uagroup');
3290
0
0
my $vn=!$dn
0
0
3291
? $fm
3292
: $fm =~/^\Q$dn\E\\/i
3293
? $'
3294
: $fm =~/\@\Q$dn\E$/i
3295
? $`
3296
: $fm;
3297
0
0
if (-f $fn) {
3298
0
my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH);
3299
0
while(my $rr =$fh->readline()) {
3300
0
0
next if $rr !~/^\Q$vn\E:/i;
3301
0
$rr =$'; chomp($rr);
0
3302
0
$fm =[map {lc($_)} split /[\t]+/, $rr];
0
3303
0
last;
3304
}
3305
$fh->close()
3306
0
}
3307
0
0
0
return($r) if !ref($fm) || !scalar(@$fm);
3308
}
3309
0
my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH);
3310
0
while(my $rr =$fh->readline()) {
3311
0
my ($en, $ef, $ep, $ec, $ed, $em, $ei)
3312
=(split /\t*:\t+/, $rr); #[0,1,2,3,4,5,6];
3313
# name, fullname, path, class, display, email, description
3314
0
0
if ($fc) {next if !&$fc($s, $en, $ef, $ep, $ed, $em, $ei)}
0
0
0
3315
elsif ($fm) {
3316
0
my($el, $rl) =(lc($en), undef);
3317
0
0
foreach my $e (@$fm) {if ($el eq $e) {$rl =$el; last}};
0
0
0
3318
0
0
next if !$rl;
3319
}
3320
0
0
0
$en =$s->{-usernt}
0
0
0
0
0
0
0
3321
? ($en =~/[\\]/ ? $en : $en =~/^([^\@]+)\@([^\@]+)$/ ? "$2\\$1" : $dn && ($ef=~/\@/) ? "$dn\\$en" : $en)
3322
: ($en =~/[@]/ ? $en : $en =~/^([^\\]+)\\([^\\]+)$/ ? "$2\@$1" : $dn && ($ef=~/\@/) ? "$en\@$dn" : $en);
3323
0
0
0
my $ev =($en =~/[\@\\]/ && $o !~/[<>]/ ? $ef : $en);
3324
0
0
$en =lc($en) if $o =~/d/;
3325
0
$_ =$en;
3326
0
0
0
if ($o =~/g/ && $ec =~/^g/i) {
3327
0
0
0
next if $fg && !&$fg($s, $en, $ef, $ep, $ed, $em, $ei);
3328
0
0
if (ref($r) eq 'ARRAY') {
0
0
3329
0
push(@$r, $en)
3330
}
3331
elsif ($o =~/\@/) {
3332
0
0
0
if ($em) {
0
0
3333
0
$r->{lc $en} =$em
3334
}
3335
elsif (($o =~/c/) && $ei && ($ei =~/\b([\w\d_+-]+\@[\w\d.]+)\b/)) {
3336
0
$r->{lc $en} =$1
3337
}
3338
}
3339
elsif ($ed) {
3340
0
0
$r->{$en} =
3341
$o =~/d/
3342
? $ed
3343
: ($ed.' <' .$ev .'>')
3344
}
3345
else {
3346
0
0
0
$ed =$ei ||$ef if !$ed;
3347
0
0
0
$r->{$en} =
0
0
0
0
0
0
0
3348
!$ed
3349
? $ev
3350
: $ed =~/^\Q$en\E\s*([,.-:]*)\s*(.*)/i
3351
? $ev .(!$2 || ($o =~/d/)
3352
? ''
3353
: (($1 ? " $1 " : ' - ') .$2))
3354
: ($o =~/d/) && ($o =~/c/)
3355
? $ed
3356
: $o =~/[<>]/
3357
? (length($ed)+length($ev)+3 >60
3358
? substr($ed, 0, 60 -length($ev)-6) .'...'
3359
: $ed)
3360
.' <' .$ev .'>'
3361
: "$ev, $ed";
3362
0
0
$r->{$en} =substr($r->{$en},0,60-3) .'...'
3363
if length($r->{$en}) >60 -3;
3364
}
3365
}
3366
0
0
0
if ($o =~/u/ && $ec =~/^u/i) {
3367
0
0
0
next if $fu && !&$fu($s, $en, $ef, $ep, $ed, $em, $ei);
3368
0
0
if (ref($r) eq 'ARRAY') {
0
3369
0
push(@$r, $en)
3370
}
3371
elsif ($o =~/\@/) {
3372
0
0
0
if ($em) {
0
0
3373
0
$r->{lc $en} =$em
3374
}
3375
elsif (($o =~/c/) && $ei && ($ei =~/\b([\w\d_+-]+\@[\w\d.]+)\b/)) {
3376
0
$r->{lc $en} =$1
3377
}
3378
}
3379
else {
3380
0
0
0
$r->{$en} =
0
3381
$o =~/d/
3382
? $ed ||$ef
3383
: (($ed ||$ef).' <' .$ev .'>')
3384
}
3385
}
3386
}
3387
0
$fh->close();
3388
}
3389
elsif (0 && $s->{-ldap}) { # lost code, for example
3390
$r =$s->ldapLst($o, $fc||$fm||'', $r);
3391
}
3392
else {
3393
}
3394
0
0
0
if ($s->{-ugadd} && $r && ($o =~/g/) && ($o !~/\@/)) {
0
0
3395
0
local $_ =$r;
3396
0
0
my $ugadd=ref($s->{-ugadd}) eq 'CODE' ? &{$s->{-ugadd}}($s) : $s->{-ugadd};
0
3397
0
0
0
if ((ref($ugadd) eq 'HASH')
3398
&& (ref($r) eq 'HASH')) {
3399
0
foreach my $e (keys(%$ugadd)) {
3400
0
0
$r->{$e} =$ugadd->{$e} if !$r->{$e};
3401
}
3402
}
3403
else {
3404
0
0
foreach my $e ( ref($ugadd) eq 'ARRAY'
0
0
3405
? @{$ugadd}
3406
: ref($ugadd) eq 'HASH'
3407
? keys(%$ugadd)
3408
: $ugadd){
3409
0
0
if (ref($r) eq 'HASH') {
3410
0
0
$r->{$e} =$e if !$r->{$e}
3411
}
3412
else {
3413
0
0
push @$r, $e if !grep /^\Q$e\E$/i, @$r
3414
}
3415
}
3416
}
3417
}
3418
1
0
1
9108
$r =do{use locale; [sort {lc($a) cmp lc($b)} @$r]} if ref($r) eq 'ARRAY';
1
2
1
6
0
0
0
3419
0
$r
3420
}
3421
3422
3423
sub udisp { # display user name
3424
!defined($_[1]) || $_[1] eq ''
3425
? ''
3426
: $_[0]->{-AuthUserFile}
3427
? $_[1]
3428
: $_[0]->{-c}->{-udisp}
3429
? $_[0]->{-c}->{-udisp}->{lc($_[1])}
3430
||(!$_[0]->{-udispq} && ($^O eq 'MSWin32') && w32udisp(@_))
3431
||$_[1]
3432
: $_[0]->{-udispq} && ref($CACHE) && $CACHE->{-udisp}
3433
0
? do { $_[0]->{-c}->{-udisp} =$CACHE->{-udisp};
3434
0
0
$_[0]->{-c}->{-udisp}->{lc($_[1])} ||$_[1];
3435
}
3436
: ref($_[0]->{-udisp})
3437
0
? do { my $v =&{$_[0]->{-udisp}}(@_);
0
3438
0
0
if (ref($v)) {
3439
0
$_[0]->{-c}->{-udisp} =$v;
3440
0
0
0
$CACHE->{-udisp} =$_[0]->{-c}->{-udisp}
3441
if $_[0]->{-udispq} && ref($CACHE);
3442
0
$v =$_[0]->{-c}->{-udisp}->{lc($_[1])};
3443
}
3444
0
0
0
$v ||(!$_[0]->{-udispq} && ($^O eq 'MSWin32') && w32udisp(@_))
0
0
3445
||$_[1]
3446
}
3447
0
0
0
0
1
: do { $_[0]->{-c}->{-udisp} =$_[0]->uglist(
0
0
0
0
0
0
0
0
0
3448
(!$_[0]->{-udisp} ? '-ud' : $_[0]->{-udisp} =~/\w/ ? '-ud' .$_[0]->{-udisp} : '-ugdc')
3449
, {});
3450
0
0
0
$CACHE->{-udisp} =$_[0]->{-c}->{-udisp}
3451
if $_[0]->{-udispq} && ref($CACHE);
3452
0
0
0
$_[0]->{-c}->{-udisp}->{lc($_[1])}
0
0
0
0
3453
||(!$_[0]->{-udispq} && ($^O eq 'MSWin32') && w32udisp(@_, !$_[0]->{-udisp} ? () : $_[0]->{-udisp} =~/\w/ ? '-ud' .$_[0]->{-udisp} : '-ugdc'))
3454
||$_[1]
3455
}
3456
}
3457
3458
3459
sub udispq { # display user name quick
3460
!defined($_[1]) || $_[1] eq ''
3461
? ''
3462
: $_[0]->{-AuthUserFile}
3463
? $_[1]
3464
: $_[0]->{-c}->{-udisp}
3465
? $_[0]->{-c}->{-udisp}->{lc($_[1])} ||$_[1]
3466
: ref($CACHE) && $CACHE->{-udisp}
3467
? $CACHE->{-udisp}->{lc($_[1])} ||$_[1]
3468
0
0
0
0
1
: (do{ my $v =udisp(@_);
0
0
0
0
0
0
0
3469
0
0
$CACHE->{-udisp} =$_[0]->{-c}->{-udisp} if ref($CACHE);
3470
0
$v})
3471
}
3472
3473
3474
sub ugfile { # Users/groups caching, 'AuthGroupFile' file write/refresh
3475
# (?self, call, filesystem, mandatory op, args)
3476
# $mo: false, 'q'ueued, 's'pawn
3477
0
0
1
my ($s, $call, $fs, $mo, @arg) =@_;
3478
0
0
$fs =$s->pthForm('var') if !$fs; # filesystem
3479
0
my $fg =$fs .'/' .'uagroup'; # file 'group'
3480
0
my $fl =$fs .'/' .'ualist'; # file list
3481
0
0
0
return(1) # update frequency
3482
if (-f $fg)
3483
&& (time() -[stat($fg)]->[9] <60*60*4);
3484
0
0
@arg = $call eq 'ugf_w32' # call args
3485
? ($s->{-udflt} ||sub{1}) # domain filter sub{}()
3486
0
0
0
: $call eq 'ugf_w32ldap'
0
0
0
0
0
3487
? ($s->{-w32ldap}) # adsi ldap [[?domain=>path],...]
3488
: $call eq 'ugf_ldap'
3489
? () # ldap support
3490
: ()
3491
if ref($_[0]) && (!$mo ||($mo eq 's'));
3492
0
0
0
$mo ='q' if $mo && ($mo eq 's');
3493
0
0
if (!$mo) { # check mode
0
3494
0
0
0
if (!-f $fg) { # immediate interactive
0
3495
0
$s->logRec('ugfile','new',$fg);
3496
}
3497
elsif ($mo =$s && $s->{-endh}) {# end request handlers
3498
0
0
0
if ($mo->{ugfile}) {
0
3499
}
3500
elsif (($^O eq 'MSWin32') && eval('use Win32::Process; 1')) {
3501
0
0
0
if ((!$s->{-w32IISdpsn} || !$s->{-c}->{-RevertToSelf})) {
3502
0
0
$mo->{ugfile} =sub{1};
0
3503
0
0
my @cmd =(
0
3504
$^X =~/^(.+)([\\\/])[^\\\/]+\.dll$/i
3505
? $1 .$2 .'perl.exe'
3506
: $^X =~/.dll$/i
3507
? 'perl.exe'
3508
: "$^X"
3509
,$0,'-call','ugfile',$call,$fs,'s');
3510
0
$s->logRec('ugfile','spawn','uagroup');
3511
0
0
Win32::Process::Create($Win32::Process::Create::ProcessObj
3512
, $cmd[0], join(' ', @cmd)
3513
, 0, &DETACHED_PROCESS | &CREATE_NO_WINDOW,'.')
3514
|| $s->logRec('error','Win32::Process::Create','ugfile',(Win32::GetLastError() +0) .'. ' .Win32::FormatMessage( Win32::GetLastError()));
3515
}
3516
}
3517
else {
3518
0
$s->logRec('ugfile','queue','uagroup');
3519
0
0
$mo->{ugfile} =sub{ugfile($_[0],$call,$fs,'q',@arg)};
0
3520
}
3521
0
return(1)
3522
}
3523
}
3524
elsif ($mo eq 'q') { # queued mode
3525
0
0
0
if (ref($s) # reverted reject
0
0
3526
&& $s->{-w32IISdpsn} && ($s->{-w32IISdpsn} <2)
3527
&& $s->{-c}->{-RevertToSelf}) {
3528
0
return(0)
3529
}
3530
0
0
0
elsif (1) { # inline
3531
}
3532
elsif (eval("use Thread; 1") # threads
3533
&& ($mo =eval{Thread->new(sub{ugfile($call=~/^(?:ugf_ldap)$/ ? $s : undef
3534
, $call, $fs, 't', @arg)})})
3535
) {
3536
$s->logRec('ugfile','thread',$mo);
3537
$mo->detach;
3538
return(1);
3539
}
3540
elsif ($mo =fork) { # fork parent success
3541
$SIG{CHLD} ='IGNORE';
3542
$s->logRec('ugfile','fork',$mo);
3543
return(1);
3544
}
3545
elsif (!defined($mo)) { # fork error, immediate interactive
3546
}
3547
else { # fork child
3548
$mo ='f';
3549
ugfile($call=~/^(?:ugf_ldap)$/ ? $s : undef
3550
, $call, $fs, $mo, @arg);
3551
exit(0);
3552
}
3553
}
3554
0
my @tm=(time());
3555
0
local(*FG, *FL, *FW);
3556
0
open(FG, "+>>$fg.tmp")
3557
0
0
0
|| ($s && &{$s->{-die}}($s->lng(0, 'ugfile') .": open('$fg.tmp') -> $!" .$s->{-ermd}))
0
3558
|| croak("open('<$fg.tmp') -> $!");
3559
0
open(FL, "+>>$fl.tmp")
3560
0
0
0
|| ($s && &{$s->{-die}}($s->lng(0, 'ugfile') .": open('$fl.tmp') -> $!" .$s->{-ermd}))
0
3561
|| croak("open('<$fl.tmp') -> $!");
3562
0
0
while (!flock(FG,LOCK_EX|LOCK_NB) ||!flock(FL,LOCK_EX|LOCK_NB)) {
3563
0
0
next if !-f $fg;
3564
0
flock(FG,LOCK_UN); close(FG);
0
3565
0
flock(FL,LOCK_UN); close(FL);
0
3566
0
return(1)
3567
}
3568
0
truncate(FG,0); truncate(FL,0);
0
3569
0
seek(FG,0,0); seek(FL,0,0);
0
3570
3571
0
0
if ($call eq 'ugf_w32') {ugf_w32 ($s, \*FG, \*FL, \@tm, @arg)}
0
0
0
0
3572
0
elsif ($call eq 'ugf_w32ldap'){ugf_w32ldap($s, \*FG, \*FL, \@tm, @arg)}
3573
elsif ($call eq 'ugf_ldap') {ugf_ldap($s, \*FG, \*FL, \@tm, @arg)}
3574
# my ($s, $tm, $df);
3575
# local (*FG, *FL);
3576
# ($s, *FG, *FL, $tm, @arg) =@_;
3577
# ualist/ugf_w32, used in uglist(), ":\t" delimited:
3578
# domain?\user : user@domain : ADsPath : 'User' : FullName : email : Description
3579
# domain?\group: group@domain: ADsPath : 'Group': : email : Description : members
3580
# uagroup/ugf_w32, used in uglist(), "\t" delimited:
3581
# ?group : members # ?name domain\name name@domain
3582
# domain\group : members
3583
# group@domain : members
3584
#
3585
# ugf_w32, used in uglist():
3586
# standalone host: local users, local groups
3587
# domain member: domain users, local member groups, domain groups
3588
# domain controller: domain users, local domain groups, domain groups
3589
# local member groups unqualified always (using simple 'fullname' without '@')
3590
# local controller groups unqualified usually
3591
3592
0
seek(FG,0,0); seek(FL,0,0);
0
3593
0
open(FW, "+>>$fg") && flock(FW,LOCK_EX)
3594
&& truncate(FW,0) && seek(FW,0,0)
3595
0
0
0
&& (do {while(my $rr =readline *FG){print FW $rr}; 1})
0
0
0
0
0
0
0
0
0
3596
&& flock(FW,LOCK_UN) && close(FW)
3597
|| ($s && $s->die($s->lng(0, 'ugfile') .": open('$fg') -> $!"))
3598
|| croak("open('<$fg') -> $!");
3599
0
flock(FG,LOCK_UN); close(FG); unlink("$fg.tmp");
0
0
3600
0
open(FW, "+>>$fl") && flock(FW,LOCK_EX)
3601
&& truncate(FW,0) && seek(FW,0,0)
3602
0
0
0
&& (do {while(my $rr =readline *FL){print FW $rr}; 1})
0
0
0
0
0
0
0
0
0
3603
&& flock(FW,LOCK_UN) && close(FW)
3604
|| ($s && $s->die($s->lng(0, 'ugfile') .": open('$fl') -> $!"))
3605
|| croak("open('<$fl') -> $!");
3606
0
flock(FL,LOCK_UN); close(FL); unlink("$fl.tmp");
0
0
3607
0
push @tm, time();
3608
0
0
$s->logRec('ugfile','timing',join('-', map {$tm[$_] -$tm[$_-1]} (1..$#tm)),'sec')
0
3609
if $s;
3610
0
1;
3611
}
3612
3613
3614
sub ugf_w32 { # ugfile() module using Win32 ADSI WinNT://
3615
0
0
0
my ($s, $FG, $FL, $tm, $df) =@_;
3616
0
eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0);
0
3617
0
eval('use Win32::OLE::Enum');
3618
0
my $od =Win32::OLE->GetObject('WinNT://' .(Win32::NodeName()) .',computer');
3619
0
0
my $hdu=$od && $od->{Name} || ''; # host domain name
3620
0
0
my $hdn=$od && lc($od->{Name}) || ''; # host domain name
3621
0
0
my $hdp=$od && $od->{ADsPath} || ''; # host domain path
3622
0
my $hdc=lc($hdp); # host domain comparable
3623
0
0
my $ldp=$od && $od->{Parent} || ''; # local domain path
3624
0
$od =Win32::OLE->GetObject("$ldp,domain");
3625
0
0
my $ldu=$od && $od->{Name} || ''; # local domain name
3626
0
0
my $ldn=$od && lc($od->{Name}) || ''; # local domain name
3627
0
my $ldc=lc($ldp); # local domain comparable
3628
0
0
my $lds =$ldu && w32isDC($s) && $ldn || ''; # local DC service?
3629
0
0
$s->logRec('ugfile','ugf_w32','host',$hdp,'dc',$lds,'domain',$ldp)
3630
if $s;
3631
0
0
0
my %dnl=(!$hdn ||$lds ?() :($hdn=>1), !$ldn ?() :($ldn=>1)); # domains to list
0
3632
0
0
0
my @dnl=(!$hdu ||$lds ?() :$hdu, !$ldu ?() :$ldu); # domains to list
0
3633
0
my $fgm; # group lister/unfolder
3634
0
0
0
$fgm=sub{ return('') if !$_[1];
3635
0
my $om =$_[1]->{Members};
3636
0
0
return('') if !$om;
3637
0
my @rv;
3638
my $oi;
3639
0
$om->{Filter} =['User'];
3640
0
$oi =Win32::OLE::Enum->new($om);
3641
0
0
while (defined($oi) && defined(my $oe =$oi->Next())) {
3642
0
0
0
if (!$oe || !$oe->{Class} || !$oe->{Name}
0
0
3643
|| substr($oe->{Name},-1,1) eq '$'
3644
|| substr($oe->{Name},-1,1) eq '&') {
3645
}
3646
else {
3647
0
0
my $dn =$oe->{Parent} =~/([^\\\/]+)$/ ? $1 : $oe->{Parent};
3648
0
push @rv
3649
0
0
, map {$_ # $_ ne lc($_) ? ($_, lc($_)) : $_
0
3650
} lc($oe->{Parent}) ne ($ldn ? $ldc : $hdc)
3651
? ($dn . '\\' .$oe->{Name})
3652
: ($oe->{Name}, ($dn . '\\' .$oe->{Name}))
3653
, $oe->{Name} .'@' .$dn;
3654
}
3655
}
3656
0
$om->{Filter} =['Group'];
3657
0
$oi =Win32::OLE::Enum->new($om);
3658
0
0
while (defined($oi) && defined(my $oe=$oi->Next())) {
3659
0
0
0
if (!$oe || !$oe->{Class} || !$oe->{Name} || !$oe->{groupType}
0
0
3660
|| substr($oe->{Name},-1,1) eq '$'
3661
|| substr($oe->{Name},-1,1) eq '&') {
3662
}
3663
else {
3664
0
0
if ($oe->{groupType} eq '2') { # 2 -global; 8 -universal
3665
0
0
my $du =$oe->{Parent} =~/([^\\\/]+)$/
3666
? $1
3667
: $oe->{Parent};
3668
0
my $dn =lc($du);
3669
0
0
0
if (!$dnl{$dn} && $dn !~/^(?:nt authority|builtin)$/) {
3670
0
$dnl{$dn} =1;
3671
0
push @dnl, $du;
3672
}
3673
}
3674
0
push @rv, &$fgm($_[0], $oe);
3675
}
3676
}
3677
0
join("\t", @rv)
3678
0
};
3679
0
for (my $di =0; $di <=$#dnl; $di++) {
3680
0
my $du =$dnl[$di];
3681
0
local $_ =$du;
3682
0
0
0
next if !$du ||!&$df($s, $du);
3683
0
push @$tm, time();
3684
0
0
$s->logRec('ugfile','ugf_w32','domain',$du) if $s;
3685
0
my $dn =lc($du);
3686
0
$od =Win32::OLE->GetObject("WinNT://$du");
3687
0
0
0
next if !$od || !$od->{Class};
3688
# standalone host: local users, local groups
3689
# domain member : domain users, local member groups, domain groups
3690
# domain controller: domain users, local domain groups, domain groups
3691
0
0
0
my $dp =$dn eq $ldn || $dn eq $hdn ? '' : $du;
3692
0
0
0
unless ($hdn && $ldn && ($dn eq $hdn)) {
0
3693
# omited default domain part
3694
0
$od->{Filter} =['User'];
3695
0
my $oi =Win32::OLE::Enum->new($od);
3696
0
0
while (defined($oi) && defined(my $oe=$oi->Next())) {
3697
0
0
0
next if !$oe || !$oe->{Class} || !$oe->{Name} || substr($oe->{Name},-1,1) eq '$' || substr($oe->{Name},-1,1) eq '&';
0
0
3698
0
0
next if $oe->{AccountDisabled};
3699
0
0
next if $oe->{Name} =~/^(?:SYSTEM|INTERACTIVE|NETWORK|IUSR_|IWAM_|HP ITO |opc_op|patrol|SMS |SMS&_|SMSClient|SMSServer|SMSService|SMSSvc|SMSLogon|SMSInternal|SMS Site|SQLDebugger|sqlov|SharePoint|RTCService)/i;
3700
0
0
0
print $FL $dp ? "$dp\\" : '', $oe->{Name}
0
3701
,":\t", $oe->{Name} .'@' .$du
3702
,":\t", $oe->{ADsPath}
3703
,":\t", $oe->{Class}
3704
,":\t", $oe->{FullName}||''
3705
,":\t", ''
3706
,":\t", $oe->{Description}||''
3707
, "\n";
3708
}
3709
}
3710
0
unless (0) {
3711
0
$od->{Filter} =['Group'];
3712
0
my $oi =Win32::OLE::Enum->new($od);
3713
0
0
while (defined($oi) && defined(my $oe=$oi->Next())) {
3714
0
0
0
next if !$oe || !$oe->{Class}
0
0
3715
|| !$oe->{Name}
3716
|| substr($oe->{Name},-1,1) eq '$'
3717
|| substr($oe->{Name},-1,1) eq '&';
3718
0
0
0
next if ($dn ne ($lds ||$hdn))
0
3719
&& ($oe->{groupType} eq '4'); # local
3720
0
0
next if $oe->{Name} =~/^(?:Domain Controllers|Domain Computers|Pre-Windows 2000|RAS and IAS Servers|MTS Trusted|SMSInternal|NetOp Activity)/i;
3721
0
my $sgm =&$fgm($_[0], $oe);
3722
0
0
0
print $FL $dp ? "$dp\\" : '', $oe->{Name}
0
3723
,":\t", $oe->{Name}
3724
.(($oe->{groupType} ne '4')
3725
? '@' .$du : '')
3726
,":\t", $oe->{ADsPath}
3727
,":\t", $oe->{Class}
3728
,":\t", ''
3729
,":\t", ''
3730
,":\t", $oe->{Description}||''
3731
, "\n";
3732
0
0
print $FG !$dp ? ($oe->{Name}, ":\t", $sgm, "\n") : ()
3733
, $du, '\\', $oe->{Name}, ":\t", $sgm, "\n"
3734
, $oe->{Name}, '@', $du, ":\t", $sgm, "\n"
3735
;
3736
}
3737
}
3738
}
3739
0
1
3740
}
3741
3742
3743
sub ugf_w32ldap { # ugfile() module using Win32 ADSI LDAP:// and WinNT://
3744
0
0
0
my ($s, $FG, $FL, $tm, $aq) =@_;
3745
0
my $hn ={}; # dn -> name
3746
0
my $hm ={}; # group dn -> members
3747
0
eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0);
0
3748
0
eval('use Win32::OLE::Enum');
3749
0
my $ll =w32isDC($s); # local DC
3750
0
my $ld =w32domain($s);
3751
0
my $lh =Win32::NodeName();
3752
0
my $ae;
3753
0
0
0
$ae =sub{ return(undef) if !$_[0];
3754
0
my $oi =Win32::OLE::Enum->new($_[0]);
3755
0
0
while (defined($oi) && defined(my $oe=$oi->Next())) {
3756
0
0
0
if (!ref($oe) ||!$oe->{Class} ||!($oe->{cn} ||$oe->{Name})) {
0
0
0
0
3757
}
3758
elsif ($oe->{Class} =~/^(?:container|organizationalUnit|builtinDomain)$/i) {
3759
0
&$ae($oe, @_[1..$#_])
3760
}
3761
elsif (($oe->{sAMAccountName} ||$oe->{cn} ||$oe->{Name} ||'') =~/\$$/) {
3762
}
3763
elsif ($oe->{Class} =~/^(?:user|group)$/i) {
3764
0
&{$_[1]}($oe)
0
3765
}
3766
}
3767
0
};
3768
0
my $am;
3769
0
0
0
$am =sub{ return('') if !$hm->{$_[0]};
3770
0
0
my $hg =$_[1] ||{};
3771
join("\t"
3772
0
0
, map { if ($hg->{$_}) {
0
0
3773
()
3774
0
}
3775
elsif (!$hm->{$_}) {
3776
0
$hg->{$_} =1;
3777
0
0
my $v =$hn->{$_} ||$_;
3778
0
0
$v =~/^$ld\\/i ? ($',$v,"$'\@$ld") : $v =~/\\/ ? ($v, "$'\@$`") : $ll ? ($v, "$ld\\$v", "$v\@$ld") : ($v)
0
0
3779
}
3780
else {
3781
0
$hg->{$_} =1;
3782
0
0
my $v =$hn->{$_} ||$_;
3783
0
my $a =&$am($_, $hg);
3784
0
0
(($v =~/^$ld\\/i ? ($',$v,"$'\@$ld") : $v =~/\\/ ? ($v, "$'\@$`") : $ll ? ($v, "$ld\\$v", "$v\@$ld") : ($v))
0
0
0
3785
,$a ? $a : ())
3786
0
}} @{$hm->{$_[0]}})
3787
0
};
3788
0
0
foreach my $e ($ll ? () : '', ref($aq) ? @$aq : $aq) {
0
3789
0
0
my ($pw, $pl) =ref($e) ? @$e : ('', $e);
3790
# $pw eq '' - local domain - $ld, 'LDAP://'
3791
# $ll - local DC, 'LDAP://'
3792
# $pl eq '' - local server - Win32::NodeName(), 'WinNT://'
3793
0
0
my $pi = $pl=~/\bDC=/ ? join('.', split /,DC=/, $') : '';
3794
0
0
0
$s->logRec('ugfile', 'ugf_w32ldap', 'domain', $pw||$ld, $pi, $pl||$lh)
0
3795
if $s;
3796
0
0
my $od =$pl
3797
? Win32::OLE->GetObject("LDAP://$pl")
3798
: Win32::OLE->GetObject("WinNT://$lh");
3799
0
0
if (!ref($od)) {
3800
0
0
$s
3801
? $s->warn("Win32::OLE->GetObject('LDAP://$pl') -> $@")
3802
: carp("Win32::OLE->GetObject('LDAP://$pl') -> $@");
3803
0
next;
3804
}
3805
0
0
&$ae($od,sub{ my $oe =$_[0];
3806
0
0
return(0) if !$oe->{GUID};
3807
0
0
0
return(0) if $pl && ($pw || !$ll)
0
0
0
0
3808
&& ($oe->{Class} =~/^(?:group)$/i)
3809
&& (($oe->{groupType}||0) & 0x00000004);
3810
# ADS_GROUP_TYPE_LOCAL_GROUP
3811
0
0
0
my $id =($pl ? $oe->{GUID} : ($oe->{sAMAccountName} ||$oe->{cn} ||$oe->{Name}));
3812
0
0
0
my $en =($pw ? $pw .'\\' : '')
3813
.($oe->{sAMAccountName} ||$oe->{cn} ||$oe->{Name});
3814
0
$hn->{$id} =$en;
3815
0
0
if ($oe->{Class} =~/^(?:group)$/i) {
3816
0
$hm->{$en} =$hm->{$id} =[];
3817
0
my $on =undef; # 'foreignSecurityPrincipal'->'foreignIdentifier' may be empty
3818
0
my $oi =Win32::OLE::Enum->new($oe->{Members});
3819
0
0
while (defined($oi) && defined(my $om=$oi->Next())) {
3820
0
0
0
if (!$om ||!$om->{Class}) {()}
0
0
3821
elsif ($om->{Class} =~/^(foreignSecurityPrincipal)$/) {
3822
0
0
if ($om->{foreignIdentifier}) {
3823
0
push @{$hm->{$id}}, $om->{foreignIdentifier}
0
3824
}
3825
else {
3826
0
$on =1; }
3827
}
3828
else {
3829
0
0
0
push @{$hm->{$id}}
0
0
0
3830
, $pl
3831
? $om->{GUID}
3832
: ((($om->{Parent}=~/([^\\\/]+)$/) && (lc($1) ne lc($lh)) ? "$1\\" : '')
3833
.($om->{sAMAccountName} ||$om->{cn} ||$om->{Name}));
3834
}
3835
}
3836
0
0
if ($on) {
3837
0
0
$on ='WinNT://' .($pw||$ld||$lh) .'/' .($oe->{sAMAccountName} ||$oe->{cn} ||$oe->{Name});
0
3838
0
my $og =Win32::OLE->GetObject($on);
3839
0
0
return($s
0
3840
? $s->warn("Win32::OLE->GetObject('$on') -> $@")
3841
: carp("Win32::OLE->GetObject('$on') -> $@")
3842
) if !$og;
3843
0
$on =$hm->{$oe->{GUID}};
3844
0
my $oi =Win32::OLE::Enum->new($og->{Members});
3845
0
0
while (defined($oi) && defined(my $om=$oi->Next())) {
3846
# GUIDs different in 'WinNT://' and 'LDAP://'; GUID formats different also.
3847
# "User Naming Attributes": objectGUID is a 128-bit GUID structure stored as an OctetString.
3848
# typedef struct _GUID { DWORD Data1; WORD Data2; WORD Data3; BYTE Data4[8];} GUID;
3849
# my $k =$om->{GUID};
3850
# next if grep /^\Q$k\E$/, @$on;
3851
# push @$on, $k;
3852
0
0
my $k = $om->{Parent}=~/([^\\\/]+)$/ ? $1 : '???';
3853
0
0
0
push @$on, $k .'\\' .($om->{sAMAccountName} ||$om->{Name})
0
0
3854
if $k && (lc($k) ne lc($pw||$ld));
3855
}
3856
}
3857
}
3858
0
});
3859
}
3860
0
0
foreach my $e ($ll ? () : '', ref($aq) ? @$aq : $aq) {
0
3861
0
0
my ($pw, $pl) =ref($e) ? @$e : ('', $e);
3862
0
0
my $pi = $pl=~/\bDC=/ ? join('.', split /,DC=/, $') : '';
3863
0
0
0
$s->logRec('ugfile', 'ugf_w32ldap', 'domain', $pw ||$ld, $pi, $pl||$lh)
0
3864
if $s;
3865
0
0
my $od =$pl
3866
? Win32::OLE->GetObject("LDAP://$pl")
3867
: Win32::OLE->GetObject("WinNT://$lh");
3868
0
0
if (!ref($od)) {
3869
0
0
$s
3870
? $s->warn("Win32::OLE->GetObject('LDAP://$pl') -> $@")
3871
: carp("Win32::OLE->GetObject('LDAP://$pl') -> $@");
3872
0
next;
3873
}
3874
0
0
&$ae($od,sub{ my $oe =$_[0];
3875
0
0
return(0) if !$oe->{GUID};
3876
0
0
0
return(0) if !$pl
3877
&& ($oe->{Class} =~/^(?:user)$/i);
3878
0
0
0
return(0) if $pl && ($pw || !$ll)
0
0
0
0
3879
&& ($oe->{Class} =~/^(?:group)$/i)
3880
&& (($oe->{groupType}||0) & 0x00000004);
3881
# ADS_GROUP_TYPE_LOCAL_GROUP
3882
0
0
0
my $id =($pl ? $oe->{GUID} : ($oe->{sAMAccountName} ||$oe->{cn} ||$oe->{Name}));
3883
0
0
my $en =$hn->{$id} ||$oe->{sAMAccountName} ||$oe->{cn} ||$oe->{Name};
3884
0
0
return(0) if $en =~/^(?:Domain Controllers|Domain Computers|Pre-Windows 2000|RAS and IAS Servers|MTS Trusted|SMSInternal|NetOp Activity)/i;
3885
0
0
return(0) if $en =~/^(?:SYSTEM|INTERACTIVE|NETWORK|IUSR_|IWAM_|HP ITO |opc_op|patrol|SMS |SMS&_|SMSClient|SMSServer|SMSService|SMSSvc|SMSLogon|SMSInternal|SMS Site|SQLDebugger|sqlov|SharePoint|RTCService)/i;
3886
0
0
0
my $ef =($oe->{sAMAccountName}||$oe->{cn}||$oe->{Name}||'')
0
0
3887
.(!($oe->{Class} =~/^(?:group)$/i)
3888
|| !($oe->{groupType} & 0x00000004)
3889
? '@' .($pi ||$lh) : '');
3890
0
my $el =&$am($id);
3891
0
0
print $FL $en
0
0
0
0
3892
,":\t", $ef
3893
,":\t", $oe->{ADsPath} ||''
3894
,":\t", ucfirst($oe->{Class}) ||''
3895
,":\t", $oe->{FullName} ||''
3896
,":\t", $oe->{EmailAddress} ||''
3897
,":\t", $oe->{Description} ||''
3898
, "\n";
3899
0
0
print $FG $en, ":\t", $el, "\n"
3900
if $el;
3901
0
0
0
print $FG "$ld\\$en", ":\t", $el, "\n"
0
3902
, "$en\@$ld", ":\t", $el, "\n"
3903
if $el && !$pw && $pl;
3904
0
0
0
print $FG "$lh\\$en", ":\t", $el, "\n"
0
3905
, "$en\@$lh", ":\t", $el, "\n"
3906
if $el && !$pw && !$pl;
3907
0
0
print $FG $ef, ":\t", $en
0
0
3908
, !$pw ? ("\t", "$ld\\$en") : ()
3909
, $el ? ("\t", $el) : ()
3910
, "\n"
3911
if $pl;
3912
0
});
3913
}
3914
1
3915
0
}
3916
3917
3918
sub ugf_ldap { # ugfile() module using Net::LDAP
3919
0
0
0
my ($s, $FG, $FL, $tm, $ha) =@_;
3920
0
0
$s =$ha if !$s;
3921
0
my $hn ={}; # dn -> name
3922
0
my $hm ={}; # group dn -> members
3923
0
0
my $a =$ha && $ha->{-ldapattr} ||$s->{-ldapattr};
3924
0
0
0
my $qf =($s->{-ldapfu} && $s->{-ldapfg}
3925
? '(|' .$s->{-ldapfu} .$s->{-ldapfg} .')'
3926
: '' # : '(|(objectClass=organizationalPerson)(objectClass=groupOfNames))'
3927
);
3928
0
0
$qf =$qf ? {'filter'=>$qf} : {};
3929
0
my $q =$s->ldapSearch(%$qf);
3930
0
push @$tm, time();
3931
0
for(my $i =0; $i < $q->count; $i++) {
3932
0
0
my $dn =$q->entry($i)->get_value('dn') ||$q->entry($i)->get_value('distinguishedName');
3933
0
0
$hn->{$dn} =utf8dec($s, $q->entry($i)->get_value($a->[0])||'');
3934
0
0
$hm->{$dn} =[$q->entry($i)->get_value('member')]
3935
if $q->entry($i)->get_value('member');
3936
}
3937
0
my $ae;
3938
$ae=sub{
3939
0
0
0
return('')
3940
if !$hm->{$_[0]};
3941
0
0
my $hg =$_[1] ||{};
3942
join("\t"
3943
0
0
,map { if ($hg->{$_}) {
0
0
3944
()
3945
0
}
3946
elsif (!$hm->{$_}) {
3947
0
$hg->{$_} =1;
3948
0
0
$hn->{$_} ? utf8dec($s, $hn->{$_}) : utf8dec($s, $_)
3949
}
3950
0
else { $hg->{$_} =1;
3951
0
my $a =&$ae($_, $hg);
3952
0
0
($hn->{$_} ? utf8dec($s, $hn->{$_}) : ()
0
3953
,$a ? $a : ())
3954
0
}} @{$hm->{$_[0]}})
3955
0
};
3956
0
push @$tm, time();
3957
0
$q =$s->ldapSearch(%$qf);
3958
0
push @$tm, time();
3959
0
for(my $i =0; $i < $q->count; $i++) {
3960
0
0
my $dn =$q->entry($i)->get_value('dn') ||$q->entry($i)->get_value('distinguishedName');
3961
0
0
my $en =utf8dec($s, $q->entry($i)->get_value($a->[0])||'');
3962
0
my @en =$q->entry($i)->get_value($a->[0]); shift @en;
0
3963
0
my $ef ='';
3964
0
my $ep =utf8dec($s, $dn);
3965
0
0
my $em =utf8dec($s, $q->entry($i)->get_value('mail')||'');
3966
0
0
0
my $ec =utf8dec($s, $q->entry($i)->get_value('objectClass')||'')
3967
=~/person|user/i ? 'User' : 'Group';
3968
0
0
my $ed =utf8dec($s, $q->entry($i)->get_value($a->[1]||$a->[0])||'');
3969
0
0
my $ei =utf8dec($s, $q->entry($i)->get_value('info')||'');
3970
0
0
$ei =join('; ', map {my $v =$q->entry($i)->get_value($_);
0
3971
0
0
!$v
3972
? ()
3973
: (utf8dec($s, $v))
3974
} qw(title company department physicalDeliveryOfficeName telephoneNumber))
3975
if !$ei;
3976
0
$ei =~s/[\n\r]/ /g;
3977
0
0
my $el =$hm->{$dn} ? &$ae($dn) : undef;
3978
0
0
print $FL $en
0
0
0
0
0
3979
,":\t", $ef ||$em ||$en ||''
3980
,":\t", $ep ||''
3981
,":\t", $ec ||''
3982
,":\t", $ed ||''
3983
,":\t", $em ||''
3984
,":\t", $ei ||''
3985
, "\n";
3986
0
0
print $FG $en, ":\t", $el, "\n"
3987
if $el;
3988
0
0
print $FG map {utf8dec($s, $_) .":\t"
0
0
3989
.$en
3990
.($el ? "\t" .$el : '')
3991
."\n"
3992
} @en
3993
if @en;
3994
}
3995
0
1
3996
}
3997
3998
3999
4000
sub w32IISdpsn {# deimpersonate Microsoft IIS impersonated process
4001
# !!!Future: Problems may be. Implement '-fswtr' login also?
4002
# 'Win32::API' module used, not in ActiveState package.
4003
# Set 'IIS / Home Directory / Application Protection' = 'Low (IIS Process)'
4004
# or see 'Administrative Tools / Component Services'.
4005
# Do not use quering to 'Index Server'.
4006
# See also FastCGI for another ways:
4007
# http://php.weblogs.com/fastcgi_with_php_and_iis
4008
# http://www.caraveo.com/fastcgi/
4009
# http://www.cpan.org/modules/by-module/FCGI/
4010
0
0
0
0
1
return(undef) if (defined($_[0]->{-w32IISdpsn}) && !$_[0]->{-w32IISdpsn})
0
0
0
0
0
4011
|| $_[0]->{-c}->{-RevertToSelf}
4012
|| ($^O ne 'MSWin32')
4013
|| !(($ENV{SERVER_SOFTWARE}||'') =~/IIS/)
4014
# || $ENV{'GATEWAY_INTERFACE'}
4015
|| $ENV{'FCGI_SERVER_VERSION'};
4016
0
$_[0]->user();
4017
0
$_[0]->{-c}->{-RevertToSelf} =1;
4018
0
if (0 && $ENV{GATEWAY_INTERFACE} && ($ENV{GATEWAY_INTERFACE} =~/PerlEx/)
4019
&& $_[0]->w32ufswtr()) {
4020
$_[0]->{-debug} && $_[0]->logRec('w32IISdpsn','w32ufswtr');
4021
return(1)
4022
}
4023
0
my $o =eval('use Win32::API; new Win32::API("advapi32.dll","RevertToSelf",[],"N")');
4024
0
0
my $l =eval{Win32::LoginName()} ||'';
4025
0
$o && $o->Call() && ($l ne (eval{Win32::LoginName()} ||''))
4026
? ($_[0]->{-debug}) && $_[0]->logRec('w32IISdpsn')
4027
0
0
0
: &{$_[0]->{-die}}($_[0]->lng(0, 'w32IISdpsn') .": Win32::API('RevertToSelf') -> " .join('; ', map {$_ ? $_ : ()} $@,$!,$^E) .$_[0]->{-ermd})
0
0
0
4028
}
4029
4030
4031
sub w32ufswtr { # Win32 filesystem writer or System user?
4032
0
0
0
1
return(undef) if $^O ne 'MSWin32';
4033
0
my $u =lc(Win32::LoginName());
4034
0
0
0
if (ref($_[0]->{-fswtr})) {
0
4035
0
0
foreach my $e (@{$_[0]->{-fswtr}}) {return(1) if $u eq lc($e)}
0
0
4036
}
4037
elsif ($_[0]->{-fswtr} && ($u eq lc($_[0]->{-fswtr}))) {
4038
0
return(1)
4039
}
4040
0
0
return(1) if $u eq 'system';
4041
0
0
0
if (($] >=5.008) && eval('use Win32; 1') && Win32::IsAdminUser()) {
0
4042
0
my ($dom, $sid, $sit);
4043
0
0
if (Win32::LookupAccountName('', $u , $dom, $sid, $sit)) {
4044
# SidTypeWellKnownGroup == 5; S-1-5-18 == system
4045
# sprintf '%vlx',$sid
4046
0
0
return(1) if $sit eq '5';
4047
}
4048
}
4049
0
undef;
4050
}
4051
4052
4053
sub w32adhi { # Win32 AD Host Info
4054
0
0
0
1
$_[0]->{'ADSystemInfo'}
4055
|| ($_[0]->{'ADSystemInfo'} =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); Win32::OLE->CreateObject("ADSystemInfo")'))
4056
}
4057
4058
4059
sub w32domain { # Win32 domain name (or node name if no domain)
4060
0
0
0
0
0
w32adhi($_[0])->{DomainShortName} || eval{Win32::NodeName()} || $ENV{COMPUTERNAME}
0
4061
}
4062
4063
4064
sub w32isDC { # Win32 is on domain controller, not srvr or wrkstation
4065
0
0
0
eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0);
0
4066
0
0
Win32::OLE->GetObject('LDAP://' .Win32::NodeName()) && 1
4067
}
4068
4069
4070
sub w32user { # Win32 user object
4071
0
0
1
eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0)');
4072
0
0
my ($dn, $gn) = $_[1] =~/^([^\\]+)\\(.+)/
0
4073
? ($1,$2)
4074
: $_[1] =~/^([^@]+)@(.+)/
4075
? ($2,$1)
4076
: (Win32::NodeName(),$_);
4077
0
Win32::OLE->GetObject("WinNT://$dn/$gn");
4078
}
4079
4080
4081
sub w32udisp { # Win32 user display name
4082
# (self, user, ?opt)
4083
0
0
0
0
return($_[1]) if $^O ne 'MSWin32';
4084
0
0
0
return('') if !defined($_[1]) || $_[1] eq '';
4085
0
0
my ($dn, $gn) = $_[1] =~/^([^\\]+)\\(.+)/
0
4086
? ($1,$2)
4087
: $_[1] =~/^([^@]+)@(.+)/
4088
? ($2,$1)
4089
: (Win32::NodeName(),$_[1]);
4090
0
0
my $o =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); 1')
4091
&& Win32::OLE->GetObject("WinNT://$dn/$gn");
4092
0
0
0
!$o
0
0
0
0
4093
? $_[1]
4094
: $o->{Class} eq 'User'
4095
? $o->{FullName} ||$_[1]
4096
: $_[2] && ($_[2] =~/c/) && ($o->{Class} eq 'Group')
4097
? $o->{Description} ||$_[1]
4098
: $_[1]
4099
}
4100
4101
4102
sub w32ugrps { # Win32 user groups, optional usage, interesting legacy code
4103
0
0
0
my $uif =$_[1]; # user input full name
4104
0
my $uid =''; # user input domain name
4105
0
my $uin =''; # user input name shorten
4106
0
eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0);
0
4107
0
0
if ($uif =~/^([^\\]+)\\(.+)/) { $uid =$1; $uin =$2 }
0
0
0
4108
0
elsif ($uif =~/^([^@]+)\@(.+)/) { $uid =$2; $uin =$1 }
0
4109
0
0
else { $uin =$uif; $uid =Win32::OLE->CreateObject('ADSystemInfo')->{DomainShortName} ||Win32::NodeName()}
0
4110
0
my $gn =[]; # group names
4111
0
my $gp =[]; # group paths
4112
0
my $oh =Win32::OLE->GetObject('WinNT://' .Win32::NodeName() .',computer');
4113
0
0
return($gn) if !$oh;
4114
0
my $ou =Win32::OLE->GetObject("WinNT://$uid/$uin,user");
4115
0
0
return($gn) if !$ou;
4116
0
0
my $dp = # domain prefix for global groups, optional
0
4117
lc($oh->{Parent}) eq lc($ou->{Parent})
4118
? ''
4119
: $ou->{Parent} =~/([^\\\/]+)$/
4120
? $1 .'\\'
4121
: '';
4122
0
foreach my $og (Win32::OLE::in($ou->{Groups})) { # global groups from user's domain
4123
0
0
0
next if !$og || !$og->{Class} || $og->{groupType} ne '2';
0
4124
0
push @$gn, $dp .$og->{Name};
4125
0
push @$gp, $og->{ADsPath};
4126
}
4127
0
my $uc =lc($ou->{ADsPath}); # user compare
4128
0
my $gc =[map {lc($_)} @$gp]; # group compare
0
4129
0
$oh->{Filter} =['Group'];
4130
0
foreach my $og (Win32::OLE::in($oh)) {
4131
0
0
0
next if !$og || !$og->{Class} || $og->{groupType} ne '4';
0
4132
0
foreach my $om (Win32::OLE::in($og->{Members})) {
4133
0
0
0
next if !$om || !$om->{Class} || ($om->{Class} ne 'User' && $om->{Class} ne 'Group');
0
0
4134
0
my $mc =lc($om->{ADsPath});
4135
0
foreach my $p (@$gc) {
4136
0
0
next if $p ne $mc;
4137
0
push @$gn, $og->{Name};
4138
0
push @$gp, $og->{ADsPath};
4139
0
$mc =undef;
4140
0
last;
4141
}
4142
0
0
last if !$mc;
4143
0
0
if ($mc eq $uc) {
4144
0
push @$gn, $og->{Name};
4145
0
push @$gp, $og->{ADsPath};
4146
0
last;
4147
}
4148
}
4149
}
4150
0
$gn;
4151
}
4152
4153
sub w32umail {
4154
0
0
1
umail(@_)
4155
}
4156
4157
4158
sub umail { # E-mail address(es) of user(s) given
4159
0
0
1
my($s, $u) =@_[0,1]; # (self, ?user(s) string) -> email
4160
0
0
$u =$s->user() if !$u;
4161
0
my $d =$s->{-smtpdomain};
4162
0
my $h =$s->uglist('-ug@c',{});
4163
0
join(', '
4164
0
, map { my ($v, $o) =($_);
4165
0
0
0
!$v
0
0
0
0
4166
? ()
4167
: $v && $d && ($v =~/\@\Q$d\E/i)
4168
? $v
4169
: $h && $h->{lc $v}
4170
? $h->{lc $v}
4171
: ($v !~/[\@\\]/)
4172
? $v
4173
: $v
4174
} split /\s*[,;]\s*/, $u)
4175
}
4176
4177
4178
sub ldap { # LDAP connection
4179
0
0
0
0
return($_[0]->{-c}->{-ldap}) if $_[0]->{-c}->{-ldap};
4180
0
my $s =$_[0];
4181
0
0
my $a =$s->{-ldapsrv} ||$s->{-ldap};
4182
0
0
return (&{$s->{-die}}('LDAP connection undefined' .$s->{-ermd}))
0
4183
if !$a;
4184
0
my $r;
4185
0
0
if(ref($a) eq 'CODE') {
4186
}
4187
else {
4188
0
$s->logRec('ldap','Net::LDAP->new');
4189
0
eval('use Net::LDAP; 1')
4190
0
0
|| return (&{$s->{-die}}("use Net::LDAP -> $@" .$s->{-ermd}));
4191
0
0
$r =Net::LDAP->new(ref($a) eq 'ARRAY' ? @$a : ref($a) eq 'HASH' ? %$a : $a);
0
4192
0
0
return (&{$s->{-die}}("Net::LDAP->new -> $@" .$s->{-ermd}))
0
4193
if !$r;
4194
0
$a =$s->{-ldapbind}; # "user",password=>"passw", version=>3
4195
0
$r->bind(ref($a) eq 'ARRAY' ? @$a : ref($a) eq 'HASH' ? %$a : !$a ? (version=>3) : $a)
4196
0
0
|| return (&{$s->{-die}}("Net::LDAP->bind -> $@" .$s->{-ermd}));
0
0
0
4197
}
4198
0
$_[0]->{-c}->{-ldap} =$r;
4199
}
4200
4201
4202
sub ldapSearch {# LDAP search
4203
# (self, option=>value)
4204
0
0
0
my %a =(@_[1..$#_]);
4205
0
0
0
my $f =$_[0]->{-ldapsearch} && $_[0]->{-ldapsearch}->{filter} && $a{filter}
0
0
4206
? '(&' .$a{filter} .$_[0]->{-ldapsearch}->{filter} .')'
4207
: $a{filter}
4208
? $a{filter}
4209
: $_[0]->{-ldapsearch}->{filter}
4210
? $_[0]->{-ldapsearch}->{filter}
4211
: '';
4212
0
$_[0]->ldap;
4213
0
$_[0]->logRec('ldap','search',$f);
4214
0
0
my %a1=($_[0]->{-ldapsearch} ? %{$_[0]->{-ldapsearch}} : ()
0
0
4215
,%a, $f ? (filter=>$f) : ());
4216
0
my $r =$_[0]->ldap->search(%a1);
4217
0
0
return (&{$_[0]->{-die}}("ldapSearch(" .join(',', map{"$_=>" .$a1{$_}} keys %a1) .') ->' .$r->error .$_[0]->{-ermd}))
0
0
4218
if $r->code;
4219
0
$r
4220
}
4221
4222
4223
sub ldapEntry { # LDAP search and return entry
4224
# (entry name) -> entry
4225
0
0
0
0
my $r =$_[0]->ldapSearch($#_ <2
0
4226
? ('filter'=> $_[1] !~/[=]/
4227
? $_[0]->{-ldapattr}->[0] .'=' .utf8enc($_[0],$_[1])
4228
: $_[1])
4229
: @_[1..$#_]);
4230
0
0
return (&{$_[0]->{-die}}('ldapRead('. join(', ',@_[1..$#_]) .'-> sevaral entries found' .$_[0]->{-ermd}))
0
4231
if $r->count >1;
4232
0
$r->entry(0);
4233
}
4234
4235
4236
sub ldapVal { # LDAP entry get value and decode it
4237
# (entry, attr name) -> value
4238
0
0
0
0
my $v =ref($_[1]) ? $_[1]->get_value($_[2..$#_]) : $_[0]->ldapEntry($_[1])->get_value($_[2..$#_]);
4239
0
!defined($v)
4240
? ($v)
4241
: ref($v) eq 'ARRAY'
4242
0
0
? [map {utf8dec($_[0], $_)} @$v]
0
4243
: utf8dec($_[0], $v)
4244
}
4245
4246
4247
sub ldapLst { # LDAP list # may be useful instead of 'ugf_ldap'
4248
# self, '-ug<>', ?user|group|filter, ?container, ?fields
4249
0
0
1
my($s,$o,$f,$r,$a) =@_;
4250
0
0
$o ='-ug' if !$o;
4251
0
0
$r =[] if !$r;
4252
0
0
$a =$s->{-ldapattr} if !$a;
4253
0
0
0
my $fq =($f =~/[=]/ ? $f
0
0
0
0
0
0
0
4254
: ($o =~/ug/)
4255
|| ($o!~/[ug]/) ? ($s->{-ldapfu} && $s->{-ldapfg}
4256
? '(|' .$s->{-ldapfu} .$s->{-ldapfg} .')'
4257
: '')
4258
: $o =~/u/ ? $s->{-ldapfu} ||'(objectClass=organizationalPerson)'
4259
: $o =~/g/ ? $s->{-ldapfg} ||'(objectClass=groupOfNames)'
4260
: '');
4261
0
0
my $fc=ref($f) eq 'CODE' ? $f : undef;
4262
0
0
0
my $fm=ref($f) ? undef : $f =~/[=]/ ? undef
0
0
4263
: $f && $o !~/u/ ? $s->ugroups($f)
4264
: $f;
4265
0
0
0
$fq =$fq
0
4266
? ('&(member=' .utf8enc($s,$fm) .")$fq")
4267
: ('(member=' .utf8enc($s,$fm) .')')
4268
if $fm && !ref($fm);
4269
0
0
my $q =$s->ldapSearch($fq ? ('filter'=>$fq) : ());
4270
0
$s->logRec('ldap','list');
4271
0
0
if (ref($r) eq 'ARRAY') {
4272
0
for(my $i =0; $i < $q->count; $i++) {
4273
0
0
my $v =utf8dec($s, $q->entry($i)->get_value($a->[0])||'');
4274
0
0
0
next if ref($fm) && !grep /^\Q$v\E$/i, @$fm;
4275
0
push @$r, $v
4276
}
4277
}
4278
else {
4279
0
for(my $i =0; $i < $q->count; $i++) {
4280
0
0
my $v =utf8dec($s, $q->entry($i)->get_value($a->[0]) ||'');
4281
0
0
my $v1=utf8dec($s, $q->entry($i)->get_value($a->[1] ||$a->[0]) ||'');
4282
0
0
0
next if ref($fm) && !grep /^\Q$v\E$/i, @$fm;
4283
0
0
0
$r->{$v} =($v1 ||$v) .($o=~/[<>]/ ? ' <' .($v ||$v1) .'>' : '');
0
4284
}
4285
}
4286
0
$r
4287
}
4288
4289
4290
sub ldapUgroups { # LDAP user groups # replaced with 'ugf_ldap'
4291
# (user) -> groups
4292
0
0
0
my($s,$u,$g) =@_;
4293
0
0
my $n =ref($u) ? $u->get_value('dn') : $s->ldapEntry($u)->get_value('dn');
4294
0
my $q =$s->ldapSearch("member=$n");
4295
0
0
$g =[] if !$g;
4296
0
for(my $i =0; $i < $q->count; $i++) {
4297
0
0
push @$g, utf8dec($s, $q->entry($i)->get_value($s->{-ldapattr}->[0])||'');
4298
0
ldapUgroups($s, $q->entry($i), $g);
4299
}
4300
0
$g
4301
}
4302
4303
4304
4305
4306
#########################################################
4307
# Database methods
4308
#########################################################
4309
4310
4311
sub mdeTable { # Table MetaData Element
4312
# (self, table name) -> table metadata
4313
# Cached
4314
0
0
0
0
0
return ($_[0]->{-table}->{$_[1]})
4315
if $_[0]->{-table}->{$_[1]}
4316
&& $_[0]->{-table}->{$_[1]}->{'.mdeTable'};
4317
4318
0
my ($s, $tn) =@_;
4319
# Generate table
4320
# table factory may be developed
4321
0
0
0
&{$s->{-mdeTable}}($s, $tn)
0
4322
if $s->{-mdeTable} && !$s->{-table}->{$tn};
4323
0
0
return (&{$s->{-die}}('mdeTable(' .$tn .') -> not described table' .$s->{-ermd}))
0
4324
if !$s->{-table}->{$tn};
4325
# Organize table metadata
4326
0
$s->logRec('mdeTable', $tn);
4327
0
my $tm =$s->{-table}->{$tn};
4328
0
$tm->{'.mdeTable'} =1; # flag of organized
4329
0
$tm->{-mdefld} ={}; # hash of fields
4330
0
0
if (ref($tm->{-field}) eq 'ARRAY') {
4331
0
foreach my $f (@{$tm->{-field}}) { # field flags setup
0
4332
0
0
0
next if !ref($f) ||ref($f) ne 'HASH';
4333
0
0
$tm->{-mdefld}->{$f->{-fld}} =$f
4334
if $f->{-fld};
4335
0
0
$f->{-flg} ='a' # 'a'll
4336
if !exists($f->{-flg});
4337
0
0
if ($f->{-flg} =~/k/) {
4338
0
0
if (!$tm->{-key}) { # 'k'ey
0
0
4339
0
$tm->{-key} =[$f->{-fld}]
4340
}
4341
0
elsif (!grep {$_ eq $f->{-fld}} @{$tm->{-key}}) {
4342
0
push @{$tm->{-key}}, $f->{-fld}
0
4343
}
4344
}
4345
0
0
if ($f->{-flg} =~/w/) { # 'w'here
4346
0
0
if (!$tm->{-wkey}) {
0
0
4347
0
$tm->{-wkey} =[$f->{-fld}]
4348
}
4349
0
elsif (!grep {$_ eq $f->{-fld}} @{$tm->{-wkey}}) {
4350
0
push @{$tm->{-wkey}}, $f->{-fld}
0
4351
}
4352
}
4353
0
$f->{-flg} ='w' .$f->{-flg} # 'w'here
4354
0
0
0
if $f->{-flg} !~/w/ && $tm->{-wkey} && grep {$_ eq $f->{-fld}} @{$tm->{-wkey}};
0
0
4355
0
$f->{-flg} ='k' .$f->{-flg} # 'k'ey
4356
0
0
0
if $f->{-flg} !~/k/ && $tm->{-key} && grep {$_ eq $f->{-fld}} @{$tm->{-key}};
0
0
4357
0
0
0
$f->{-flg}.='e' # 'e'dit
4358
if $f->{-flg} !~/e/ && $f->{-edit};
4359
}
4360
}
4361
$tm
4362
0
}
4363
4364
4365
sub mdlTable { # Tables List
4366
0
sort( $_[0]->{-mdlTable}
4367
0
?(keys %{$_[0]->{-table}}
4368
0
, grep {!$_[0]->{-table}->{$_}} &{$_[0]->{-mdlTable}})
0
4369
0
0
0
0
: keys %{$_[0]->{-table}})
4370
}
4371
4372
4373
sub mdeQuote { # Quote field value if needed
4374
# self, table, field, value
4375
0
0
0
0
my $t =ref($_[1]) eq 'HASH' ? $_[1] : mdeTable($_[0], !ref($_[1]) ? $_[1] : ref($_[1]->[0]) ? $_[1]->[0]->[0] : $_[1]->[0]);
0
0
4376
0
0
0
!ref($t) || !$t->{-mdefld} || !$t->{-mdefld}->{$_[2]} || !$t->{-mdefld}->{$_[2]}->{-flg}
0
0
0
0
0
0
0
0
0
0
0
4377
? ( !defined($_[3])
4378
? 'NULL'
4379
: ($_[3] =~/\d+/) && ($_[3] =~/^[+-]{0,1}[\d]+(?:\.[\d]+){0,1}$/)
4380
## ($_[3] =~/^[+-]{0,1}[\d ,]+(?:.[\d ,]+){0,1}$/)
4381
? $_[3]
4382
: !$_[0]->{-dbi}
4383
? strquot($_[0], $_[3])
4384
: $_[0]->{-dbi}->quote($_[3])
4385
)
4386
: $t->{-mdefld}->{$_[2]}->{-flg} =~/["']/
4387
? (!$_[0]->{-dbi} ? strquot($_[0], $_[3]) : $_[0]->{-dbi}->quote($_[3]))
4388
: $t->{-mdefld}->{$_[2]}->{-flg} =~/[9n]/
4389
? $_[3]
4390
: !defined($_[3])
4391
? 'NULL'
4392
: ($_[3] =~/\d/) && ($_[3] =~/^[+-]{0,1}[\d]+(?:\.[\d]+){0,1}$/)
4393
## ($_[3] =~/^[+-]{0,1}[\d ,]+(?:.[\d ,]+){0,1}$/)
4394
? $_[3]
4395
: !$_[0]->{-dbi}
4396
? strquot($_[0], $_[3])
4397
: $_[0]->{-dbi}->quote($_[3])
4398
}
4399
4400
4401
sub mdeSubj { # Subject generalized of record
4402
# (self, data) | (self, meta, data) -> subject
4403
0
0
0
0
if ($#_ >1) {
4404
}
4405
0
( ref($_[0]->{-tn}->{-ridSubject}) eq 'CODE'
4406
0
0
0
? &{$_[0]->{-tn}->{-ridSubject}}(@_)
4407
: join(' ', map {
4408
0
!defined($_[1]->{$_}) || ($_[1]->{$_} eq '')
4409
? ()
4410
: ($_[1]->{$_})
4411
0
0
} @{$_[0]->{-tn}->{-ridSubject}}))
0
4412
||''
4413
}
4414
4415
4416
sub mdeReaders {# Table readers fields
4417
# self, table
4418
0
0
0
my $r =!$_[0]->{-rac} || $_[0]->uadmrdr()
4419
? undef
4420
: ref($_[1])
4421
0
0
0
? [@{$_[1]->{-racReader} ||$_[0]->{-racReader} ||[]}
4422
0
0
0
,@{$_[1]->{-racWriter} ||$_[0]->{-racWriter} ||[]}]
4423
0
0
0
: [@{$_[0]->{-table}->{$_[1]}->{-racReader} ||$_[0]->{-racReader}||[]}
4424
0
0
0
0
0
,@{$_[0]->{-table}->{$_[1]}->{-racWriter} ||$_[0]->{-racWriter}||[]}];
0
4425
#$_[0]->logRec('mdeReaders',@_[1..$#_],$r);
4426
0
0
0
ref($r) && @$r ? $r : undef
4427
}
4428
4429
4430
sub mdeWriters {# Table writers fields
4431
# self, table
4432
0
0
0
0
0
!$_[0]->{-rac} || $_[0]->uadmwtr()
0
0
0
4433
? undef
4434
: ref($_[1])
4435
? $_[1]->{-racWriter} ||$_[0]->{-racWriter} ||undef
4436
: $_[0]->{-table}->{$_[1]}->{-racWriter} ||$_[0]->{-racWriter} ||undef
4437
}
4438
4439
4440
sub mdeRAC { # Table record access control condition
4441
# self, table/form, ? option switch
4442
0
0
0
0
if ($_[2]) {
4443
0
0
0
my $m =ref($_[1]) ? $_[1] : ($_[0]->{-form}->{$_[1]} ||$_[0]->{-table}->{$_[1]} ||{});
4444
0
0
0
return(undef) if exists($m->{$_[2]}) && !$m->{$_[2]};
4445
}
4446
0
0
my $m =(ref($_[1])
4447
? ($_[1]->{-table} ? $_[0]->{-table}->{$_[1]->{-table}} : $_[1])
4448
: $_[0]->{-form}->{$_[1]}
4449
? ($_[0]->{-form}->{$_[1]}->{-table} ? $_[0]->{-table}->{$_[0]->{-form}->{$_[1]}->{-table}} : $_[0]->{-form}->{$_[1]})
4450
: $_[0]->{-table}->{$_[1]}
4451
) ||{};
4452
0
0
0
( $m->{-racActor} ||$_[0]->{-racActor}
0
0
0
0
0
0
0
0
0
0
4453
||$m->{-racManager} ||$_[0]->{-racManager}
4454
||$m->{-racPrincipal} ||$_[0]->{-racPrincipal}
4455
||$m->{-racUser} ||$_[0]->{-racUser}
4456
||$m->{-racWriter} ||$_[0]->{-racWriter}
4457
||$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy}
4458
) && $m
4459
}
4460
4461
4462
sub mdeRole { # Table user role fields list
4463
# self, table, role, ? altrole
4464
0
0
0
0
my $m =ref($_[1]) ? $_[1] : $_[0]->{-table}->{$_[1]};
4465
0
0
0
my $r =$_[2] eq 'all'
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
4466
? undef
4467
: $_[2] eq 'creator'
4468
? [$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ||()]
4469
: $_[2] eq 'updater'
4470
? [$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ||()]
4471
: $_[2] eq 'author'
4472
? [$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ||()
4473
,$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ||()]
4474
: $_[2] eq 'authors'
4475
? $m->{-racWriter} ||$_[0]->{-racWriter}
4476
|| mdeRole($_[0], $m, $_[3] ||'author')
4477
: $_[2] eq 'actor'
4478
? $m->{-racActor} &&[$m->{-racActor}->[0]]
4479
|| $_[0]->{-racActor} &&[$_[0]->{-racActor}->[0]]
4480
||mdeRole($_[0], $m, $_[3] ||'actors')
4481
: $_[2] eq 'actors'
4482
? $m->{-racActor} ||$_[0]->{-racActor}
4483
|| ($_[3] ? mdeRole($_[0], $m, $_[3]) : undef)
4484
|| ($m->{-rvcUpdBy} && [$m->{-rvcUpdBy}])
4485
|| ($_[0]->{-rvcUpdBy} && [$_[0]->{-rvcUpdBy}])
4486
|| mdeRole($_[0], $m, 'authors')
4487
: $_[2] eq 'manager'
4488
? $m->{-racManager} &&[$m->{-racManager}->[0]]
4489
|| $_[0]->{-racManager} &&[$_[0]->{-racManager}->[0]]
4490
||mdeRole($_[0], $m, $_[3] ||'managers')
4491
: $_[2] eq 'managers'
4492
? $m->{-racManager} ||$_[0]->{-racManager}
4493
|| ($_[3] ? mdeRole($_[0], $m, $_[3]) : undef)
4494
|| ($m->{-rvcInsBy} && [$m->{-rvcInsBy}])
4495
|| ($_[0]->{-rvcInsBy} && [$_[0]->{-rvcInsBy}])
4496
|| mdeRole($_[0], $m, 'author')
4497
: $_[2] eq 'principal'
4498
? $m->{-racPrincipal} &&[$m->{-racPrincipal}->[0]]
4499
|| $_[0]->{-racPrincipal} &&[$_[0]->{-racPrincipal}->[0]]
4500
|| mdeRole($_[0], $m, $_[3] ||'principals')
4501
: $_[2] eq 'principals'
4502
? $m->{-racPrincipal} ||$_[0]->{-racPrincipal}
4503
|| ($_[3] ? mdeRole($_[0], $m, $_[3]) : undef)
4504
|| ($m->{-rvcInsBy} && [$m->{-rvcInsBy}])
4505
|| ($_[0]->{-rvcInsBy} && [$_[0]->{-rvcInsBy}])
4506
|| mdeRole($_[0], $m, 'author')
4507
: $_[2] eq 'user'
4508
? $m->{-racUser} &&[$m->{-racUser}->[0]]
4509
|| $_[0]->{-racUser} &&[$_[0]->{-racUser}->[0]]
4510
|| mdeRole($_[0], $m, $_[3] ||'users')
4511
: $_[2] eq 'users'
4512
? $m->{-racUser} ||$_[0]->{-racUser}
4513
|| mdeRole($_[0], $m, $_[3] ||'principals')
4514
: mdeRole($_[0], $m, 'authors');
4515
0
0
0
ref($r) && @$r ? $r : undef
4516
}
4517
4518
4519
sub mdeRoles { # Table user roles list
4520
# self, table/form ||0, ? pass value
4521
0
0
0
0
return(qw(all author authors actor actors manager managers principal principals user users))
4522
if !$_[1];
4523
0
0
0
my $m =!$_[1] ? $_[1] : (mdeRAC(@_) ||{});
4524
0
my $v;
4525
0
0
0
my @l =('all'
0
0
0
0
0
0
0
0
0
0
0
0
0
0
4526
#,!$m ||$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ? ('creator') : ()
4527
#,!$m ||$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ? ('updater') : ()
4528
,!$m ||$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ||
4529
!$m ||$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ? ('author') : ()
4530
,!$m ||$m->{-racWriter} ||$_[0]->{-racWriter} ? ('authors') : ()
4531
,(!($v =!$m ||$m->{-racActor}||$_[0]->{-racActor})
4532
? () : $#$v >0 ? (qw(actor actors)) : qw(actor))
4533
,(!($v =!$m ||$m->{-racManager}||$_[0]->{-racManager})
4534
? () : $#$v >0 ? (qw(manager managers)) : qw(manager))
4535
,(!($v =!$m ||$m->{-racPrincipal}||$_[0]->{-racPrincipal})
4536
? () : $#$v >0 ? (qw(principal principals)) : qw(principal))
4537
,(!($v =!$m ||$m->{-racUser}||$_[0]->{-racUser})
4538
? () : $#$v >0 ? (qw(user users)) : qw(user))
4539
);
4540
0
0
0
push @l, $_[2] if $_[2] && !grep {$_ eq $_[2]} @l;
0
4541
@l
4542
0
}
4543
4544
4545
sub mdeFldIU { # Field of Inserters/Updaters
4546
0
0
0
0
0
$_[2] # self, table meta, field
0
0
0
0
0
0
4547
&&(($_[1]->{-rvcInsBy} && ($_[1]->{-rvcInsBy} eq $_[2]))
4548
|| ($_[0]->{-rvcInsBy} && ($_[0]->{-rvcInsBy} eq $_[2]))
4549
|| ($_[1]->{-rvcUpdBy} && ($_[1]->{-rvcUpdBy} eq $_[2]))
4550
|| ($_[0]->{-rvcUpdBy} && ($_[0]->{-rvcUpdBy} eq $_[2])))
4551
}
4552
4553
4554
sub mdeFldRW { # Field of Readers/Writers
4555
# self, table meta, field
4556
0
0
0
0
0
return(undef) if !$_[2]
0
4557
|| !($_[1]->{-racReader} ||$_[0]->{-racReader} ||$_[1]->{-racWriter} ||$_[0]->{-racWriter});
4558
0
0
foreach my $e ( $_[1]->{-racReader} ? @{$_[1]->{-racReader}} : $_[0]->{-racReader} ? @{$_[0]->{-racReader}} : ()
0
0
0
0
0
0
4559
0
, $_[1]->{-racWriter} ? @{$_[1]->{-racWriter}} : $_[0]->{-racWriter} ? @{$_[0]->{-racWriter}} : ()) {
4560
0
0
return($_[2]) if $e eq $_[2]
4561
}
4562
return(undef)
4563
0
}
4564
4565
4566
sub mddUrole { # Display UROLE
4567
0
0
0
my ($s, $m, $n) =@_; # self, meta, role
4568
0
0
$m =$s->mdeTable($m->{-table}) if $m->{-table};
4569
0
my $l =$s->mdeRole($m, $n);
4570
0
0
0
join(', '
0
0
0
4571
, $l
4572
0
0
? (map {$_ && $m && $m->{-mdefld} && $m->{-mdefld}->{$_}
0
0
0
4573
# && ($s->lngslot($m->{-mdefld}->{$_},'-lbl') || $s->lng(0,$_))
4574
&& $s->lnglbl($m->{-mdefld}->{$_},'-fld')
4575
|| $_
4576
} @$l)
4577
: ()
4578
, $n =~/^(?:manager|principal|user)$/i
4579
? '! ' .$s->mddUrole($m, 'actor')
4580
: $n =~/^(?:managers|principals|users)$/i
4581
? '! ' .$s->mddUrole($m, 'actors')
4582
: ()
4583
) || $n
4584
}
4585
4586
4587
sub recType { # Record type or table name
4588
0
0
0
0
0
$_[1]->{-table}
0
0
0
4589
|| ($_[1]->{-form} && $_[0]->{-form}->{$_[1]->{-form}} && $_[0]->{-form}->{$_[1]->{-form}}->{-table})
4590
|| (ref($_[2]) ne 'HASH' && substr($_[2], 0, index($_[2],'='))) # class name
4591
}
4592
4593
4594
sub recFields { # Field names in the record hash
4595
# !!! sort degradation, needed to use 'recValues'
4596
0
0
0
1
sort grep {substr($_,0,1) ne '-' && substr($_,0,1) ne '.'} keys %{$_[1]}
0
0
4597
}
4598
4599
4600
sub recValues { # Field values in the record hash
4601
0
0
1
map {$_[1]->{$_}} recFields($_[0], $_[1])
0
4602
}
4603
4604
4605
sub recData { # Field name => value hash ref
4606
0
0
1
return({map {($_=> $_[1]->{$_})} recFields($_[0], $_[1])})
0
4607
}
4608
4609
4610
sub recKey { # Record's key: field => value hash ref
4611
# self, table name, record
4612
0
0
0
1
my $m =$_[0]->{-table}->{$_[1]} ||$_[0]->{-form}->{$_[1]};
4613
0
$m && $m->{-key}
4614
0
0
0
? {map {($_=>$_[2]->{$_})} @{$m->{-key}}}
0
0
4615
: $_[2]->{'id'} # 'id' field present
4616
? {'id'=>$_[2]->{'id'}}
4617
: {}
4618
}
4619
4620
4621
sub recWKey { # Record's optimistic key: field => value hash ref
4622
# self, table name, record
4623
0
0
0
1
my $m =$_[0]->{-form}->{$_[1]} ||$_[0]->{-table}->{$_[1]};
4624
0
0
return(recKey(@_)) if !$m;
4625
0
my $r ={};
4626
0
0
if ($m->{-wkey}) {
4627
0
$r ={map {($_=>$_[2]->{$_})
0
4628
0
} grep {defined($_[2]->{$_})
4629
0
} @{$m->{-wkey}}}
4630
}
4631
0
0
%$r ? $r : recKey(@_)
4632
}
4633
4634
4635
sub rmlClause { # Command clause words and values list from record's hash ref
4636
# (record manipulation language)
4637
# !!! sort degradation, for nice display
4638
0
0
0
map {($_=>$_[1]->{$_})} sort grep {substr($_,0,1) eq '-'} keys %{$_[1]}
0
0
0
4639
}
4640
4641
4642
sub rmlKey { # Record's '-key' clause value
4643
# ($self, {command}, {data})
4644
0
$_[1]->{-key} && !ref($_[1]->{-key}) # should be translated
4645
? {'id'=>rmlIdSplit(@_[0,1],$_[1]->{-key})}
4646
: $_[1]->{-key} # already exists
4647
? $_[1]->{-key}
4648
: $_[1]->{-where} # not needed using '-where'
4649
? $_[1]->{-key}
4650
: $_[1]->{-table} # key described
4651
&& $_[0]->{-table}->{$_[1]->{-table}}->{-key}
4652
0
? {(map {($_=>$_[2]->{$_})}
4653
0
0
0
0
0
@{$_[0]->{-table}{$_[1]->{-table}}->{-key}})}
0
0
0
0
0
4654
: $_[2]->{'id'} # 'id' field present
4655
? {'id'=>rmlIdSplit(@_[0,1],$_[2]->{'id'})}
4656
: undef
4657
}
4658
4659
4660
sub rmlIdSplit {# Split record ID into table name and real ID
4661
# ($self, {command}, key value)
4662
0
!$_[0]->{-idsplit}
4663
? $_[2]
4664
: ref($_[0]->{-idsplit})
4665
0
? &{$_[0]->{-idsplit}}(@_)
4666
: $_[2] =~m/([^\Q$RISM0\E]+)\Q$RISM1\E((?:.(?!\Q$RISM1\E))+)$/
4667
# !!! optimize: 'database $RISM0 table $RISM1 rowid'
4668
0
0
0
0
? eval{$_[1]->{-table}=$1; $2} # 'table//rowid', table !~m!/!, rowid !~m!//!
0
0
0
4669
: $_[2]
4670
}
4671
4672
4673
sub rmiTrigger {# Execute trigger
4674
# (record manipulation internal)
4675
# self, {command}, {data}, {record}, trigger names
4676
0
0
0
0
my $tbl =$_[1]->{-table} && $_[0]->{-table}->{$_[1]->{-table}};
4677
0
0
my $frm =$_[1]->{-form} && $_[0]->{-form} && $_[0]->{-form}->{$_[1]->{-form}};
4678
0
0
local $_[1]->{-cmdt} =$tbl || $frm; # table metadata
4679
0
0
local $_[1]->{-cmdf} =$frm || $tbl; # form metadata
4680
0
local $_[0]->{-affect} =undef;
4681
0
local $_[0]->{-rac} =undef;
4682
0
foreach my $t (@_[4..$#_]) {
4683
0
$_[0]->logRec('rmiTrigger'
4684
, (caller(1))[3] =~/([^:]+)$/ ? $1 : (caller(1))[3]
4685
, -cmd=>$_[1]->{-cmd} || 'undef'
4686
, $tbl && $_[1]->{-table} ? (-table=>$_[1]->{-table}) : ()
4687
, $frm && $_[1]->{-form} ? (-form=>$_[1]->{-form}) : ()
4688
, $_[1]->{-key} ? (-key=>$_[1]->{-key}) : ()
4689
# , $_[2] ? (-data=>$_[2]) : ()
4690
, join(' ',@_[4..$#_])
4691
) if 0;
4692
0
0
0
&{$_[0]->{$t}}($_[0], $_[1], $_[2], $_[3]) if $_[0]->{$t} && !($t eq '-recInsID' && $tbl && $tbl->{$t});
0
0
4693
0
0
0
&{$tbl->{$t}} ($_[0], $_[1], $_[2], $_[3]) if $tbl && $tbl->{$t};
0
4694
0
0
0
&{$frm->{$t}} ($_[0], $_[1], $_[2], $_[3]) if $frm && $frm->{$t} && ($frm->{$t} ne $tbl->{$t});
0
0
4695
}
4696
0
$_[0]
4697
}
4698
4699
4700
sub rmiIndex { # Index record
4701
# {-table=>name}, {newData=>value}, {oldData=>value}
4702
0
0
0
my ($s, $a, $d, $r) =@_;
4703
0
my $n =$d; # {%$r} ||{}; @{$n}{keys %$d} =values %$d;
4704
0
my @q =([undef,'-'],[undef,'+']);
4705
0
local $s->{-affect} =undef;
4706
0
local $s->{-rac} =undef;
4707
0
0
if (my $m =$s->{-table}->{$a->{-table}}->{-recIndex0R}) {
4708
0
&$m($s, $a, $d, $r)
4709
}
4710
0
foreach my $x (keys %{$s->{-table}}) {
0
4711
0
0
next if !ref($s->{-table}->{$x}->{-ixcnd});
4712
0
my $i =$s->{-table}->{$x};
4713
0
0
0
$q[0]->[0] =$r && &{$i->{-ixcnd}}($s, $a, $r) ? $r : 0; # delete
4714
0
0
0
$q[1]->[0] =$d && &{$i->{-ixcnd}}($s, $a, $n) ? $n : 0; # insert/update
4715
0
foreach my $q (@q) {
4716
0
0
next if !$q->[0];
4717
0
my $v = $i->{-ixrec}
4718
0
? &{$i->{-ixrec}}($s, $a, $q->[0], $q->[1])
4719
: $i->{-field} && ref($i->{-field}) eq 'ARRAY'
4720
0
0
? {map {$q->[0]->{$_}} grep {ref($_) && $_->{-fld}} @{$i->{-field}}}
0
0
4721
: $i->{-field} && ref($i->{-field}) eq 'HASH'
4722
0
0
0
? {map {$q->[0]->{$_}} keys %{$i->{-field}}}
0
0
0
0
4723
: undef;
4724
0
0
foreach my $r (!ref($v) ? () : ref($v) eq 'ARRAY' ? @$v : ($v)) {
0
4725
0
my $k =rmlKey($s, {-table=>$x}, $r);
4726
0
$q->[1] eq '-'
4727
? $s->dbiDel({-table=>$x, -key=>$k}, $r)
4728
0
0
: 1 && eval{$s->dbiIns({-table=>$x, -key=>$k}, $r)}
0
4729
? 0 # !!! dbiIns better, dbiUpd safer
4730
: $s->dbiUpd({-table=>$x, -key=>$k, -save=>1}, $r, $d);
4731
}
4732
}
4733
}
4734
$d
4735
0
}
4736
4737
4738
sub recIndex { # Update/delete index entry, for calls from '-recIndex0R'
4739
# index name, {key}, {data}||undef
4740
0
!$_[0]->{-table}->{$_[1]}->{-ixcnd}
4741
0
0
0
1
? &{$_[0]->{-die}}('recIndex(' .$_[1] .') -> not described index' .$_[0]->{-ermd})
0
4742
: $_[3]
4743
? $_[0]->dbiUpd({-table=>$_[1], -key=>$_[2], -save=>1}, $_[$#_])
4744
: $_[0]->dbiDel({-table=>$_[1], -key=>$_[2]});
4745
}
4746
4747
4748
sub recReindex{ # Reindex database
4749
# self, clear, indexes
4750
0
0
1
my ($s, $c, @i) =@_;
4751
0
$s->varLock();
4752
0
my @t =grep {!$s->{-table}->{$_}->{-ixcnd}} $s->mdlTable();
0
4753
0
0
@i =grep { $s->{-table}->{$_}->{-ixcnd}} keys %{$s->{-table}} if !@i;
0
0
4754
0
0
if ($c) {
4755
0
foreach my $i (@i) {
4756
0
$s->dbiTrunc($i);
4757
}
4758
}
4759
0
foreach my $t (@t) {
4760
0
$s->logRec('recReindex', $t);
4761
0
my $a ={-table=>$t,-version=>1};
4762
0
my $c =$s->recSel(%$a);
4763
0
my $r;
4764
0
while ($r =$c->fetchrow_hashref()) {
4765
0
$s->logRec('recReindex',$r);
4766
0
$s->rmiIndex($a, $r)
4767
}
4768
}
4769
$s
4770
0
}
4771
4772
4773
sub rfdName { # Record's files directory name
4774
# self, command |table name, record data, subdirectory,...
4775
0
0
0
0
my $t =ref($_[1]) ? $_[1]->{-table} : $_[1];
4776
0
my $m =$_[0]->{-table}->{$t};
4777
join('/'
4778
, $_[0]->{-cgibus}
4779
? ($t
4780
,$_[2]->{$m->{-rvcActPtr} ||$_[0]->{-rvcActPtr} ||'-none'} ? 'ver' : 'act')
4781
: ($_[2]->{$m->{-rvcActPtr} ||$_[0]->{-rvcActPtr} ||'-none'} ? 'v' : 'a'
4782
,$t)
4783
0
0
, &{$m->{-rfdName}
4784
||$_[0]->{-rfdName}
4785
0
0
||sub{ my $r ='';
4786
0
foreach my $e (@_[1..$#_]) {
4787
0
for (my $i =0; $i <=length($e); $i +=3) {
4788
0
my $v =substr($e, $i, 3);
4789
# $v =~s/([,;+:'"?*%\/\\])/uc sprintf("%%%02x",ord($1))/eg;
4790
0
$v =~s/([^a-z0-9_-])/uc sprintf("%%%02x",ord($1))/eg;
0
4791
0
$r .=$v .'/'
4792
}
4793
}
4794
0
chop($r);
4795
0
$r
4796
0
0
0
}}(
4797
$_[0]
4798
0
, map { defined($_[2]->{$_}) ? $_[2]->{$_} : $_[1]->{-key}->{$_}
4799
0
} @{$m->{-key}})
4800
. $RISM2
4801
0
0
0
, map { my $v =$_;
0
0
0
0
0
4802
0
$v =~s/([,;+:'"?*%])/uc sprintf("%%%02x",ord($1))/eg;
0
4803
0
$v} @_[3..$#_] # encoding as 'rfaUpload'
4804
)
4805
}
4806
4807
4808
sub rfdPath { # Record's files directory path
4809
# self, -path|-url|-urf, rfdName |{data} |({command}|table, {data}), ?subdirectory...
4810
0
0
0
1
return(undef) if !$_[0]->{$_[1]};
4811
join('/'
4812
, $_[0]->{-cgibus}
4813
? ($_[1] eq '-path'
4814
? $_[0]->{-cgibus}
4815
: $_[1] ne '-urf'
4816
? $_[0]->{$_[1]}
4817
: !$_[0]->{$_[1]} # !!! lost code, for example
4818
? (($ENV{REMOTE_ADDR}||'') ne '127.0.0.1' ? $_[0]->{-url} : $_[0]->{-path})
4819
: $_[0]->{$_[1]})
4820
: $_[1] ne '-urf'
4821
? $_[0]->{$_[1]} .'/rfa' # -url, -path
4822
: !$_[0]->{$_[1]} # !!! lost code, for example
4823
? (($ENV{REMOTE_ADDR}||'') ne '127.0.0.1' ? $_[0]->{-url} : $_[0]->{-path}) .'/rfa'
4824
: ($_[0]->{-urf} eq $_[0]->{-url})
4825
|| (substr($_[0]->{-urf},7) eq $_[0]->{-path})
4826
? $_[0]->{-urf} .'/rfa'
4827
: $_[0]->{-urf}
4828
, !ref($_[3]) # rfdName, !ref($_[2]) && !ref($_[3])
4829
? ((ref($_[2])
4830
? $_[2]->{-file}
4831
0
|| return(&{$_[0]->{-die}}('rfdPath(' .$_[0]->strdata(@_) .') -> no file attachments' .$_[0]->{-ermd})||'')
4832
: $_[2])
4833
0
0
0
,map {my $v =$_;
0
0
0
0
0
0
0
0
0
0
0
0
0
4834
0
$v =~s/([,;+:'"?*%])/uc sprintf("%%%02x",ord($1))/eg;
0
4835
0
$v} @_[3..$#_]) # encoding as 'rfdName' and 'rfaUpload'
4836
: rfdName($_[0],@_[2..$#_]))
4837
}
4838
4839
4840
sub rfdEdmd { # Record's files directory editing allowed?
4841
# self, command |table name, record data
4842
my $m =$_[0]->{-table}->{
4843
0
0
0
0
1
ref($_[1])
0
4844
? ($_[1]->{-table} || $_[1]->{-form} && $_[0]->{-form}->{$_[1]->{-form}}->{-table})
4845
: ($_[0]->{-table}->{$_[1]} && $_[1] ||$_[0]->{-form}->{$_[1]}->{-table})
4846
};
4847
0
0
my $u =$m->{-rvcChgState} ||$_[0]->{-rvcChgState};
4848
0
0
my $v =$m->{-rvcActPtr} ||$_[0]->{-rvcActPtr};
4849
0
my $r =$_[2];
4850
0
0
0
!$v || ($u && ($r->{$u->[0]} && grep {$r->{$u->[0]} eq $_} @{$u}[1..$#$u]))
0
0
0
4851
}
4852
4853
4854
sub rfdTime { # mtime of record files directory
4855
# self, (command |table name, record data) |rfdName
4856
0
0
0
0
(stat(rfdPath($_[0], -path=>$_[2] ? rfdName(@_[0..2]) : $_[1])))[9];
4857
}
4858
4859
4860
sub rfdStamp { # Stamp record with files directory name, create if needed
4861
# self, command |table name, record data, acl set
4862
0
0
0
my $d =rfdName(@_[0..2]);
4863
0
my $p =rfdPath($_[0],-path=>$d);
4864
0
my $e =rfdEdmd(@_[0..2]);
4865
0
my $r =$_[2];
4866
0
my $w =$_[3];
4867
4868
0
0
0
if ($e && !-d $p) {
4869
0
0
0
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
4870
0
$_[0]->pthMk($p);
4871
}
4872
4873
0
0
if (-d $p) { $r->{-file} =$d; $r->{-fupd} =$d if $e}
0
0
0
4874
0
else { delete $r->{-file}; delete $r->{-fupd}}
0
4875
4876
0
0
0
if ($r->{-file} && $w) { # set ACL
4877
0
0
0
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
4878
0
my $s =$_[0];
4879
0
0
my $m =$s->{-table}->{ref($_[1]) ? $_[1]->{-table} : $_[1]};
4880
0
0
my $wr=$m->{-racReader} ||$s->{-racReader};
4881
0
0
$wr=[map {defined($r->{$_}) ? (split /\s*[,;]\s*/i, $r->{$_}) : ()} @$wr] if $wr;
0
0
4882
0
0
my $ww=$m->{-racWriter} ||$s->{-racWriter};
4883
0
0
$ww=[map {defined($r->{$_}) ? (split /\s*[,;]\s*/i, $r->{$_}) : ()} @$ww] if $ww;
0
0
4884
0
0
0
if ($wr ||$ww) {
4885
0
0
my $ld=$^O eq 'MSWin32' && $s->w32domain() || '';
4886
0
0
my @wa= map {$_ =~s/ /_/g; $_}
0
0
0
0
4887
0
0
map {$_ =~/^([^\\@]+)([\\@])([^\\@]+)$/
0
4888
? ($_, $3 .($2 eq '@' ? '\\' : '@') .$1)
4889
: $ld
4890
? ($_, $ld .'\\' .$_, $_ .'@' .$ld)
4891
: $_}
4892
0
(map {!$_ ? () : ref($_) ? @$_ : ($_)
4893
} $s->{-fswtr}, $s->{-fsrdr}, $ww, $wr);
4894
# ||getlogin()
4895
0
my $wf=$s->hfNew('+>',"$p/.htaccess");
4896
0
$wf->store('', "\n"
4897
,"require user\t" .join(' ',@wa), "\n"
4898
,"require group\t" .join(' ',@wa), "\n"
4899
,'',"\n");
4900
0
$wf->close();
4901
}
4902
0
0
0
if (($wr ||$ww) && $^O eq 'MSWin32' && Win32::IsWinNT()) { # $ENV{OS} && $ENV{OS}=~/Windows_NT/i
0
0
4903
# !!! WMI may be better/faster for all filesystem security
4904
# MSDN: WMI Security Descriptor Objects
4905
# Win32_LogicalFileSecuritySetting
4906
# Win32_LogicalFileSecuritySetting.GetSecurityDescriptor
4907
# Win32_LogicalFileSecuritySetting.SetSecurityDescriptor
4908
# Win32_SecurityDescriptor
4909
# Win32_ACE # how to create?
4910
# Win32_Trustee # how to create?
4911
# $wmiobj=Win32::OLE->GetObject("winmgmts:Win32_LogicalFileSecuritySetting.path='$obj'")
4912
# $out=$wmiobj->ExecMethod_("GetSecurityDescriptor");
4913
# die if !$out ||$out->{ReturnValue};
4914
# $out->{Descriptor}->{Owner}->{Domain}
4915
# .'\\' .$out->{Descriptor}->{Owner}->{Name};
4916
# $dacl=$out->{Descriptor}->{DACL};
4917
# die if !$dacl;
4918
# foreach my $k (@$dacl) {
4919
# $k->{Trustee}->{Domain}
4920
# $k->{Trustee}->{Name}
4921
# $k->{AceType}
4922
# 0 ADS_ACETYPE_ACCESS_ALLOWED
4923
# =| $k->{AccessMask}
4924
# 1 ADS_ACETYPE_ACCESS_DENIED
4925
# =& $k->{AccessMask}
4926
# %permf=('FULL'=>2032127,'CHANGE'=>1245631,'ADD&READ&EXECUTE'=>1180095,'ADD&READ'=>1180063,'READ&EXECUTE'=>1179817,'READ'=>1179785,'ADD'=>1048854);
4927
# %permd=('FULL'=>2032127,'CHANGE'=>1245631,'ADD&READ'=>1180095,'READ'=>1179817,'LIST'=>1179785,'ADD'=>1048854);
4928
# $k->{AccessMask} >=$perm{$k->{AccessMask}}
4929
# xcacls.vbs
4930
# objLocator.ConnectServer.Get("Win32_SecurityDescriptor").Spawninstance_
4931
#
4932
0
$p =~s/\//\\/g;
4933
0
$s->pthStamp($p); # access control
4934
0
delete $s->{-c}->{-pthStamp};
4935
0
0
0
if ($e && $ww) {
4936
0
0
foreach my $u (map {m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_} @$ww) {
0
4937
0
0
$s->osCmd('-i'
0
0
4938
, $s->{-w32xcacls} ? 'xcacls' : 'cacls'
4939
, "\"$p\""
4940
, '/E','/T','/C','/G'
4941
, ($u =~/\s/ ? "\"$u\"" : $u) .':F'
4942
, $s->{-w32xcacls} ? '/Y' : ())
4943
}
4944
0
0
foreach my $u (map {m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_} $wr ? @$wr : ()) {
0
0
4945
0
0
$s->osCmd('-i'
0
0
4946
, $s->{-w32xcacls} ? 'xcacls' : 'cacls'
4947
, "\"$p\""
4948
, '/E','/T','/C','/G'
4949
, ($u =~/\s/ ? "\"$u\"" : $u) .':R'
4950
, $s->{-w32xcacls} ? '/Y' : ())
4951
}
4952
}
4953
else {
4954
0
0
foreach my $u (map {m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_
0
0
0
4955
} map {$_ ? @$_ : ()} $ww, $wr) {
4956
0
0
$s->osCmd('-i'
0
0
4957
, $s->{-w32xcacls} ? 'xcacls' : 'cacls'
4958
, "\"$p\""
4959
, '/E','/T','/C','/G'
4960
, ($u =~/\s/ ? "\"$u\"" : $u) .':R'
4961
, $s->{-w32xcacls} ? '/Y' : ())
4962
}
4963
}
4964
}
4965
0
0
0
if ($w && ($w =~/^\d+$/)) {
4966
0
my $wa =(stat($p))[8];
4967
0
0
$s->logRec('utime', $s->strtime($wa||$w), $s->strtime($w), $r->{-file});
4968
0
0
utime($wa ||$w, $w, $p);
4969
}
4970
}
4971
4972
0
$r->{-file}
4973
}
4974
4975
4976
sub rfdCp { # Copy record's files directory to another record
4977
# self, source {record} |rfdName, dest {command} |table, {record}
4978
0
0
0
0
0
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
4979
0
0
my $fd =ref($_[1]) ? $_[1]->{-file} : $_[1];
4980
0
0
return(0) if !$fd;
4981
0
my $fp =rfdPath($_[0],-path=>$fd);
4982
0
0
return(0) if ! -d $fp;
4983
0
my $td =rfdName($_[0], @_[2..$#_]);
4984
0
my $tp =rfdPath($_[0],-path=>$td);
4985
0
0
$_[0]->pthCp('-rdp*',$fp,$tp)
4986
&& ($_[3]->{-file} =$td);
4987
}
4988
4989
4990
sub rfdRm { # Remove record's files directory
4991
# self, rfdName |{record} |({command} |table, {record})
4992
0
0
0
0
1
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
4993
0
0
0
my $p =rfdPath($_[0], -path=>ref($_[1]) && $_[1]->{-file} ? $_[1]->{-file} : @_[1..max($_[0], 2, $#_)]);
4994
0
0
0
$p =-d $p ? $_[0]->pthRm('-r', $p) && $_[0]->pthCln($p) : $p;
4995
0
0
0
delete $_[1]->{-file} if $p && ref($_[1]);
4996
0
$p
4997
}
4998
4999
5000
sub rfdCln { # Clean record's files directory, delete if empty
5001
# self, rfdName |{record} |({command} |table, {record})
5002
0
0
0
0
0
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
5003
0
0
0
my $p =rfdPath($_[0], -path=>ref($_[1]) && $_[1]->{-file} ? $_[1]->{-file} : @_[1..max($_[0], 2, $#_)]);
5004
0
$p =$_[0]->pthCln($p);
5005
0
0
0
delete $_[1]->{-file} if $p && ref($_[1]) && !-d $p;
0
5006
0
$p
5007
}
5008
5009
5010
sub rfdGlobn { # Glob record's files directory, return attachments names
5011
# self, rfdName |{record} |({command} |table, {record}), subdirectory...
5012
0
0
1
$_[0]->pthGlobn($_[0]->rfdPath(-path=>@_[1..$#_]) .'/*')
5013
}
5014
5015
5016
sub rfaRm { # Delete named attachment(s) in record's files directory
5017
# self, rfdName |{record} |({command} |table, {record}), attachment|[attachments]
5018
0
0
0
0
1
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
5019
0
grep {$_[0]->pthRm('-r',$_[0]->rfdPath(-path=>@_[1..$#_-1], $_))
0
5020
0
0
} ref($_[$#_]) ? @{$_[$#_]} : $_[$#_]
5021
}
5022
5023
5024
sub rfaUpload { # Upload named attachment into record's files directory
5025
# self, rfdName |{record} |({command} |table, {record}), cgi file
5026
0
0
0
0
1
$_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf};
5027
0
my $fn =$_[0]->cgi->param($_[$#_]);
5028
0
0
$fn =$fn =~/[\\\/]([^\\\/]+)$/ ? $1 : $fn;
5029
0
$fn =~s/([,;+:'"?*%])/uc sprintf("%%%02x",ord($1))/eg;
0
5030
my $fh =$_[0]->cgi->upload($_[$#_])
5031
0
0
||return(&{$_[0]->{-die}}($_[0]->lng(0,'rfaUpload') ."('" .$_[$#_] ."') CGI::upload -> " .$_[0]->lng(1,'rfaUplEmpty') ."\n"));
5032
0
binmode($fh);
5033
0
eval('use File::Copy');
5034
0
File::Copy::copy($fh, $_[0]->rfdPath(-path=>@_[1..$#_-1], $fn))
5035
0
0
|| &{$_[0]->{-die}}($_[0]->lng(0,'rfaUpload') ."('" .$_[$#_] ."'): File::Copy::copy -> $!\n");
5036
0
eval{close($fh)};
0
5037
}
5038
5039
5040
sub recActor { # User's role ('admin','owner','-...', field); cached using -editable
5041
# (table|command, record, ?db record , role | field | 0,...) -> boolean
5042
0
0
0
1
return(1) if $_[0]->uadmin();
5043
0
0
0
return(recActor($_[0],$_[1],$_[3]||$_[2],@_[4..$#_]))
0
0
5044
if ref($_[3]) ||(!$_[3] && ($#_ >3));
5045
0
0
0
return(undef) if !$_[3]
5046
|| !ref($_[2]);
5047
0
0
0
return($_[2]->{-editable})
0
5048
if exists($_[2]->{-editable})
5049
&& (!$_[2]->{-editable} || !$_[3]);
5050
0
0
return(scalar(grep {recActor($_[0],$_[1],$_[2],$_)} @_[3..$#_]))
0
5051
if $#_ >3;
5052
0
0
0
return($_[2]->{-editable}->{$_[3]})
5053
if ref($_[2]->{-editable})
5054
&& exists($_[2]->{-editable}->{$_[3]});
5055
0
my ($s,$f,$r,$n) =@_;
5056
0
0
if (!ref($f)) {}
0
0
0
5057
0
elsif ($f->{-cmdt}) {$f =$f->{-cmdt}}
5058
elsif ($f->{-table}) {$f =$f->{-table}}
5059
0
0
if (!exists($r->{-editable})) {
5060
0
0
my $mt=ref($f) ? $f : !$f ? undef : $s->mdeTable($f);
0
5061
0
0
return(undef) if !$mt;
5062
0
my $w =mdeWriters($s, $mt);
5063
0
0
$r->{-editable} =!$w ||$s->ugmember(map {$r->{$_}} @$w);
5064
0
0
return(undef) if !$r->{-editable};
5065
}
5066
0
0
return($_[2]->{-editable}) if !$n;
5067
0
0
$r->{-editable} ={} if !ref($r->{-editable});
5068
0
0
if ($n =~/^(-racOwner)$/) { # 'owner' role
0
5069
0
my $n =$1;
5070
0
0
my $mt =ref($f) ? $f : !$f ? undef : $s->mdeTable($f);
0
5071
0
$r->{-editable}->{$n} =1;
5072
0
foreach my $k (qw(-rvcInsBy -rvcUpdBy)) {
5073
0
0
my $nf=($mt && $mt->{$k}) || ($s->{$k}) || ($s->{-tn}->{$k});
5074
0
0
0
next if !$nf || !exists($r->{$nf})
0
5075
|| (lc($r->{$nf}) eq lc($s->user()));
5076
0
$r->{-editable}->{$n} =undef;
5077
last
5078
0
}
5079
}
5080
elsif (substr($n,0,1) eq '-') { # -racReader, -racWriter; -racActor, -racManager, -racPrincipal, -racUser
5081
0
0
my $mt =ref($f) ? $f : !$f ? undef : $s->mdeTable($f);
0
5082
0
0
$r->{-editable}->{$n} =$s->ugmember(
5083
0
0
0
map {$r->{$_} ? $r->{$_} : ()
0
5084
0
} @{($mt && $mt->{$n}) || $s->{$n} ||[]})
5085
}
5086
else { # field name
5087
0
0
0
$r->{-editable}->{$n} =!defined($r->{$n}) || ($r->{$n} eq '')
5088
? undef
5089
: $s->ugmember($r->{$n})
5090
}
5091
#$s->logRec('recActor',$n) if $r->{-editable}->{$n};
5092
0
$r->{-editable}->{$n}
5093
}
5094
5095
5096
sub recActLim { # Bound fields
5097
0
0
1
my ($s, $c, $rn, $rb, $fo, @fn) =@_; # (cmd, new data, db data, opt, fld names | -recDel)
5098
0
0
my $rr =ref($rn) ? $rn : $rb; # 1-'v'iew, 2-e'x'clude
5099
0
0
return(undef) if !ref($rr); # []-restrict values; '-recRead'
5100
0
$s->logRec('recActLim',$c->{-cmd},$fo, @fn);
5101
0
0
if ($fo eq '-recRead') {
5102
0
delete $rr->{-editable};
5103
0
0
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,$c->{-cmd}) .": " .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef)
0
5104
if $c->{-cmd}
5105
&& ($c->{-cmd} !~/^(?:recRead)$/);
5106
0
return(1)
5107
}
5108
0
0
0
delete $rr->{-editable} if ref($rr->{-editable}) && exists($rr->{-editable}->{-racWriter}) && !$rr->{-editable}->{-racWriter};
0
5109
0
0
$s->recActor($c, $rr, 0) if !$rr->{-editable};
5110
0
0
0
return(undef) if !$rr->{-editable} && !$rr->{-new};
5111
return(!$c->{-cmdt}
5112
0
0
0
? return(&{$s->{-die}}($s->lng(0,'recActLim') ." no {-cmdt}" .$s->{-ermd}) && undef)
5113
: $s->recActLim($c, $rn, $rb, $1
5114
0
, (map{ my $n =(ref($_) ne 'HASH') ||!$_->{-fld}
5115
||(exists($_->{-edit}) && (!$_->{-edit} || ref($_->{-edit})))
5116
||($_->{-flg} && ($_->{-flg}!~/[aeu]/))
5117
? '' : $_->{-fld};
5118
0
!$n
5119
? ()
5120
0
0
: !(grep {$n eq $_} @_[5..$#_])
0
5121
? ($n)
5122
: ()
5123
0
0
0
} @{$c->{-cmdt}->{-field}})))
0
5124
if $fo =~/^(\w)!/;
5125
0
0
$rr->{-editable} ={} if !ref($rr->{-editable});
5126
0
0
$rr->{-editable}->{-fr} ={} if !$rr->{-editable}->{-fr};
5127
0
0
0
$fo = $fo eq 'v' ? 1 : $fo eq 'x' ? 2 : 1
0
0
0
5128
if $fo && !ref($fo) && $fo =~/\w/;
5129
0
my $fh =$rr->{-editable}->{-fr}; # fields restrictions hash
5130
0
my $ds =undef; # delete restriction
5131
0
0
0
if ($c->{-cmd} && ($c->{-cmd} =~/^(?:recRead|recForm)$/)
0
0
0
5132
&& !$c->{-edit} ) {
5133
0
0
$fh->{-recDel} =$ds =1 if grep /^-recDel$/, @fn;
5134
}
5135
elsif ($c->{-cmd} && ($c->{-cmd} =~/^(?:recNew|recRead|recForm|recDel)$/)) {
5136
0
foreach my $fn (@fn) {
5137
0
$fh->{$fn} =$fo;
5138
0
0
0
if (ref($fo) && $rn && defined($rn->{$fn})
0
0
0
5139
&& !grep {$rn->{$fn} eq $_} @$fo) {
5140
0
$rn->{$fn} =$fo->[0];
5141
}
5142
0
0
$ds =1 if $fn eq '-recDel';
5143
}
5144
}
5145
else {
5146
0
foreach my $fn (@fn) {
5147
0
$fh->{$fn} =$fo;
5148
0
0
$ds =1 if $fn eq '-recDel';
5149
0
0
0
if (!$fo
0
5150
|| (substr($fn,0,1) eq '-')
5151
) {
5152
}
5153
elsif (ref($fo)) { # restricted values
5154
0
0
0
if (ref($rn) && (ref($fo) eq 'ARRAY')) {
5155
return(&{$s->{-die}}($s->{-ermu}
5156
.$s->lng(0,'recUpd')
5157
." ('$fn', "
5158
0
.join(', ', map {defined($_) ? "'$_'" : 'undef'
5159
} $rn->{$fn}, @$fo)
5160
."): " .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef)
5161
if !defined($rn->{$fn})
5162
0
0
0
|| !(grep {$rn->{$fn} eq $_} @$fo);
0
5163
}
5164
}
5165
0
0
0
if (ref($rn) && ref($rb)) {
0
5166
0
0
if ($fo ==1) { # view only
0
5167
return(&{$s->{-die}}($s->{-ermu}
5168
.$s->lng(0,'recUpd')
5169
." ('$fn', "
5170
0
0
0
.join(', ', map {defined($_) ? "'$_'" : 'undef'
0
0
5171
} $rn->{$fn}, $rb->{$fn})
5172
."): " .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef)
5173
if (defined($rn->{$fn}) ? $rn->{$fn} : '')
5174
ne (defined($rb->{$fn}) ? $rb->{$fn} : '');
5175
}
5176
elsif ($fo ==2) { # exclude
5177
0
delete $rn->{$fn}
5178
}
5179
}
5180
elsif (!$rb) {
5181
0
0
if ($fo ==1) { # view only
0
5182
}
5183
elsif ($fo ==2) { # exclude
5184
0
delete $rn->{$fn}
5185
}
5186
}
5187
}
5188
}
5189
0
0
if ($ds) {
5190
0
0
$ds =$c->{-cmdt} && $c->{-cmdt}->{-rvcDelState} ||$s->{-rvcDelState};
5191
0
$fh->{$ds->[0]} =[grep { $_ ne $ds->[1]
0
5192
} ref($fh->{$ds->[0]})
5193
0
? @{$fh->{$ds->[0]}}
5194
0
0
0
: @{$c->{-cmdt}->{-mdefld}->{$ds->[0]}->{-inp}->{-values}}
0
0
0
0
0
0
5195
]
5196
if $ds
5197
&& (!$fh->{$ds->[0]} || (ref($fh->{$ds->[0]}) eq 'ARRAY'))
5198
&& $c->{-cmdt}->{-mdefld} && $c->{-cmdt}->{-mdefld}->{$ds->[0]}
5199
&& $c->{-cmdt}->{-mdefld}->{$ds->[0]}->{-inp}
5200
&& (ref($c->{-cmdt}->{-mdefld}->{$ds->[0]}->{-inp}->{-values}) eq 'ARRAY');
5201
0
0
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recDel') .": " .$s->lng(1,'recDelAclStp') .$s->{-ermd}) && undef)
0
0
0
0
0
0
0
5202
if ($c->{-cmd} && ($c->{-cmd} eq 'recDel'))
5203
|| ($c->{-cmd} && ($c->{-cmd} !~/^(?:recRead|recForm)$/)
5204
&& $ds && $rn && $rn->{$ds->[0]}
5205
&& ($rn->{$ds->[0]} eq $ds->[1]));
5206
}
5207
1
5208
0
}
5209
5210
5211
sub recNew { # Create new record to be inserted into database
5212
# -table=>name, field=>value || -data=>{values}
5213
# -key=>prototype record key, -proto=>{values}
5214
0
0
1
my $s =$_[0];
5215
0
$s->logRec('recNew', @_[1..$#_]);
5216
0
0
0
my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]});
0
5217
0
0
my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a;
0
0
5218
0
my $r =$d;
5219
0
$a->{-cmd} ='recNew';
5220
0
$a->{-table}=recType ($s, $a, $d);
5221
0
$a->{-key} =rmlKey($s, $a, {});
5222
0
my $m =mdeTable($s,$a->{-table});
5223
0
foreach my $w (qw(-rvcInsBy -rvcUpdBy)) {foreach my $c ($m, $s) {
0
5224
0
0
next if !$c->{$w}; $r->{$c->{$w}} =$s->user; last
0
5225
0
}}
5226
0
foreach my $w (qw(-rvcInsWhen -rvcUpdWhen)) {foreach my $c ($m, $s) {
0
5227
0
0
next if !$c->{$w}; delete $r->{$c->{$w}}; last
0
5228
0
}}
5229
0
foreach my $w (qw(id -file -fupd)) {
5230
0
delete $r->{$w};
5231
}
5232
0
$r->{-new} =$s->strtime();
5233
0
0
0
$r->{-editable} =1 if $s->{-rac} && ($m->{-racWriter}||$s->{-racWriter});
0
5234
0
rmiTrigger($s, $a, $r, undef, qw(-recForm0C));
5235
0
0
my $p =$a->{-proto} || ((grep {$_} values %{$a->{-key}}) ? $s->recRead_($m, {%$a, -data=>undef, -test=>1}) : {});
5236
0
rmiTrigger($s, $a, $r, $p, qw(-recNew0C));
5237
0
rmiTrigger($s, $a, $r, undef, qw(-recForm0R -recFlim0R -recEdt0R -recNew0R -recNew1C -recForm1C));
5238
0
$r
5239
}
5240
5241
5242
sub recForm { # Recalculate record - new or existing
5243
# -table=>name, field=>value || -data=>{values}
5244
# -key=>original
5245
0
0
1
my $s =$_[0];
5246
# $s->logRec('recForm', @_[1..$#_]);
5247
0
0
0
my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]});
0
5248
0
0
my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a;
0
0
5249
0
$a->{-cmd} ='recForm';
5250
0
$a->{-table}=recType ($s, $a, $d);
5251
0
$a->{-key} =rmlKey($s, $a, $d);
5252
0
my $m =mdeTable($s,$a->{-table});
5253
0
rmiTrigger($s, $a, $d, undef, qw(-recForm0C));
5254
0
0
my $r =(!$d->{-new} && (grep {$_} values %{$a->{-key}}) && $s->recRead_($m, {%$a,-data=>undef,-test=>1}))
5255
||undef;
5256
0
0
map {$d->{$_} =$r->{$_} if !exists($d->{$_})} keys %$r if $r;
0
0
5257
0
foreach my $w (qw(-rvcInsBy -rvcUpdBy)) {foreach my $c ($m, $s) {
0
5258
0
0
next if !$c->{$w}; $d->{$c->{$w}} =$s->user if !$d->{$c->{$w}}; last
0
0
5259
0
}}
5260
0
0
0
$d->{-editable} =1
0
0
0
0
5261
if ($r && $r->{-editable})
5262
|| ($d->{-new} && $s->{-rac} && ($m->{-racWriter}||$s->{-racWriter}));
5263
0
rmiTrigger($s, $a, $d, $r, qw(-recForm0R -recFlim0R -recEdt0R -recForm1C));
5264
0
$d
5265
}
5266
5267
5268
sub recIns { # Insert record into database
5269
# -table=>table, field=>value || -data=>{values}
5270
# -key=>{sample}, -from=>cursor
5271
0
0
1
my $s =$_[0];
5272
0
0
0
$s->varLock if $s->{-serial} && $s->{-serial} ==2;
5273
0
$s->logRec('recIns', @_[1..$#_]);
5274
0
0
0
my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]});
0
5275
0
0
my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a;
0
0
5276
0
$a->{-cmd} ='recIns';
5277
0
$a->{-table}=recType ($s, $a, $d);
5278
0
$a->{-key} =rmlKey($s, $a, $d);
5279
0
my $m =mdeTable($s,$a->{-table});
5280
0
0
my $v =$m->{-rvcActPtr} ||$s->{-rvcActPtr};
5281
0
0
my $b =$m->{-rfa} ||$s->{-rfa};
5282
0
my $tu=time();
5283
5284
0
foreach my $w (qw(-rvcInsBy -rvcUpdBy)) {foreach my $c ($m, $s) {
0
5285
0
0
next if !$c->{$w}; $d->{$c->{$w}} =$s->user; last
0
5286
0
}}
5287
0
foreach my $w (qw(-rvcInsWhen -rvcUpdWhen)) {foreach my $c ($m, $s) {
0
5288
0
0
next if !$c->{$w}; $d->{$c->{$w}} =$s->strtime($tu); last
0
5289
0
}}
5290
5291
0
rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recIns0C));
5292
0
my $r =undef;
5293
0
0
my $p =(grep {$_} values %{$a->{-key}}) && $s->recRead_($m,{%$a, -data=>undef, -test=>1});
5294
0
0
if ($p) { # form record with prototype
5295
0
my $t =recData($s, $p);
5296
0
delete $t->{$v};
5297
0
@{$t}{keys %$d} =values %$d;
0
5298
0
0
if ($a eq $d) {$a =$d =$t}
0
0
5299
else {$d =$t}
5300
}
5301
5302
# !!! Permissions should be checked in -recIns0C trigger, no other way
5303
0
0
if ($a->{-from}) { # insert from cursor
5304
0
my $j =0;
5305
0
while (my $e =$a->{-from}->fetchrow_hashref()) {
5306
0
my $t ={%$e}; # readonly hash
5307
0
0
rfdStamp($s, $a, $t) if $b;
5308
0
@{$t}{recFields($s, $d)} =recValues($s, $d);
0
5309
0
rmiTrigger($s, $a, $t, undef, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recIns0R -recInsID -recChg0W));
5310
0
0
0
rfdCp ($s, $t->{-file}, $a, $t) if !$a->{-file} && $t && $t->{-file};
0
5311
0
0
0
rfdCp ($s, $p->{-file}, $a, $t) if !$a->{-file} && $p && $p->{-file};
0
5312
0
0
rfdCp ($s, $a->{-file}, $a, $t) if $a->{-file};
5313
0
0
0
rmiIndex ($s, $a, $t) if $m->{-index} ||$s->{-index};
5314
0
$r =$s->dbiIns($a, $t);
5315
0
0
0
rfdStamp($s, $a, $r, $tu) if $t && $t->{-file} || $p && $p->{-file};
0
0
5316
0
0
rmiTrigger($s, $a, $r, undef, qw(-recIns1R)) if $r;
5317
0
$j++;
5318
}
5319
0
$s->{-affected} =$j;
5320
0
0
rmiTrigger($s, $a, $r, undef, '-recIns1C', $j ==1 ? ('-recForm1C') : ())
0
5321
if $r;
5322
0
0
$r =$r ||$d;
5323
}
5324
else { # insert single record
5325
0
rmiTrigger($s, $a, $d, undef, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recIns0R -recInsID -recChg0W));
5326
0
0
0
rfdCp ($s, $p, $a, $d) if !$a->{-file} && $p && $p->{-file};
0
5327
0
0
rfdCp ($s, $a->{-file}, $a, $d) if $a->{-file};
5328
0
0
0
rmiIndex ($s, $a, $d, undef) if $m->{-index} ||$s->{-index};
5329
0
$r =$s->dbiIns($a, $d);
5330
0
rfdStamp ($s, $a, $r, $tu);
5331
0
0
0
$r->{-editable} =1 if $r && $s->{-rac} && ($m->{-racWriter}||$s->{-racWriter});
0
0
5332
0
$s->{-affected} =1;
5333
0
0
do { local $a->{-cmd} ='recRead';
0
5334
0
local $a->{-edit} =undef;
5335
0
rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recFlim0R -recRead0R -recIns1R -recRead1R))
5336
}
5337
if $r;
5338
0
0
rmiTrigger($s, $a, $r, undef, qw(-recIns1C -recRead1C -recForm1C))
5339
if $r;
5340
}
5341
0
return($r)
5342
}
5343
5344
5345
sub dbiTblExpr {# DBI / SQL table name expression
5346
0
0
0
0
0
!$_[0]->{-table}->{$_[1]} || !$_[0]->{-table}->{$_[1]}->{-expr}
0
5347
? $_[1]
5348
: $_[0]->{-table}->{$_[1]}->{-expr} =~/\s/
5349
? $_[0]->{-table}->{$_[1]}->{-expr}
5350
: $_[0]->{-table}->{$_[1]}->{-expr} .' AS ' .$_[1]
5351
}
5352
5353
5354
sub dbiTblExp1 {# DBI / SQL first table expression for insert/update/delete
5355
0
0
0
0
0
!$_[0]->{-table}->{$_[1]} || !$_[0]->{-table}->{$_[1]}->{-expr}
0
0
5356
? $_[1]
5357
: $_[0]->{-table}->{$_[1]}->{-expr} =~/^([^\s]+\s+AS\s+[^\s]+)/i
5358
? $1
5359
: $_[0]->{-table}->{$_[1]}->{-expr} =~/\s/
5360
? $`
5361
: $_[0]->{-table}->{$_[1]}->{-expr} # .' AS ' .$_[1] # sql syntax
5362
}
5363
5364
5365
sub dbiIns { # Insert record into database
5366
# -table=>table, field=>value
5367
# -save=>boolean, -sel=>boolean
5368
0
0
0
my ($s, $a, $d) =@_;
5369
0
my $f =$a->{-table};
5370
0
my @c;
5371
0
my $r =$a;
5372
0
$s->{-affected} =0;
5373
0
0
0
if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') {
0
0
0
0
5374
0
my $db=$s->dbi();
5375
0
my @a =recFields($s,$d);
5376
0
my @v;
5377
0
@c=( 'INSERT INTO '
5378
.dbiTblExp1($s, $f)
5379
.' (' .join(',', @a)
5380
.') VALUES ('
5381
.join(','
5382
, $s->{-dbiph}
5383
0
? map {'?'} @a
5384
0
: map {mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_})
5385
} @a)
5386
.')'
5387
0
0
, $s->{-dbiph} ? ({}, map {$d->{$_}} @a) : ()
0
5388
);
5389
0
$s->logRec('dbiIns', @c);
5390
0
0
0
$db->do(@c)|| return(&{$s->{-die}}($s->lng(0,'dbiIns') .": do() -> " .($DBI::errstr ||'Unknown') .$s->{-ermd}) && undef);
5391
0
$s->{-affected} =$DBI::rows;
5392
0
0
$s->{-affected} =-$s->{-affected} if $s->{-affected} <0;
5393
0
0
0
return($d) if ($s->{-affected} >1) ||$a->{-save};
5394
0
0
0
return($d) if defined($a->{-sel}) && !$a->{-sel};
5395
0
0
if ($s->{-dbiph}) {
5396
0
@a =grep {defined($d->{$_})} @a;
0
5397
0
@v =map {$d->{$_}} @a;
0
5398
}
5399
0
@c =('SELECT * FROM ' .dbiTblExp1($s, $f) .' WHERE '
5400
.join(' AND '
5401
, $s->{-dbiph}
5402
0
0
? map {"$_=?"} @a
5403
0
0
: map {defined($d->{$_})
5404
? ($_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_}))
5405
: ()
5406
} @a));
5407
0
0
$s->logRec('dbiIns', @c, @v ? {} : (), @v);
5408
0
$f =$db->prepare(@c);
5409
0
0
$r =$f && $f->execute(@v) && $f->fetchrow_hashref() || return(&{$s->{-die}}($s->lng(0,'dbiIns') .": selectrow_hashref() -> " .($DBI::errstr||'Empty result set') .$s->{-ermd}) && undef);
5410
}
5411
elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') {
5412
0
@c = ([map {$d->{$_}}
0
5413
0
@{$s->{-table}->{$f}->{-key}}]
5414
,($r =recData($s, $d)));
5415
0
$s->logRec('dbiIns','kePut', $f, @c);
5416
0
0
0
$s->dbmTable($f)->kePut(@c) || return(&{$s->{-die}}($s->lng(0,'dbiIns') .": kePut() -> $@" .$s->{-ermd}) && undef);
5417
0
$s->{-affected} =1;
5418
}
5419
elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'xmr') {
5420
}
5421
$r
5422
0
}
5423
5424
5425
sub dbiExplain {# Explain DML plan
5426
0
0
0
my $s =shift;
5427
0
0
0
return() if !$s->{-debug} || (defined($s->{-dbiexpl}) && !$s->{-dbiexpl});
0
5428
0
0
my $i =ref($_[0]) ? shift : $s->dbi;
5429
0
my $q =shift;
5430
0
eval {
5431
0
my $c =$i->prepare("explain $q");
5432
0
$c->execute;
5433
0
my $r;
5434
0
while ($r =$c->fetchrow_hashref()) {
5435
0
$s->logRec('dbiExplain', join(', ', map {"$_=> " .$s->strquot($r->{$_})} @{$c->{NAME}}));
0
0
5436
}
5437
}
5438
}
5439
5440
5441
sub recUpd { # Update record(s) in database
5442
# -table=>table, field=>value || -data=>{values}
5443
# -key=>{field=>value}, -where=>'condition', -version=>'+'|'-'
5444
# -optrec=>boolean, -sel=>boolean
5445
0
0
1
my $s =$_[0];
5446
0
0
0
$s->varLock if $s->{-serial} && $s->{-serial} ==2;
5447
0
$s->logRec('recUpd', @_[1..$#_]);
5448
0
0
0
my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]});
0
5449
0
0
my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a;
0
0
5450
0
$a->{-cmd} ='recUpd';
5451
0
$a->{-table}=recType ($s, $a, $d);
5452
0
$a->{-key} =rmlKey ($s, $a, $d);
5453
0
my $m =mdeTable($s,$a->{-table});
5454
0
my $r =undef;
5455
0
my $w =mdeWriters($s, $m);
5456
0
0
my $u =$m->{-rvcChgState} ||$s->{-rvcChgState};
5457
0
0
my $o =$m->{-rvcCkoState} ||$s->{-rvcCkoState};
5458
0
0
my $x =$m->{-rvcDelState} ||$s->{-rvcDelState};
5459
0
0
my $v =$m->{-rvcActPtr} ||$s->{-rvcActPtr};
5460
0
my $tu=time();
5461
0
0
my $t1=$m->{-rvcUpdWhen} ||$s->{-rvcUpdWhen};
5462
0
0
my $t2=$m->{-rvcVerWhen} ||$s->{-rvcVerWhen};
5463
0
0
my $i =$m->{-index} ||$s->{-index};
5464
0
0
my $b =$m->{-rfa} ||$s->{-rfa};
5465
0
my $e;
5466
0
0
local $a->{-version}= ref($a->{-version})
5467
? $a->{-version}
5468
: $v && (!$a->{-version} ||$a->{-version} eq '-')
5469
0
0
0
? [$v, @{$x||[]}]
0
0
5470
: ($a->{-version} ||'+');
5471
0
foreach my $w (qw(-rvcInsBy -rvcInsWhen)) {foreach my $c ($m, $s) {
0
5472
0
0
next if !$c->{$w}; delete $d->{$c->{$w}}; last
0
5473
0
}}
5474
0
foreach my $c ($m, $s) {
5475
0
0
next if !$c->{-rvcUpdBy}; $d->{$c->{-rvcUpdBy}} =$s->user; last
0
5476
0
}
5477
0
0
$d->{$t1} =$s->strtime($tu) if $t1;
5478
0
rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recUpd0C));
5479
0
0
0
if ($w ||$o ||$v ||$i ||grep {$s->{$_} || $m->{$_}} qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recChg0W -recUpd1R)) {
0
0
0
0
0
5480
0
my $c =$s->recSel(rmlClause($s, $a), -data=>undef);
5481
0
my $j =0;
5482
0
while ($r =$c->fetchrow_hashref()) {
5483
0
0
0
$j++; return(&{$s->{-die}}($s->lng(0,'recUpd') .": $j ". $s->lng(1,'-affected') .$s->{-ermd}) && undef)
0
0
5484
if $s->{-affect} && $j >$s->{-affect};
5485
# $r ={%$r}; # readonly hash, should be considered below
5486
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recUpd') .': ' .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef)
5487
0
0
0
if $w && !$s->ugmember(map {$r->{$_}} @$w);
0
5488
0
0
rfdStamp($s, $a, $r) if $b;
5489
0
my ($n, $p);
5490
0
0
0
if (($v && $r->{$v} # prohibit version
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
5491
&& (!$o || (defined($r->{$o->[0]})
5492
&& ($r->{$o->[0]} ne $o->[1]))))
5493
|| ($x && defined($r->{$x->[0]})
5494
&& ($r->{$x->[0]} eq $x->[1])
5495
&& (!defined($d->{$x->[0]})
5496
|| ($d->{$x->[0]} eq $x->[1])))
5497
) {
5498
0
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recUpd') .': ' .$s->lng(1,'recUpdVerStp') .$s->{-ermd}) && undef)
5499
}
5500
elsif ($o # check-in
5501
&& (($r->{$o->[0]}||'') eq $o->[1])
5502
&& defined($d->{$o->[0]})
5503
&& ($d->{$o->[0]} ne $o->[1])
5504
&& (!$x || (defined($d->{$x->[0]})
5505
&& ($d->{$x->[0]} ne $x->[1])))
5506
&& $r->{$v}) {
5507
0
my $t =$r->{'id'};
5508
0
$e =$s->recUpd(%$r, %{recData($s,$d)}
0
5509
, 'id'=>$r->{$v}
5510
, $v=>undef
5511
, -table=>$a->{-table}
5512
, -key=>{'id'=>$r->{$v}});
5513
0
0
rfdRm ($s, $a->{-table}, $r) if $r->{-file};
5514
0
0
rmiIndex($s, $a, undef, $r) if $i;
5515
0
$s->dbiDel({-table=>$a->{-table}, -key=>{'id'=>$t}});
5516
0
$n =undef;
5517
}
5518
elsif ($o # check-out
5519
&& (($r->{$o->[0]}||'') ne $o->[1])
5520
&& (($d->{$o->[0]}||'') eq $o->[1])) {
5521
0
$n ={%$r}; @{$n}{recFields($s, $d)} =recValues($s, $d);
0
0
5522
0
$n->{$v} =$r->{'id'};
5523
0
rmiTrigger($s, $a, $n, $n, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recInsID -recChg0W));
5524
0
0
rfdCp ($s, $r->{-file}, $a, $n) if $r->{-file};
5525
0
0
rfdStamp ($s, $a, $n, $tu) if $r->{-file};
5526
0
0
0
rmiIndex ($s, $a, $n, undef) if $m->{-index} ||$s->{-index};
5527
0
$e =$s->dbiIns($a, $n);
5528
0
0
$e->{-file} =$n->{-file} if $n->{-file};
5529
0
$n =undef;
5530
}
5531
elsif ($v && (!$u # version
5532
|| (defined($r->{$u->[0]})
5533
&& !grep {$r->{$u->[0]} eq $_
5534
} @{$u}[1..$#$u]))) {
5535
0
$n ={%$r}; @{$n}{recFields($s, $d)} =recValues($s, $d);
0
0
5536
0
$p ={%$r, $v=>$r->{'id'}, -table=>$a->{-table}};
5537
0
rmiTrigger($s, $a, $n, $r, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recChg0W));
5538
0
rmiTrigger($s, $a, $p, undef, qw(-recInsID));
5539
0
do { rfdCp ($s, $r->{-file}, $a, $p);
5540
0
0
rfdStamp($s, $a, $p, rfdTime($s, $a, $n)||'+');
5541
}
5542
if $r
5543
&& $r->{-file}
5544
&& (!$u
5545
|| $a->{-file}
5546
|| ($d->{$u->[0]}
5547
&& grep {$d->{$u->[0]} eq $_
5548
0
0
0
} @{$u}[1..$#$u]));
0
0
5549
0
0
0
do { rfdRm ($s, $a->{-table}, $n);
0
0
5550
0
rfdCp ($s, $a->{-file}, $a->{-table}, $n);
5551
0
rfdCln ($s, $a->{-table}, $n)
5552
}
5553
if $a->{-file}
5554
&& (!$r->{-file} || $r->{-file} ne $a->{-file});
5555
0
0
rfdStamp ($s, $a, $n, rfdTime($s, $a, $n)||'+');
5556
0
0
0
$p->{$t2} =$d->{$t1}
0
0
5557
if $t2 && $t1
5558
&& (exists($r->{$t2})
5559
|| ($m->{-mdefld} && $m->{-mdefld}->{$t2})
5560
|| (($m->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm'));
5561
0
0
rmiIndex ($s, $a, $n, $r) if $i;
5562
0
0
rmiIndex ($s, $a, $p) if $i;
5563
0
$p =$s->dbiIns({-table=>$a->{-table}, -save=>1}, $p);
5564
}
5565
else { # update only
5566
0
$n ={%$r}; @{$n}{recFields($s, $d)} =recValues($s, $d);
0
0
5567
0
rmiTrigger($s, $a, $n, $r, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recChg0W));
5568
0
0
0
do { rfdRm ($s, $a->{-table}, $n);
0
0
5569
0
rfdCp ($s, $a->{-file}, $a->{-table}, $n);
5570
}
5571
if $a->{-file}
5572
&& (!$r->{-file} || ($r->{-file} ne $a->{-file}));
5573
0
0
0
rfdStamp ($s, $a, $n, $tu)
5574
if $r && $r->{-file};
5575
0
rfdCln ($s, $a, $n)
5576
if $r && $r->{-file}
5577
&& $u
5578
&& $n->{$u->[0]}
5579
0
&& !grep {$n->{$u->[0]} eq $_
5580
0
0
0
} @{$u}[1..$#$u];
0
0
0
5581
0
0
rmiIndex ($s, $a, $n, $r) if $i;
5582
}
5583
0
0
if (1 && $n) {
5584
0
0
$s->logRec('dbiUpd','SINGLE') if $j ==1;
5585
0
0
$e =$s->dbiUpd({ -table=>$a->{-table}
5586
,-key=>$s->recWKey($a->{-table}, $r)
5587
# recKey, recWKey
5588
}, $n, $r || {});
5589
0
0
$s->{-affected} =$j if $s->{-affected};
5590
}
5591
}
5592
0
0
$r =$e || $s->dbiUpd($a, $d);
5593
}
5594
else {
5595
0
$r =$s->dbiUpd($a, $d);
5596
}
5597
0
0
0
return(&{$s->{-die}}($s->lng(0,'recUpd') .': ' .($s->{-affected}||0) .' ' .$s->lng(1,'-affected') .$s->{-ermd}) && undef)
0
0
5598
if $s->{-affect} && (($s->{-affected}||0) != $s->{-affect});
5599
0
0
0
if ($r && ($s->{-affected}||0) ==1) {
0
0
5600
0
0
rfdStamp($s, $a, $r)
5601
if $b;
5602
0
0
$r->{-editable} =$w ? $s->ugmember(map {$r->{$_}} @$w) : 1
0
0
5603
if $s->{-rac};
5604
0
{ local $a->{-cmd} ='recRead';
0
5605
0
local $a->{-edit} =undef;
5606
0
rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recFlim0R -recRead0R -recRead1R))
5607
};
5608
0
rmiTrigger($s, $a, $r, undef, qw(-recUpd1C -recRead1C -recForm1C));
5609
}
5610
elsif ($r) {
5611
0
rmiTrigger($s, $a, $r, undef, qw(-recUpd1C))
5612
}
5613
$r
5614
0
}
5615
5616
5617
5618
sub recUtr { # Translate values in database
5619
# (table || {cmd} ||false, field, new, old)
5620
# {-table, -version}
5621
# or recUpd() args
5622
0
0
1
my $s =$_[0];
5623
0
my $n =$_[1];
5624
0
0
0
$n =$s->{-pcmd}->{-table} ||$s->{-pcmd}->{-form} if !$n;
5625
0
0
0
$n->{-table} = $s->{-pcmd}->{-table} if ref($n) && !$n->{-table};
5626
0
my $a;
5627
0
0
0
if ($n && ($n !~/^-/)) {
5628
0
0
$a ={-table=>ref($n) ? $n->{-table} : $n
5629
, -key=>{}, -data=>{}, -sel=>0};
5630
0
0
0
if (!$_[4] && ref($_[2]) && ref($_[3])) { # {new}, {old}
0
0
0
0
0
0
0
0
5631
0
$a->{-data}=$_[2];
5632
0
$a->{-key} =$_[3];
5633
}
5634
elsif (!$_[2] && ref($_[3]) && ref($_[4])) { # !, {new}, {old}
5635
0
$a->{-data}=$_[3];
5636
0
$a->{-key} =$_[4]
5637
}
5638
elsif (ref($_[2]) eq 'HASH') { # {field/src}
5639
0
foreach my $k (keys %{$_[2]}) {
0
5640
0
0
if (ref($_[2]->{$k})) { # {field=>[new, old]}
5641
0
$a->{-data}->{$k} =$_[2]->{$k}->[0];
5642
0
$a->{-key}->{$k} =$_[2]->{$k}->[1]
5643
}
5644
else { # {src fld=>tgt fld}, {new}, {old}
5645
0
$a->{-data}->{$_[2]->{$k}} =$_[3]->{$k};
5646
0
$a->{-key}->{$_[2]->{$k}} =$_[4]->{$k};
5647
}
5648
}
5649
}
5650
elsif (ref($_[2])) { # [fields], [new], [old]
5651
0
for (my $i=0; $i <=$#{$_[2]}; $i++) {
0
5652
0
$a->{-data}->{$_[2]->[$i]} =$_[3]->[$i];
5653
0
$a->{-key}->{$_[2]->[$i]} =$_[4]->[$i]
5654
}
5655
}
5656
elsif ($_[2] && !ref($_[2])) { # field, new, old
5657
0
$a->{-data}->{$_[2]}=$_[3];
5658
0
$a->{-key}->{$_[2]} =$_[4];
5659
}
5660
else {
5661
0
0
return(&{$s->{-die}}("'recUtr' parameters unknown" .$s->{-ermd}) && undef);
5662
}
5663
0
0
0
if ((grep {!defined($a->{-data}->{$_})} keys %{$a->{-data}})
0
0
0
5664
0
|| (grep {!defined($a->{-key}->{$_})} keys %{$a->{-key}})){
5665
return(undef)
5666
0
}
5667
}
5668
else {
5669
0
0
0
$a = (@_< 3 && ref($n) ? {%{$n}} : {@_[1..$#_]});
0
5670
}
5671
0
0
0
$s->varLock if $s->{-serial} && $s->{-serial} ==2;
5672
0
$s->logRec('recUtr', @_[1..$#_]);
5673
0
0
my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a;
0
0
5674
0
$a->{-cmd} ='recUtr';
5675
0
$a->{-table}=recType ($s, $a, $d);
5676
0
$a->{-key} =rmlKey ($s, $a, $d);
5677
0
my $m =mdeTable($s,$a->{-table});
5678
0
0
my $x =$m->{-rvcDelState} ||$s->{-rvcDelState};
5679
0
0
my $v =$m->{-rvcActPtr} ||$s->{-rvcActPtr};
5680
0
0
0
local $a->{-version}= ref($n)
5681
? $n->{-version} ||'-' : '-'; # !!! ignoring chk-out
5682
0
0
$a->{-version}= ref($a->{-version})
5683
? $a->{-version}
5684
: $v && (!$a->{-version} ||$a->{-version} eq '-')
5685
0
0
0
? [$v, @{$x||[]}]
0
0
5686
: ($a->{-version} ||'+');
5687
0
0
0
if (ref($n) && $n->{-excl} && $n->{-version} && $v && $a->{-version}
0
0
0
0
5688
&& (ref($_[4]) eq 'HASH')) {
5689
0
my $kv =$s->recKey($a->{-table}, $_[3]);
5690
0
0
$a->{-where} =
5691
join(' AND '
5692
0
, map { defined($kv->{$_})
5693
? ('(' .$_ .'!=' .$s->mdeQuote($a->{-table},$_,$kv->{$_}) .')'
5694
,"($v IS NULL OR " . $v .'!=' .$s->mdeQuote($a->{-table},$_,$kv->{$_}) .')')
5695
: ()
5696
} keys %$kv);
5697
}
5698
0
local $s->{-rac} =undef;
5699
0
$s->dbiUpd($a, $d);
5700
}
5701
5702
5703
5704
5705
sub dbiUpd { # Update record(s) in database
5706
# -table=>table, field=>value || -data=>{values}
5707
# -key=>{field=>value}, -where=>'condition'
5708
# -save=>boolean, -optrec=>boolean, -sel=>boolean
5709
# $d && $dp - single record full new && prev data
5710
0
0
0
my ($s, $a, $d, $dp) =@_;
5711
0
my $f =$a->{-table};
5712
0
my @c;
5713
0
my $r =undef;
5714
0
$s->{-affected} =0;
5715
0
0
0
if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') {
0
0
5716
0
0
0
$d ={map { (defined($dp->{$_}) && defined($d->{$_}) && ($dp->{$_} eq $d->{$_}))
0
0
5717
|| (!defined($dp->{$_}) && !defined($d->{$_}))
5718
? ()
5719
: ($_ => $d->{$_}) } keys %$d}
5720
if $dp;
5721
0
0
0
$d =$dp if $dp && !scalar(keys(%$d));
5722
0
my $db =$s->dbi();
5723
0
0
my @cn =!$a->{-key} ? () : $s->{-dbiph} ? sort keys %{$a->{-key}} : keys %{$a->{-key}};
0
0
0
5724
0
0
my(@a, @v); @a =recFields($s,$d) if $s->{-dbiph};
0
5725
0
@c=('UPDATE '
5726
.dbiTblExp1($s, $f)
5727
.' SET '
5728
.join(','
5729
, $s->{-dbiph}
5730
0
? (map {"$_=?"} @a)
5731
0
: (map {$_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_})
5732
} recFields($s,$d)))
5733
." WHERE "
5734
.join(' AND '
5735
, dbiKeyWhr($s, 1, $a, @cn) # Key condition
5736
, $a->{-where}
5737
? '(' .$a->{-where} .')' # Where condition
5738
: ()
5739
, ref($a->{-version}) # Version control $f.
5740
? ("(( " .$a->{-version}->[0] .' IS NULL'
5741
." OR " .$a->{-version}->[0] ."='')"
5742
.($a->{-version}->[1]
5743
? ' AND ' .$a->{-version}->[1] ." <> '" .$a->{-version}->[2] ."')"
5744
: ')'))
5745
: ()
5746
, dbiACLike($s, 1, $f, undef # Access control
5747
,mdeWriters($s, $f), $s->ugnames())
5748
)
5749
0
0
,$s->{-dbiph} ? ({}, (map {$d->{$_}} @a), (map {ref($a->{-key}->{$_}) ? @{$a->{-key}->{$_}} : $a->{-key}->{$_}} @cn)) : ()
0
0
0
0
0
0
0
5750
);
5751
0
$s->logRec('dbiUpd', @c);
5752
0
0
0
$db->do(@c) || return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": do() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef);
5753
0
$s->{-affected} =$DBI::rows;
5754
0
0
$s->{-affected} =-$s->{-affected} if $s->{-affected} <0;
5755
0
$s->logRec('dbiUpd','AFFECTED',$s->{-affected});
5756
0
0
0
return($s->dbiIns($a, $d))
0
5757
if !$s->{-affected}
5758
&& ($a->{-save}
5759
|| $s->{-table}->{$f}->{-ixcnd});
5760
0
0
0
return($s->recIns($a, $d))
0
5761
if !$s->{-affected}
5762
&& ($a->{-optrec}
5763
|| $s->{-table}->{$f}->{-optrec});
5764
0
0
0
return($d) if ($s->{-affected} >1) ||$a->{-save};
5765
0
0
0
return($d) if defined($a->{-sel}) && !$a->{-sel};
5766
0
0
0
return($d) if !$s->{-affect} && $DBI::rows <=0;
5767
0
0
if ($s->{-dbiph}) {
5768
0
0
0
@cn =grep {defined($d->{$_})
0
5769
|| !exists($d->{$_}) && defined($a->{-key}->{$_})
5770
} @cn;
5771
0
0
@v =map {defined($d->{$_}) ? $d->{$_} : $a->{-key}->{$_}
0
5772
} @cn;
5773
}
5774
0
@c =('SELECT * FROM ' .dbiTblExp1($s, $f) .' WHERE '
5775
.join(' AND '
5776
, $s->{-dbiph}
5777
0
0
? (map { "$_=?" } @cn)
0
0
5778
0
0
: (map { defined($d->{$_})
0
5779
? ($_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_}))
5780
: exists($d->{$_})
5781
? ()
5782
: defined($a->{-key}->{$_})
5783
? ($_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $a->{-key}->{$_}))
5784
: ()
5785
} @cn)
5786
, $a->{-where} ? '(' .$a->{-where} .')' : ())
5787
);
5788
0
0
$s->logRec('dbiUpd', @c, @v ? {} : (), @v);
5789
0
$f =$db->prepare(@c);
5790
0
0
$r =$f && $f->execute(@v) && $f->fetchrow_hashref() || return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": selectrow_hashref() -> " .($DBI::errstr||'Empty result set') .$s->{-ermd}) && undef);
5791
}
5792
elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') {
5793
0
my ($j, $h, @f, @v);
5794
0
$j =0;
5795
0
$h =$s->dbmTable($f);
5796
0
0
if (!$dp) {
5797
0
@f =recFields($s,$d);
5798
0
@v =recValues($s,$d);
5799
}
5800
$s->{-affected} =
5801
!$dp
5802
? $s->dbmSeek($a, sub{
5803
0
0
$j++;
5804
0
0
0
return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": $j ". $s->lng(1,'-affected') .$s->{-ermd}) && undef)
0
5805
if $s->{-affect} && $j >$s->{-affect};
5806
0
0
if (!$dp) { $r =$_[2]; @{$r}{@f} =@v }
0
0
0
5807
0
else { $r =$d }
5808
0
my $k =[map {$r->{$_}} @{$s->{-table}->{$f}->{-key}}];
0
0
5809
0
$s->logRec('dbiUpd','kePut', $f, $k, $_[1], $r);
5810
0
$h->kePut($k, $_[1], $r);
5811
})
5812
0
0
: do { my $k =[map {$d->{$_}} @{$s->{-table}->{$f}->{-key}}];
0
0
0
5813
0
my $kp=[map {$dp->{$_}} @{$s->{-table}->{$f}->{-key}}];
0
0
5814
0
$s->logRec('dbiUpd','kePut', $f, $k, $kp, $d);
5815
0
$h->kePut($k, $kp, $d);
5816
0
$r =$d;
5817
0
1
5818
};
5819
0
0
if (!$s->{-affected}) {
5820
0
0
0
return($s->dbiIns($a, $d))
5821
if $a->{-save} || $s->{-table}->{$f}->{-ixcnd};
5822
0
0
0
return($s->recIns($a, $d))
5823
if $a->{-optrec} || $s->{-table}->{$f}->{-optrec};
5824
0
0
return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": dbiSeek() -> " .($@ ||'not found') .$s->{-ermd}) && undef)
5825
}
5826
0
0
$r =$s->{-affected} >1 ? $d : $r;
5827
}
5828
$r
5829
0
}
5830
5831
5832
sub dbmSeek { # Select records from dbm file using -key and -where
5833
0
0
0
my ($s, $a, $e) =@_;
5834
0
my $m =$s->{-table}->{$a->{-table}}; # metadata
5835
0
my $i =$m->{-key}; # index
5836
0
0
my $k =($a->{-key} # key index part
0
5837
0
0
? [map {!exists($a->{-key}->{$_})
5838
? ()
5839
: ref($a->{-key}->{$_})
5840
? ()
5841
: ($a->{-key}->{$_})
5842
} @$i]
5843
: []);
5844
0
my $ko=$s->{-keyqn}; # key compare opt
5845
0
my $wk={ $a->{-key} # key where part
5846
0
? (map {($_=>$a->{-key}->{$_})
5847
0
} (grep { my $v =$_;
5848
0
ref($a->{-key}->{$v})
5849
0
0
|| !grep {$v eq $_
5850
} @$i
5851
0
0
} keys %{$a->{-key}}))
5852
: ()
5853
};
5854
0
0
$wk=undef if !%$wk;
5855
0
0
my $o =($a->{-keyord} ||$a->{-orderby} ||$a->{-order}) # order request
5856
|| (!$e && (!@$k) ? $KSORD : '-aeq');
5857
0
0
$o ='-' .$o if substr($o,0,1) ne '-';
5858
0
0
my $ox=@$k # order execute
0
0
5859
? $o
5860
: $e
5861
? $o
5862
: $o =~/^-[af]/
5863
? '-aall'
5864
: '-dall';
5865
0
my $ws; # 'where' key cond
5866
0
0
if ($wk) { # !!! without [{}] syntax
5867
0
$ws =substr($o, 2); # of cgiForm(recQBF)/cgiQkey
5868
0
0
$ws =0 ? undef
5869
: $ws eq 'eq' || $ws eq 'all'
5870
0
? sub{my($k,$v,$d); foreach $k (keys %$wk) {
5871
0
$v =$wk->{$k}; $d =$_[2]->{$k};
0
5872
0
return(undef) if
5873
$ko && (!defined($v) || ($v eq ''))
5874
? defined($d) && $d ne ''
5875
: !defined($d) ? defined($v)
5876
: !defined($v) ? defined($d)
5877
: ref($v)
5878
0
0
0
? !grep {$d eq $_} @$v
0
0
0
0
0
0
0
5879
: $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/
5880
? $d != $v : $d ne $v;
5881
0
}; 1}
5882
0
0
: $ws eq 'ge' ? sub{my($k,$v,$d); foreach $k (keys %$wk) {
0
5883
0
$v =$wk->{$k}; $d =$_[2]->{$k};
0
5884
0
return(undef) if
5885
$ko && (!defined($v) || ($v eq ''))
5886
? defined($d) && ($d lt '')
5887
: !defined($d) ? defined($v)
5888
: !defined($v) ? 0
5889
: ref($v)
5890
0
0
0
? !grep {$d ge $_} @$v
0
0
0
0
0
0
0
5891
: $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/
5892
? $d < $v : $d lt $v;
5893
0
}; 1}
5894
0
0
: $ws eq 'gt' ? sub{my($k,$v,$d); foreach $k (keys %$wk) {
0
5895
0
$v =$wk->{$k}; $d =$_[2]->{$k};
0
5896
0
return(undef) if
5897
$ko && (!defined($v) || ($v eq ''))
5898
? !defined($d) || ($d le '')
5899
: !defined($d) ? 1
5900
: !defined($v) ? !defined($d)
5901
: ref($v)
5902
0
0
0
? !grep {$d gt $_} @$v
0
0
0
0
0
0
0
5903
: $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/
5904
? $d <= $v : $d le $v;
5905
0
}; 1}
5906
0
0
: $ws eq 'le' ? sub{my($k,$v,$d); foreach $k (keys %$wk) {
0
5907
0
$v =$wk->{$k}; $d =$_[2]->{$k};
0
5908
0
return(undef) if
5909
$ko && (!defined($v) || ($v eq ''))
5910
? defined($d) && ($d gt '')
5911
: !defined($d) ? 0
5912
: !defined($v) ? defined($d)
5913
: ref($v)
5914
0
0
0
? !grep {$d le $_} @$v
0
0
0
0
0
0
0
5915
: $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/
5916
? $d > $v : $d gt $v;
5917
0
}; 1}
5918
0
0
: $ws eq 'lt' ? sub{my($k,$v,$d); foreach $k (keys %$wk) {
0
5919
0
$v =$wk->{$k}; $d =$_[2]->{$k};
0
5920
0
return(undef) if
5921
$ko && (!defined($v) || ($v eq ''))
5922
? !defined($d) || ($d ge '')
5923
: !defined($d) ? !defined($v)
5924
: !defined($v) ? 0
5925
: ref($v)
5926
0
0
0
? !grep {$d lt $_} @$v
0
0
0
0
0
0
0
5927
: $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/
5928
? $d >= $v : $d ge $v;
5929
0
}; 1}
5930
: undef
5931
0
0
0
}
0
0
0
0
5932
5933
0
0
my $wr=$a->{-urole} # 'where' role cond
5934
&& mdeRole($s, $m, $a->{-urole});
5935
0
0
if ($wr) {
5936
0
my $wl =$wr;
5937
0
0
my $wn =$a->{-uname} ? $s->ugnames($a->{-uname}) : $s->ugnames();
5938
0
0
my $wx =$a->{-urole} =~/^(?:manager|principal|user)$/i
0
5939
? mdeRole($s, $m, 'actor')
5940
: $a->{-urole} =~/^(?:managers|principals|users)$/i
5941
? mdeRole($s, $m, 'actors')
5942
: [];
5943
0
0
$wr =sub{ foreach my $n (@$wn) {
5944
0
foreach my $v (@$wx) {
5945
0
0
return(undef) if $_[2]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i
5946
}
5947
0
foreach my $v (@$wl) {
5948
0
0
return($n) if $_[2]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i
5949
}
5950
}
5951
undef
5952
0
}
5953
0
}
5954
0
0
0
my $wa=$a->{-urole} && !$a->{-uname} # 'where' access cond
5955
? undef
5956
: mdeReaders($s, $m);
5957
5958
0
my $wv=$a->{-version}; # 'where' version cond
5959
0
0
0
$wv=undef if !ref($wv) || !@$wv;
5960
0
my $ft=$a->{-ftext}; # full-text find
5961
0
my $wf=$a->{-filter}; # 'where' filter expr
5962
0
my $wc=$a->{-where}; # 'where' condition
5963
0
my $we=$wc; # 'where' cond source
5964
0
0
0
if (defined($wc) && !ref($wc) && $wc) { # ... from string
0
5965
# !!! SQL perl operations incompatible with perl
5966
0
my $wm =$we; $we ='';
0
5967
0
my ($wa, $wt, $wq);
5968
0
while (length($wm)) {
5969
0
$wa =!$wa;
5970
0
0
if ($wm =~/(?
5971
0
$wt =$`; $wm =$'; $wq =$1;
0
0
5972
}
5973
else {
5974
0
$wt =$wm; $wm =''; $wq ='';
0
0
5975
}
5976
0
0
if ($wa) { # ... translate expr
5977
0
$wt =~s/((?<=])=)/'=' .$1/ge;
0
5978
0
$wt =~s/({\w+\})/'$_->' .$1/ge;
0
5979
0
0
$wt =~s/\b((?{' .$v .'}' : $v/ge;
0
0
5980
} # !!! good expr syntax?
5981
0
$we .=$wt .$wq;
5982
}
5983
0
$wc =$s->ccbNew($we);
5984
}
5985
0
0
my $w =sub{local $_ =$_[2]; # 'where' construct
5986
(!$wv || (!$_[2]->{$wv->[0]} && (!$wv->[1] ||!$_[2]->{$wv->[1]} ||($_[2]->{$wv->[1]} ne $wv->[2]))))
5987
&& (!$ws || &$ws(@_))
5988
&& (!$wc || &$wc(@_))
5989
&& (!$wa || ugmember($s, map {$_[2]->{$_}} @$wa))
5990
&& (!$wr || &$wr(@_))
5991
0
0
0
&& (!$ft || grep {defined($_[2]->{$_}) && $_[2]->{$_} =~/\Q$ft\E/i} keys %{$_[2]})
0
0
0
0
0
0
0
0
0
0
0
5992
&& (!$wf || &$wf(@_))
5993
0
};
5994
0
0
0
$s->logRec('dbiSeek'
0
0
0
0
0
0
0
5995
, $a->{-table}, $ox, $k
5996
, $wv ? (-version=> $wv) : ()
5997
, $wk ? ('-' .substr($o, 2)=>$wk) : ()
5998
, $we ? (-where=>$we) : ()
5999
, $wa ? (-rac =>$wa) : ()
6000
, $wr ? (-urole=>$a->{-urole}, -uname=>$a->{-uname}||'') : ()
6001
, $ft ? (-ftext=>$ft) : ()
6002
, $wf ? (-filter=>$wf) : ()
6003
, $e ? (-subw=>$e) : ()
6004
);
6005
0
0
!$s->{-c}->{-dbmSeek}
6006
? $s->dbmTableFlush($a->{-table}) # !!! for proper seek by DB_File
6007
: $s->dbmTable($a->{-table})->sync();
6008
0
local $s->{-c}->{-dbmSeek} =1;
6009
0
$s->dbmTable($a->{-table})->keSeek($ox,$k,$w,$e);
6010
}
6011
6012
6013
sub dbiKeyWhr { # SQL -key -order query condition
6014
# self, tbl alias off, {command}, key field names
6015
0
0
0
my ($s, $t, $a, @cn)=@_;
6016
0
0
@cn =!$a->{-key} ? () : $s->{-dbiph} ? sort keys %{$a->{-key}} : keys %{$a->{-key}}
0
0
0
0
6017
if !@cn;
6018
0
0
!@cn && return(@cn);
6019
0
0
my $kc =$a->{-keyord} ||$a->{-order};
6020
0
0
0
$kc =!$kc || ref($kc) || substr($kc,0,1) ne '-'
0
6021
? ''
6022
: {'eq'=>'=','ge'=>'>=','gt'=>'>','le'=>'<=','lt'=>'<'}->{substr($kc,2)}||'=';
6023
0
0
$kc ='' if $kc eq '=';
6024
0
my $db =$s->dbi();
6025
0
0
my $f =ref($a->{-table}) ? $a->{-table}->[0] : $a->{-table};
6026
0
0
$f =$1 if $f=~/^([^\s]+)/;
6027
0
0
my $m =$s->{-table} && $s->{-table}->{$f};
6028
0
0
0
$t =!$t && $m ? $f .'.' : '';
6029
0
0
$s->{-dbiph}
6030
0
0
?(map {my $ce =$m && $m->{-mdefld} && $m->{-mdefld}->{$_}
6031
&& $m->{-mdefld}->{$_}->{-expr} || ($t .$_);
6032
# expression may not be in select list
6033
ref($a->{-key}->{$_})
6034
0
0
0
? do{ my $n =$_;
0
0
0
0
0
0
0
0
6035
0
@{$a->{-key}->{$_}}
6036
? ('(' .join(' OR '
6037
0
, map { ref($_)
6038
0
0
0
? (do { local $a->{-key} =$_;
0
0
0
0
0
0
0
0
6039
0
local $_ =$_;
6040
0
local $s->{-dbiph} =undef;
6041
0
my @v =dbiKeyWhr(@_[0..2]);
6042
0
0
@v ? '(' .join(' AND ', @v) .')' : ()
6043
})
6044
: $s->{-keyqn} && (!defined($_) || ($_ eq ''))
6045
? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='' OR " .$ce .'=?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'' OR " .$ce .$kc .'?)' : ('(' .$ce .$kc ."'' OR " .$ce .$kc .'?)'))
6046
: !defined($_)
6047
? (!$kc ? '(' .$ce .' IS ?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'?)' : ('(' .$ce .$kc .'?)'))
6048
: ('(' .$ce .($kc ||'=') .'?)')
6049
0
0
} @{$a->{-key}->{$_}}) .')')
6050
: ()
6051
}
6052
: $s->{-keyqn} && (!defined($a->{-key}->{$_}) || ($a->{-key}->{$_} eq ''))
6053
? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='' OR " .$ce .'=?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'' OR " .$ce .$kc .'?)' : ('(' .$ce .$kc ."'' OR " .$ce .$kc .'?)'))
6054
: !defined($a->{-key}->{$_})
6055
? (!$kc ? '(' .$ce .' IS ?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'?)' : ('(' .$ce .$kc .'?)'))
6056
: ('(' .$ce .($kc ||'=') .'?' .')')
6057
} @cn)
6058
0
0
:(map {my $ce =$m && $m->{-mdefld} && $m->{-mdefld}->{$_}
6059
&& $m->{-mdefld}->{$_}->{-expr} || ($t .$_);
6060
# expression may not be in select list
6061
ref($a->{-key}->{$_})
6062
0
0
0
? do{ my $n =$_;
0
0
0
0
0
0
0
0
6063
0
@{$a->{-key}->{$_}}
6064
? ('(' .join(' OR '
6065
0
, map { ref($_)
6066
0
0
0
? (do { local $a->{-key} =$_;
0
0
0
0
0
0
0
0
6067
0
local $_ =$_;
6068
0
my @v =dbiKeyWhr(@_[0..2]);
6069
0
0
@v ? '(' .join(' AND ', @v) .')' : ()
6070
})
6071
: $s->{-keyqn} && (!defined($_) || ($_ eq ''))
6072
? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='')" : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'')" : ('(' .$ce .$kc ."'')"))
6073
: !defined($_)
6074
? (!$kc ? '(' .$ce .' IS NULL)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'NULL)' : ($t .$n .$kc .'NULL'))
6075
: ('(' .$ce .($kc ||'=') .mdeQuote($s, $m, $n, $_) .')')
6076
0
0
} @{$a->{-key}->{$_}}) .')')
6077
: ()
6078
}
6079
: $s->{-keyqn} && (!defined($a->{-key}->{$_}) || ($a->{-key}->{$_} eq ''))
6080
? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='')" : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'')" : ('(' .$ce .$kc ."'')"))
6081
: !defined($a->{-key}->{$_})
6082
? (!$kc ? '(' .$ce .' IS NULL)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'NULL)' : ('(' .$ce .$kc .'NULL)'))
6083
: ('(' .$ce .($kc ||'=') .mdeQuote($s, $s->{-table}->{$f}, $_, $a->{-key}->{$_}) .')')
6084
} @cn);
6085
}
6086
6087
6088
sub dbiACLike { # SQL Access Control LIKE / RLIKE
6089
# self, tbl alias off, table, operation, [fields], [values], ?filter
6090
0
0
0
0
0
return(!$_[3] ? () : '') if !$_[4] ||!$_[5] || !@{$_[4]} ||!@{$_[5]};
0
0
0
0
0
6091
# RLIKE method detect / construct
6092
0
0
my $o = ($_[0]->{-table} && $_[0]->{-table}->{$_[2]}
6093
&& $_[0]->{-table}->{$_[2]}->{-dbiACLike})
6094
|| $_[0]->{-dbiACLike} ||'';
6095
# rlike regexp ~* similar regexp_like like eq|=; lc|lower; filter|sub
6096
# $o = 'eq lc';
6097
0
0
my $t = !$_[1] && $_[0]->{-table} && $_[0]->{-table}->{$_[2]} && ($_[2] .'.')
6098
||'';
6099
0
my $e = $_[0]->dbiEng();
6100
0
0
0
$e = 0
0
0
0
0
6101
? ''
6102
: ($o =~/\b(?:rlike|regexp)\b/i)|| (!$o && ($e =~/\bDBI:(?:mysql)\b/i))
6103
? 'RLIKE' # MySQL, case insensitive for not binary strings
6104
: ($o =~/~\*/i) || (!$o && ($e =~/\bDBI:(?:pg|postgresql)\b/i))
6105
? '~*' # PostgreSQL, case insensitive
6106
: ($o =~/\b(?:similar)\b/i)
6107
? 'SIMILAR TO' # SQL99, PostgreSQL: '%[[:<:]](|)[[:>:]]%'
6108
: ($o =~/\b(?:regexp_like)/i)
6109
? 'REGEXP_LIKE' # Oracle 10: REGEXP_LIKE(zip, '[^[:digit:]]')
6110
: '';
6111
0
my $l = !$e || ($o =~/\b(?:like|eq|=)\b/i)
6112
? $_[5]
6113
: ($e eq 'SIMILAR TO'
6114
? $_[0]->dbi->quote('%[[:<:]]('
6115
0
.join('|', map {$_[0]->dbiLikesc($_)} @{$_[5]})
0
6116
.')[[:>:]]%')
6117
: $e eq 'RLIKE'
6118
? $_[0]->dbi->quote( '(^|,|;)[:blank:]*('
6119
0
.join('|', map {$_[0]->dbiLikesc($_)} @{$_[5]})
0
6120
.')[:blank:]*(,|;|$)')
6121
: $_[0]->dbi->quote( '[[:<:]]('
6122
0
0
0
.join('|', map {$_[0]->dbiLikesc($_)} @{$_[5]})
0
0
0
6123
.')[[:>:]]')
6124
);
6125
0
$l = ref($l)
6126
0
0
0
? (!$o || ($o =~/\b(?:lc|lower)\b/i) ? [map {lc($_)} @$l] : $l)
0
0
0
0
6127
: $e =~/\b(?:regexp_like)/i
6128
? (',' .($o =~/\b(?:lc|lower)\b/i ? lc($l) : $l) .')')
6129
: (' ' .$e .' ' .($o =~/\b(?:lc|lower)\b/i ? lc($l) : $l));
6130
6131
0
0
0
if (ref($l) &&(@_ >6) # LIKE method '-filter' constructor
0
0
6132
&& (!$o || ($o =~/\b(?:filter|sub)\b/i))) {
6133
0
my $w =$_[0];
6134
0
my $e =$_[6];
6135
0
my $f =$_[4];
6136
$_[6] =$_[3] && $_[3] =~/not/i
6137
0
0
? sub{ foreach my $v (@$f) {
6138
0
0
next if !exists($_[3]->{$v});
6139
0
foreach my $n (@$l) {
6140
return(undef)
6141
0
0
0
if defined($_[3]->{$v})
6142
&& $_[3]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i
6143
}
6144
0
0
} !$e || &$e(@_) }
6145
0
0
: sub{ foreach my $v (@$f) {
6146
0
0
if (!exists($_[3]->{$v})) {
6147
0
0
if ($w) {
6148
# &{$w->{-warn}}("dbiACLike ACL filter ignoring due to ACL field(s) missing from SELECT list\n");
6149
0
CORE::warn("dbiACLike ACL filter ignoring due to ACL field(s) missing from SELECT list\n");
6150
0
$w =undef;
6151
}
6152
0
0
return(!$e || &$e(@_))
6153
}
6154
0
foreach my $n (@$l) {
6155
0
0
0
return(!$e || &$e(@_))
0
6156
if defined($_[3]->{$v})
6157
&& $_[3]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i
6158
}
6159
0
} undef }
6160
0
0
0
}
6161
0
' ' .($_[3] ? $_[3] .' ' : '') # RLIKE / LIKE assembly
6162
.(!defined($l) # !!! ignored -expr of field
6163
? ''
6164
: !ref($l) && ($e =~/\b(?:regexp_like)\b/i)
6165
? '(' .( $o =~/\b(?:lc|lower)\b/i
6166
0
? join(' OR ', map {$e .'(LOWER(' .$t .$_ .')' .$l} @{$_[4]})
0
6167
0
: join(' OR ', map {$e .'(' .$t .$_ .$l} @{$_[4]})
0
6168
) .')'
6169
: !ref($l)
6170
? '(' .( $o =~/\b(?:lc|lower)\b/i
6171
0
? join(' OR ', map {'LOWER(' .$t .$_ .')' .$l} @{$_[4]})
0
6172
0
0
: join(' OR ', map {$t .$_ .$l} @{$_[4]})
0
6173
) .')'
6174
: $o =~/\b(?:eq|=)\b/i
6175
? '(' .join(' OR '
6176
0
, map { my $f =($o =~/\b(?:lc|lower)\b/i ? 'LOWER(' .$t .$_ .')' : ($t .$_));
6177
0
map {$f .'=' .$_[0]->dbi->quote($_)
0
6178
} @$l
6179
0
0
0
} @{$_[4]}) .')'
6180
: '(' .join(' OR ' # !!! like precession, see -filter above
6181
0
, map { my $f =(!$o || ($o =~/\b(?:lc|lower)\b/i) ? 'LOWER(' .$t .$_ .')' : ($t .$_));
6182
0
map {$f .' LIKE ' .$_[0]->dbi->quote('%' .$_ .'%')
0
6183
} @$l
6184
0
0
0
} @{$_[4]}) .')'
0
0
0
0
0
0
6185
);
6186
}
6187
6188
6189
sub recDel { # Delete record(s) in database
6190
# -table=>table
6191
# -key=>{field=>value}, -where=>'condition', -version=>'+'|'-'
6192
0
0
1
my $s =$_[0];
6193
0
0
0
$s->varLock if $s->{-serial} && $s->{-serial} ==2;
6194
0
$s->logRec('recDel', @_[1..$#_]);
6195
0
0
0
my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]});
0
6196
0
0
my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a;
0
0
6197
0
$a->{-cmd} ='recDel';
6198
0
$a->{-table}=recType($s, $a, $d);
6199
0
$a->{-key} =rmlKey($s, $a, $d);
6200
0
my $m =mdeTable($s,$a->{-table});
6201
0
my $r =undef;
6202
0
my $w =mdeWriters($s, $m);
6203
0
0
my $x =$m->{-rvcDelState} ||$s->{-rvcDelState};
6204
0
0
my $i =$m->{-index} ||$s->{-index};
6205
0
0
my $b =$m->{-rfa} ||$s->{-rfa};
6206
0
rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recDel0C));
6207
0
0
0
if ((($w||$i) && !$x) ||grep {$s->{$_} || $m->{$_}} qw(-recDel0R -recDel1R)) {
0
0
0
0
6208
0
my $c =$s->recSel(rmlClause($s, $a), -data=>undef);
6209
0
my $j =0;
6210
0
while ($r =$c->fetchrow_hashref()) {
6211
0
0
0
$j++; return(&{$s->{-die}}($s->lng(0,'recDel') .": $j ". $s->lng(1,'-affected') .$s->{-ermd}) && undef)
0
0
6212
if $s->{-affect} && $j >$s->{-affect};
6213
# $r ={%$r}; # readonly hash, should be considered below
6214
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recDel') .': ' .$s->lng(1,'recDelAclStp') .$s->{-ermd}) && undef)
6215
0
0
0
if $w && !$s->ugmember(map {$r->{$_}} @$w);
0
6216
0
0
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recDel') .': ' .$s->lng(1,'recUpdVerStp') .$s->{-ermd}) && undef)
0
0
6217
if $x && defined($r->{$x->[0]})
6218
&& ($r->{$x->[0]} eq $x->[1]);
6219
0
0
rfdStamp ($s, $a, $r) if $b;
6220
0
rmiTrigger($s, $a, undef, $r, qw(-recForm0R -recFlim0R -recDel0R));
6221
0
0
0
rfdRm ($s, $r) if !$x && $r->{-file};
6222
0
0
0
rmiIndex ($s, $a, undef, $r) if !$x && $i;
6223
}
6224
0
0
$r =($x ? $s->recUpd((map {$a->{$_} ? ($_=>$a->{$_}) : ()
0
0
6225
} qw(-table -key -where -version)), @$x)
6226
: $s->dbiDel($a, $d));
6227
}
6228
else {
6229
0
0
$r =($x ? $s->recUpd((map {$a->{$_} ? ($_=>$a->{$_}) : ()
0
0
6230
} qw(-table -key -where -version)), @$x)
6231
: $s->dbiDel($a, $d));
6232
}
6233
0
0
0
return(&{$s->{-die}}($s->lng(0,'recDel') .': ' .($s->{-affected}||0) .' ' .$s->lng(1,'-affected') .$s->{-ermd}) && undef)
0
0
6234
if $s->{-affect} && (($s->{-affected}||0) != $s->{-affect});
6235
0
0
rmiTrigger($s, $a, $d, undef, qw(-recDel1C)) if $r;
6236
0
$r
6237
}
6238
6239
6240
sub dbiDel { # Delete record(s) in database
6241
# -table=>table
6242
# -key=>{field=>value}, -where=>'condition'
6243
0
0
0
my ($s, $a, $d) =@_;
6244
0
my $f =$a->{-table};
6245
0
my @c;
6246
my $r;
6247
0
$s->{-affected} =0;
6248
0
0
0
if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') {
0
0
6249
0
@c =('DELETE FROM '
6250
.dbiTblExp1($s, $f)
6251
.' WHERE '
6252
.join(' AND '
6253
, dbiKeyWhr($s, 1, $a) # Key condition
6254
, $a->{-where}
6255
? '(' .$a->{-where} .')' # Where condition
6256
: ()
6257
, dbiACLike($s, 1, $f, undef # Access control
6258
, mdeWriters($s, $f), $s->ugnames())
6259
)
6260
, $s->{-dbiph} && $a->{-key}
6261
0
0
0
? ({}, map {ref($a->{-key}->{$_}) ? @{$a->{-key}->{$_}} : $a->{-key}->{$_}} sort keys %{$a->{-key}})
0
0
0
0
6262
: ()
6263
);
6264
0
$s->logRec('dbiDel', @c);
6265
0
0
0
$s->dbi->do(@c) || return(&{$s->{-die}}($s->lng(0,'dbiDel') .": do() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef);
6266
0
$s->{-affected} =$DBI::rows;
6267
0
0
$s->{-affected} =-$s->{-affected} if $s->{-affected} <0;
6268
0
$s->logRec('dbiDel','AFFECTED',$s->{-affected});
6269
0
0
return($s->{-affected} && $a);
6270
}
6271
elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') {
6272
0
my $h =$s->dbmTable($f);
6273
0
my $j =0;
6274
$s->{-affected} =
6275
$s->dbmSeek($a, sub{
6276
0
0
0
0
$j++; return(&{$s->{-die}}($s->lng(0,'dbiDel') .": $j " .$s->lng(1,'-affected') .$s->{-ermd}) && undef)
0
0
6277
if $s->{-affect} && $j >$s->{-affect};
6278
0
$s->logRec('dbiDel', 'keDel', $f, $_[1]);
6279
0
$h->keDel($_[1]);
6280
0
});
6281
0
0
0
return(&{$s->{-die}}($s->lng(0,'dbiDel') .": dbiSeek() -> $@" .$s->{-ermd}) && undef)
6282
if !defined($s->{-affected});
6283
}
6284
0
0
$s->{-affected} && $a
6285
}
6286
6287
6288
sub dbiTrunc { # Clear all records in the datafile
6289
# self, datafile name
6290
0
0
0
my ($s, $f) =@_;
6291
0
my @c;
6292
0
0
0
if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') {
0
0
6293
0
@c =('TRUNCATE TABLE ' .dbiTblExp1($s, $f));
6294
0
$s->logRec('dbiTrunc', @c);
6295
0
0
0
$s->dbi->do(@c) || return(&{$s->{-die}}($s->lng(0,'dbiTrunc') .": do() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef);
6296
}
6297
elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') {
6298
0
0
my $n =$s->pthForm('dbm',($s->{-table}->{$f} && $s->{-table}->{$f}->{-expr} ||$f));
6299
0
0
if (-e $n) {
6300
0
$s->logRec('dbiTrunc','unlink', $n);
6301
unlink($n)
6302
0
0
0
|| return(&{$s->{-die}}($s->lng(0,'dbiTrunc') .": unlink('$n') -> $!" .$s->{-ermd}) && undef)
6303
}
6304
}
6305
$s
6306
0
}
6307
6308
6309
sub recSel { # Select records from database
6310
# see 'dbiSel'
6311
0
0
1
my $s =$_[0];
6312
0
0
0
my $a =@_< 3 && ref($_[1]) ? dsdClone($s, $_[1]) : {map {ref($_) ? dsdClone($s, $_) : $_} @_[1..$#_]};
0
0
6313
0
$a->{-table}=recType($s, $a, $a);
6314
0
local $s->{-affect}=undef;
6315
0
my $m =mdeTable($s,$a->{-table});
6316
0
$a->{-cmd} ='recSel';
6317
0
0
0
$a->{-version}= ref($a->{-version})
6318
? $a->{-version}
6319
: $m && (!$a->{-version} ||$a->{-version} eq '-')
6320
? [ ($m->{-rvcActPtr} ||$s->{-rvcActPtr} ||())
6321
0
0
0
,@{$m->{-rvcDelState} ||$s->{-rvcDelState} ||[]}]
0
0
0
6322
: ($a->{-version} ||'+');
6323
0
0
0
local $a->{-urole}= !$a->{-urole} ||($a->{-urole} eq 'all') ? undef : $a->{-urole};
6324
#$s->logRec('recSel', $a);
6325
0
$s->{-fetched} =0;
6326
0
rmiTrigger($s, $a, undef, undef, qw(-recSel0C));
6327
0
my $r =$s->dbiSel($a);
6328
0
$r->{-query} =$a;
6329
0
$r
6330
}
6331
6332
6333
sub recList { # List records from database
6334
0
0
1
recSel(@_) # - reserved to be redesigned
6335
}
6336
6337
6338
sub recRead { # Read one record from database
6339
# -key=>{field=>value}, see 'dbiSel'
6340
# -wikn=>value, instead of -key
6341
# -optrec=>boolean, -test=>boolean
6342
# -version=>'+'
6343
0
0
1
my $s =$_[0];
6344
0
0
0
my $a =@_< 3 && ref($_[1]) ? dsdClone($s, $_[1]) : {map {ref($_) ? dsdClone($s, $_) : $_} @_[1..$#_]};
0
0
6345
0
my $d ={};
6346
0
local $s->{-affect}=1;
6347
0
$a->{-cmd} ='recRead';
6348
0
$a->{-table}=recType($s, $a, $d);
6349
0
$a->{-key} =rmlKey($s, $a, $d);
6350
0
0
$a->{-data} =ref($a->{-data}) ne 'ARRAY' ? undef : $a->{-data};
6351
0
my $m =mdeTable($s,$a->{-table});
6352
0
my $r =undef;
6353
0
0
0
$a->{-version}= [ ($m->{-rvcActPtr} ||$s->{-rvcActPtr} ||())
6354
0
0
0
,@{$m->{-rvcDelState} ||$s->{-rvcDelState} ||[]}]
0
0
0
0
6355
if defined($a->{-version}) && !ref($a->{-version})
6356
&& $m && (!$a->{-version} || ($a->{-version} eq '-'));
6357
0
rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recRead0C));
6358
0
$r =$s->recRead_($m, $a);
6359
0
0
rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recFlim0R -recRead0R -recRead1R -recRead1C -recForm1C))
6360
if $r;
6361
0
$r
6362
}
6363
6364
6365
sub recRead_ { # recRead internal use, without triggers
6366
0
0
0
my ($s, $m, $a) =@_;
6367
0
my $r =$s->dbiSel($a)->fetchrow_hashref();
6368
0
0
if ($r) {
6369
0
$s->{-affected} =1;
6370
0
$s->{-fetched} =1;
6371
}
6372
else {
6373
0
$s->{-affected} =0;
6374
0
$s->{-fetched} =0;
6375
return(undef)
6376
0
0
if $a->{-test};
6377
0
0
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recRead') .': ' .($s->{-affected}||0) .' ' .$s->lng(1,'-affected') .$s->{-ermd}) && undef)
0
6378
if !$a->{-optrec}
6379
|| !$m->{-optrec};
6380
0
return($s->recNew(map {($_=>$a->{$_})} grep {$a->{$_}} qw(-table -form)));
0
0
6381
}
6382
0
0
0
if ($r && $s->{-rac}) {
6383
0
return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recRead') .': '. $s->lng(1,'recReadAclStp') .$s->{-ermd}) && undef)
6384
if !$s->uadmrdr()
6385
&&($m->{-racWriter} ||$s->{-racWriter} ||$m->{-racReader} ||$s->{-racReader})
6386
0
0
0
&& !$s->ugmember(map {$r->{$_}} @{$m->{-racWriter} ||$s->{-racWriter}||[]}
0
0
0
6387
0
0
0
,@{$m->{-racReader} ||$s->{-racReader}||[]});
0
0
0
6388
0
$r->{-editable} =1
6389
if $s->uadmwtr()
6390
0
0
0
|| $s->ugmember(map {$r->{$_}} @{$m->{-racWriter} || $s->{-racWriter}||[]})
0
0
0
6391
}
6392
0
0
0
rfdStamp($s, $a, $r) if $m->{-rfa} ||$s->{-rfa};
6393
0
$r
6394
}
6395
6396
6397
sub recWikn { # Find record by name
6398
# (wikiname)
6399
0
0
0
my ($s, $val, $qry) =@_;
6400
0
my $rk;
6401
0
my $rl=0;
6402
0
my $ru='';
6403
0
0
0
$qry ='' if $qry && ($qry eq 'default');
6404
6405
0
$s->logRec('recWikn',$val, $qry);
6406
0
0
0
if ($qry && $s->{-wikq} && !$s->{-table}->{$qry}) {
0
6407
0
$rk =&{$s->{-wikq}}($s, $val, $qry);
0
6408
0
0
return($rk) if $rk;
6409
}
6410
0
foreach my $tn (keys %{$s->{-table}}) {
0
6411
0
0
0
next if $qry && ($tn ne $qry);
6412
0
my $tm =$s->mdeTable($tn);
6413
0
0
0
next if defined($tm->{-wikn}) && !$tm->{-wikn};
6414
0
0
0
next if !$tm->{-wikn} && !$s->{-wikn};
6415
0
my $fn;
6416
0
0
foreach my $f ($tm->{-wikn}
0
0
0
6417
0
? (ref($tm->{-wikn}) ? @{$tm->{-wikn}} : $tm->{-wikn})
6418
: (ref($s->{-wikn}) ? @{$s->{-wikn}} : $s->{-wikn})) {
6419
0
0
next if !$tm->{-mdefld}->{$f};
6420
0
$fn =$f;
6421
last
6422
0
}
6423
0
0
next if !$fn;
6424
0
0
my $fv =$tm->{-rvcActPtr} ||$s->{-rvcActPtr};
6425
0
0
my $fu =$tm->{-rvcUpdWhen} ||$s->{-rvcUpdWhen};
6426
0
my $ti =$s->recSel(-table=>$tn
6427
, -version=>'+'
6428
, -key=>{$fn=>$val}
6429
, -keyord=>'dall');
6430
0
my $rr;
6431
0
while ($rr=$ti->fetchrow_hashref()) {
6432
0
0
if ($rr->{$fv}) {
6433
0
0
0
next if $fu
0
6434
? $ru gt ($rr->{$fu}||'')
6435
: $rl;
6436
0
$rk ={-table=>$tn, -key=>$s->recKey($tn,$rr)};
6437
0
0
$ru =$rr->{$fu}||'';
6438
0
$rl =1;
6439
}
6440
else {
6441
0
0
0
next if $fu
0
6442
? $ru gt ($rr->{$fu}||'')
6443
: $rl >1;
6444
0
$rk ={-table=>$tn, -key=>$s->recKey($tn,$rr)};
6445
0
0
$ru =$rr->{$fu}||'';
6446
0
$rl =2; # last
6447
}
6448
}
6449
0
0
last if $rl==2;
6450
}
6451
0
0
0
$rk->{-cmd} ='recRead' if ref($rk) && !$rk->{-cmd};
6452
0
$rk
6453
}
6454
6455
6456
sub recHist { # History of changes of record
6457
# -table=>name, -key=>{}
6458
0
0
0
my $s =$_[0];
6459
0
0
0
my $a =@_< 3 && ref($_[1]) ? dsdClone($s, $_[1]) : {map {ref($_) ? dsdClone($s, $_) : $_} @_[1..$#_]};
0
0
6460
0
my $d ={};
6461
0
local $s->{-affect}=undef;
6462
0
$a->{-cmd} ='recRead';
6463
0
$a->{-table}=recType($s, $a, $d);
6464
0
$a->{-key} =rmlKey($s, $a, $d);
6465
0
my $m =mdeTable($s,$a->{-table});
6466
0
$s->logRec('recHist',%$a);
6467
0
0
my %rvc =map {($_ => $m->{$_} ||$s->{$_})
0
6468
} qw(-rvcInsBy -rvcInsWhen -rvcUpdBy -rvcUpdWhen -rvcActPtr);
6469
return(undef)
6470
0
0
0
if !$rvc{-rvcActPtr} || !$rvc{-rvcUpdWhen};
6471
0
0
$rvc{-key} =$m->{-key} ||$s->{-key} ||$s->{-tn}->{-key};
6472
0
0
$rvc{-key} =$rvc{-key}->[0] if ref($rvc{-key});
6473
0
0
my $rva =$m->{-rvcActPtr} ||$s->{-rvcActPtr};
6474
0
0
my %rvx =map {($m->{$_} ||$s->{$_} => 1) # may be included: -key, -rvcActPtr
0
6475
} qw(-rvcUpdBy -rvcUpdWhen -rvcActPtr);
6476
0
$rvx{$rvc{-key}} =1;
6477
0
$rvx{-fupd} =1;
6478
0
$rvx{-editable} =1;
6479
0
$a->{-key} ={$rvc{-key} => [$a->{-key}->{$rvc{-key}}
6480
, {$rvc{-rvcActPtr} => $a->{-key}->{$rvc{-key}}}
6481
]};
6482
0
$a->{-version} ='+';
6483
0
$a->{-order} =$rvc{-rvcUpdWhen};
6484
0
$a->{-keyord} ='-aeq';
6485
# $s->logRec('recHist', %$a, {%rvc});
6486
0
$s->{-affected}=0;
6487
0
$s->{-fetched} =0;
6488
0
my $l =0; # length
6489
0
my $r =[]; # return list
6490
0
my $pv={}; # previous values: field => value
6491
0
my $c =$s->recSel(%$a);
6492
0
my($r0, $r1) =($pv);
6493
0
while (my $rr =$c->fetchrow_hashref()) { # collect versions
6494
0
$r1 =$rr;
6495
0
0
if ($l >1024*1024*10) {
6496
0
push @$r, [$a->{-key}->{$rvc{-key}}
6497
, '...'
6498
, '...'
6499
, {}];
6500
0
while (my $v =$c->fetchrow_hashref()) {$r1 =$v};
0
6501
}
6502
0
$s->{-fetched}++; $s->{-affected}++;
0
6503
0
0
0
$s->rfdStamp($a->{-table}, $r1) if $m->{-rfa} ||$s->{-rfa};
6504
0
rmiTrigger($s, $a, $r1, $r1, qw(-recForm0R -recRead0R -recRead1R -recRead1C -recForm1C));
6505
0
push @$r, [ $r1->{$rvc{-key}}
6506
,$r1->{$rvc{-rvcUpdWhen}}
6507
,$r1->{$rvc{-rvcUpdBy}}
6508
,{}];
6509
0
foreach my $v (@{$r->[$#$r]}) {
0
6510
0
0
0
$l +=length($v) if !ref($v) && defined($v)
6511
}
6512
0
my $cf =$r->[$#$r]->[3];
6513
0
foreach my $f (keys %$r1) {
6514
0
0
0
next if $rvx{$f}
0
6515
|| (!defined($pv->{$f}) && !defined($r1->{$f}));
6516
0
0
0
next unless ($f ne $rva)
0
6517
? (!defined($pv->{$f}) && defined($r1->{$f}))
6518
|| ( defined($pv->{$f}) && !defined($r1->{$f}))
6519
|| ($pv->{$f} ne $r1->{$f})
6520
: 1;
6521
6522
0
my $cv =$r1->{$f}; # change value
6523
0
0
0
if (!$cv) {}
0
0
0
0
0
0
6524
elsif ( (length($cv) >255)
6525
|| ($cv =~/[\n\r]/)
6526
|| ($m->{-mdefld}
6527
&& $m->{-mdefld}->{$f}
6528
&& $m->{-mdefld}->{$f}->{-inp}
6529
&& (grep {$m->{-mdefld}->{$f}->{-inp}->{$_}
6530
} qw(-rows -arows -htmlopt)))
6531
) {
6532
0
0
0
if ($m->{-mdefld} && $m->{-mdefld}->{$f}
0
0
6533
&& $m->{-mdefld}->{$f}->{-inp}
6534
&& $m->{-mdefld}->{$f}->{-inp}->{-htmlopt}) {
6535
0
$cv =$s->strDiff('-hbr', $pv->{$f}, $cv);
6536
}
6537
else {
6538
0
$cv =$s->strDiff('-br', $r0->{$f}, $cv);
6539
}
6540
}
6541
0
$cf->{$f} =$cv;
6542
0
0
$l +=length($cv) if defined($cv);
6543
# $s->logRec('recHist', $r1->{$rvc{-rvcUpdBy}}, $r1->{$rvc{-rvcUpdWhen}}, $f, $cv);
6544
0
$pv->{$f} =$r1->{$f};
6545
}
6546
}
6547
# return($r);
6548
0
if (1) { # arrange attachments if possible
6549
0
my($fn, $ft); # folder name, folder time
6550
0
for (my $i=$#$r; $i >=0; $i--) {
6551
0
0
0
if ($fn && ( $r->[$i]->[3]->{-file}
0
6552
|| ($r->[$i]->[1] lt $ft)) ){
6553
0
$r->[$i+1]->[3]->{-file} =$fn;
6554
0
$fn =$ft =undef;
6555
}
6556
0
0
if ($r->[$i]->[3]->{-file}) {
6557
0
$fn =$r->[$i]->[3]->{-file};
6558
0
0
$ft =$s->strtime($s->rfdTime($fn)||0);
6559
0
delete($r->[$i]->[3]->{-file});
6560
}
6561
}
6562
0
0
$r->[0]->[3]->{-file} =$fn if $fn;
6563
}
6564
# $s->logRec('recHist', @$r);
6565
$r
6566
0
}
6567
6568
6569
sub recLast { # Last record lookup for values
6570
# self, table/command ||false, record data, key fields,... target
6571
# {-table, -version, -excl}
6572
0
0
1
my $s =$_[0];
6573
0
my $n =$_[1];
6574
0
0
0
$n =$s->{-pcmd}->{-table} ||$s->{-pcmd}->{-form} if !$n;
6575
0
0
0
$n->{-table} = $s->{-pcmd}->{-table} if ref($n) && !$n->{-table};
6576
0
my $d =$_[2];
6577
0
0
my $a ={-cmd=>'recLast'
6578
, -table=>ref($n) ? $s->recType($n, $d) : $n};
6579
0
my $m =mdeTable($s,$a->{-table});
6580
0
my $r =undef;
6581
0
0
0
return($r)
6582
unless ($m->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi';
6583
0
local $s->{-affect}=1;
6584
0
0
0
$a->{-version} = ref($n->{-version})
6585
? $n->{-version}
6586
: $m && (!$n->{-version} ||$n->{-version} eq '-')
6587
? [ ($m->{-rvcActPtr} ||$s->{-rvcActPtr} ||())
6588
0
0
0
,@{$m->{-rvcDelState} ||$s->{-rvcDelState} ||[]}]
0
0
0
6589
: ($n->{-version} ||'+');
6590
0
0
if ($n->{-excl}) {
6591
0
my $kv =$s->recKey($a->{-table}, $_[2]);
6592
0
0
$a->{-where} =
6593
join(' AND '
6594
0
, map { defined($kv->{$_})
6595
? $_ .'!=' .$s->mdeQuote($a->{-table},$_,$kv->{$_})
6596
: ()
6597
} keys %$kv);
6598
}
6599
0
foreach my $c ($m, $s) {
6600
0
0
next if !$c->{-rvcUpdWhen};
6601
0
$a->{-order} =[[$c->{-rvcUpdWhen},'desc']];
6602
last
6603
0
}
6604
0
for (my $i =$#_; $i >2; $i--) {
6605
0
0
next if ref($_[$i]) ne 'ARRAY';
6606
0
$a->{-key} ={};
6607
0
for (my $j =3; $j <=$i; $j++) {
6608
0
foreach my $f (@{$_[$j]}) {
0
6609
0
0
0
next if !defined($d->{$f}) || ($d->{$f} eq '');
6610
0
$a->{-key}->{$f} =$d->{$f};
6611
}
6612
}
6613
0
0
next if !%{$a->{-key}};
0
6614
0
$s->logRec('recLast',$i
6615
0
, (map {($_=>$s->strdata($a->{$_}))} sort keys %$a)
6616
, @_[3..$#_]);
6617
0
rmiTrigger($s, $a, $d, $r, qw(-recForm0C -recRead0C));
6618
0
$r =$s->dbiSel($a)->fetchrow_hashref();
6619
0
0
next if !$r;
6620
# $s->{-affected} =$s->{-fetched} =1;
6621
0
rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recRead0R -recRead1R -recRead1C -recForm1C));
6622
0
0
if (ref($_[$#_]) eq 'CODE') {
0
6623
0
0
$r =$r && &{$_[$#_]}($s,$r);
6624
}
6625
elsif (ref($_[$#_]) eq 'ARRAY') {
6626
0
foreach my $f (@{$_[$#_]}) {
0
6627
0
0
$d->{$f} =$r->{$f} if defined($r->{$f});
6628
}
6629
# $s->logRec('recLast', $i, map {($_=>$d->{$_})} @{$_[$#_]});
6630
}
6631
0
last;
6632
}
6633
0
$r
6634
}
6635
6636
6637
sub recUnion { # UNION cursor / container operation
6638
# (self, option=>value,... {hash}||[array]||cursor,...)
6639
0
0
1
DBIx::Web::dbcUnion->new(@_[1..$#_])
6640
}
6641
6642
6643
sub dbiWsubst { # WHERE substitution for '#funct'
6644
# (''|char, expr string, dbiSel vars) -> translated
6645
0
0
0
my ($s, $c, $q, $f, $a, $cf) =@_;
6646
0
my $r ='';
6647
0
0
if (!$c) {
0
0
0
6648
0
0
return($q) if $q !~/#[\w]+[\w\d]+\(/;
6649
0
while ($q =~/^(.*?)(['"]|#[\w]+[\w\d]+\()(.*)/) {
6650
0
$r .=$1;
6651
0
$q =$3;
6652
0
0
if (substr($2,0,1) eq '#') {
6653
0
my $c1 =substr($2,1,-1);
6654
0
my $q1 =dbiWsubst($s, '(', $q);
6655
0
0
$q1 =$1 if $q1 =~/^\(\s*(.*?)\)\s*$/;
6656
0
my @q1 =dbiWsubst($s, ',', $q1);
6657
0
0
if ($c1 =~/^(?:ftext|fulltext|qftext)$/i) {
0
6658
0
0
my $qs =!defined($q1[0])
0
6659
? '%'
6660
: $q1[0] =~/^['"](.*?)['"]$/
6661
? dbiQuote($s, '%' .$1 .'%')
6662
: $q1[0];
6663
0
$r .=dbiWSft($s, $f, $qs);
6664
}
6665
elsif ($c1 =~/^(?:urole)$/i) {
6666
0
my ($v, $u) =(dbiUnquote($s,$q1[0]), dbiUnquote($s,$q1[1]));
6667
0
0
$v ='authors' if !$v;
6668
0
$r .=join(' AND ', dbiWSur($s, $f, $v, $u, $_[5]));
6669
}
6670
else {
6671
0
0
$r .=$c1 .'(' .(!defined($q1[0]) ? '' : $q1[0]) .')'
6672
}
6673
}
6674
else {
6675
0
$r .=dbiWsubst($s, $2, $q)
6676
}
6677
}
6678
0
$r .=$q
6679
}
6680
elsif ($c eq '(') {
6681
0
$r =$c;
6682
0
while ($q =~/^(.*?)([()'"])(.*)/) {
6683
0
$q =$3;
6684
0
$r .=$1;
6685
0
0
if ($2 eq ')') {$r .=$2; last}
0
0
0
6686
else {$r .=dbiWsubst($s, $2, $q)}
6687
}
6688
0
$_[2] =$q;
6689
}
6690
elsif ($c =~/['"]/) {
6691
0
my $cq =$s->dbiQuote($c);
6692
0
$cq =substr($cq,1,-1);
6693
0
$r =$c;
6694
0
while ($q =~/^(.*?)(\Q$c\E|\Q$cq\E)(.*)/) {
6695
0
$q =$3;
6696
0
$r .=$1 .$2;
6697
0
0
last if $2 eq $c;
6698
}
6699
0
$_[2] =$q;
6700
}
6701
elsif ($c eq ',') {
6702
0
my @r;
6703
0
while ($q =~/^(.*?)(['"(]|\Q$c\E)(.*)/i) {
6704
0
$q =$3;
6705
0
$r .=$1;
6706
0
0
if ($2 eq $c) {
6707
0
0
push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r);
6708
0
$r ='';
6709
}
6710
else {
6711
0
$r .=dbiWsubst($s, $2, $q);
6712
}
6713
}
6714
0
$r .=$q;
6715
0
0
push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r) if $r ne '';
0
6716
0
return(@r)
6717
}
6718
else {
6719
0
$r =$c .$q
6720
}
6721
0
$r
6722
}
6723
6724
6725
sub dbiWSft { # Full text search condition substitution
6726
0
0
0
my($s, $f, $v) =@_;
6727
return(
6728
0
0
$s->{-table}->{$f}->{-ftext}
6729
? '(' .join(' OR '
6730
0
, map { ($_ =~/\./ ? $_ : "$f.$_")
6731
.' LIKE '
6732
. $v
6733
0
0
} @{$s->{-table}->{$f}->{-ftext}}
0
6734
) .')'
6735
: $s->{-table}->{$f}->{-field}
6736
? '(' .join(' OR '
6737
0
0
0
, map { ( $_->{-expr}
0
0
0
6738
? $_->{-expr}
6739
: $_->{-fld} =~/\./
6740
? $_->{-fld}
6741
: ($f .'.' .$_->{-fld}) )
6742
.' LIKE '
6743
.$v
6744
0
} grep {ref($_) eq 'HASH'
6745
&& $_->{-fld}
6746
&& ($_->{-flg}||'') =~/[akwuql]/
6747
&& (!$_->{-expr} ||($_->{-expr} !~/[-+*\/!|&%\s()]/))
6748
0
0
} @{$s->{-table}->{$f}->{-field}}
0
0
0
0
6749
) .')'
6750
: ref($a->{-data}) eq 'ARRAY'
6751
? '(' .join(' OR '
6752
0
0
0
, map { (!ref($_)
0
0
6753
?($_ =~/\./ ? $_ : "$f.$_")
6754
: ref($_) ne 'HASH'
6755
? $_->[1]
6756
: (defined($_->{-expr})
6757
? $_->{-expr}
6758
: $_->{-fld} =~/\./
6759
? $_->{-fld}
6760
: ($f .'.' .$_->{-fld})
6761
))
6762
. ' LIKE '
6763
.$v
6764
0
} grep {$_
6765
&& ((ref($_) ne 'HASH')
6766
|| ($_->{-fld}
6767
&& (!$_->{-expr}
6768
||($_->{-expr} !~/[-+*\/!|&%\s()]/))))
6769
0
0
} @{$a->{-data}}
6770
, $s->{-table}->{$f}->{-ftext}
6771
0
? map { ($_ =~/\./ ? $_ : "$f.$_")
6772
.' LIKE '
6773
.$v
6774
0
0
} @{$s->{-table}->{$f}->{-ftext}}
0
0
0
6775
: ()
6776
) .')'
6777
: '')
6778
}
6779
6780
6781
sub dbiWSur { # User role condition substitution
6782
0
0
0
my($s, $f, $r, $u) =@_;
6783
0
0
return(dbiACLike($s, 0, $f, undef
0
0
0
0
6784
, mdeRole($s, $f, $r)
6785
,($u
6786
? $s->ugnames($u)
6787
: $s->ugnames())
6788
, $_[4])
6789
, $r =~/^(?:manager|principal|user)$/i
6790
? dbiACLike($s, 0, $f, 'NOT'
6791
, mdeRole($s, $f, 'actor')
6792
,($u
6793
? $s->ugnames($u)
6794
: $s->ugnames())
6795
, $_[4])
6796
: $r =~/^(?:managers|principals|users)$/i
6797
? dbiACLike($s, 0, $f, 'NOT'
6798
, mdeRole($s, $f, 'actors')
6799
,($u
6800
? $s->ugnames($u)
6801
: $s->ugnames())
6802
, $_[4])
6803
: ())
6804
}
6805
6806
6807
sub dbiSel { # Select records from database
6808
# -select =>ALL, DISTINCT, DISTINCTROW, STRAIGHT_JOIN, HIGH_PRIORITY, SQL_SMALL_RESULT
6809
# -data =>[fields] | [field, [field=>alias], {-fld=>alias, -expr=>formula,..}]
6810
# -table =>[tables] | [[table=>alias], [table=>alias,join]]
6811
# -join[01] =>string
6812
# -join =>string
6813
# -join2 =>string
6814
# -key =>{field=>value}
6815
# -where =>string | [strings]
6816
# -ftext =>string
6817
# -version =>0|1
6818
# -order =>string | [field, [field=>order]]
6819
# -keyord =>-(a|f|d|b)(all|eq|ge|gt|le|lt)
6820
# -group =>string | [field, [field=>order]]
6821
# -filter =>sub{}(cursor, undef, {field=>value,...})
6822
0
0
0
my ($s, $a) =@_;
6823
0
my $t =$a->{-table};
6824
0
0
my $f =ref($t) ? $t->[0] : $t; $f =$1 if $f=~/^([^\s]+)/;
0
0
6825
0
my @c;
6826
my $r;
6827
0
0
0
if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') {
0
0
6828
# local $s->{-dbiph} =1 if !exists($s->{-dbiph});
6829
0
my @cn =!$a->{-key} ? ()
6830
0
: $s->{-dbiph} ? sort keys %{$a->{-key}}
6831
0
0
: keys %{$a->{-key}};
0
6832
0
my @cv =!$a->{-key} ? ()
6833
0
0
: $s->{-dbiph} ? map {ref($a->{-key}->{$_})
0
6834
0
0
? grep {!ref($_)} @{$a->{-key}->{$_}}
0
6835
: $a->{-key}->{$_}} @cn
6836
: ();
6837
0
0
my $kn =$s->{-table}->{$f} && $s->{-table}->{$f}->{-key} ||[];
6838
0
0
my $tf =$s->{-table}->{$f} && $s->{-table}->{$f}->{-mdefld};
6839
0
my $cf =$a->{-filter};
6840
0
0
@c =('SELECT '
6841
. ($a->{-select} ? $a->{-select} .' ' : '')
6842
. (!$a->{-data} ? ' * ' # Data
6843
: !ref($a->{-data}) ? ' ' .$a->{-data} .' '
6844
: ref($a->{-data}) ne 'ARRAY' ? ' * '
6845
: join(', '
6846
0
, map { my $v =ref($_) && $_ || $tf && $tf->{$_} || $_;
6847
0
0
!ref($v)
0
0
0
0
6848
? ($v =~/\./
6849
? $v
6850
: "$f.$v AS $v")
6851
: ref($v) ne 'HASH'
6852
? join(' AS ', @$v[0..1])
6853
: (defined($v->{-expr})
6854
? $v->{-expr} .' AS ' .$v->{-fld}
6855
: $v->{-fld} =~/\./
6856
? $v->{-fld}
6857
: ($f .'.' .$v->{-fld} .' AS ' .$v->{-fld})
6858
)
6859
0
0
} @{$a->{-data}}))
0
6860
. ' FROM ' # From
6861
. ( $a->{-join0} ? $a->{-join0} .' ' : '')
6862
. (ref($t)
6863
? join(' '
6864
0
, (map {!ref($_)
6865
? ($_,',')
6866
: (@$_, $_->[$#_] =~/(JOIN|,)$/i
6867
? ()
6868
: ',')} @$t)[0..-1])
6869
: dbiTblExpr($s, $t)
6870
)
6871
. ( $a->{-join1} ? $a->{-join1} : '')
6872
. join(''
6873
0
0
, map { my $v =ref($a->{$_}) ? &{$a->{$_}}($s,$a) : $a->{$_};
0
6874
0
0
!$v
0
6875
? ()
6876
: $v =~/^\s*(?:,|CROSS|JOIN|INNER|STRAIGHT_JOIN|LEFT|NATURAL|RIGHT|OUTER)\b/i
6877
? (' ' .$v .' ')
6878
: (', ' .$v .' ')
6879
} qw(-join -join2)
6880
)
6881
. ' WHERE ' # Where
6882
. join(' AND '
6883
, dbiKeyWhr($s, 0, $a, @cn) # Key condition
6884
,($a->{-where} # Where condition
6885
? '(' .$s->dbiWsubst(''
6886
,(!ref($a->{-where})
6887
? $a->{-where}
6888
0
: join(' AND ', map {$_
6889
0
0
} @{$a->{-where}})), $f, $a, $cf)
6890
.')'
6891
: ())
6892
,(ref($a->{-version}) # Version switch
6893
? ('((' .$f .'.' .$a->{-version}->[0]
6894
.' IS NULL OR ' .$f .'.' .$a->{-version}->[0]
6895
."='')"
6896
.($a->{-version}->[1]
6897
? " AND $f."
6898
.$a->{-version}->[1] ." <> '"
6899
.$a->{-version}->[2] ."')"
6900
: ')'))
6901
: ())
6902
,(($a->{-urole} && !$a->{-uname}) # Access control
6903
|| $s->uadmrdr()
6904
? ()
6905
: dbiACLike($s, 0, $f, undef
6906
, mdeReaders($s, $f), $s->ugnames(), $cf)
6907
)
6908
,(!$a->{-urole} # Role filter
6909
? ()
6910
: dbiWSur($s,$f,$a->{-urole},$a->{-uname},$cf)
6911
)
6912
,(!$a->{-ftext} # Full-text
6913
? ()
6914
: $s->dbiWSft($f,$s->dbi->quote('%' .$a->{-ftext} .'%'))
6915
)
6916
,(scalar(@cn) ||$a->{-where} ||ref($a->{-version})
6917
||$a->{-urole} ||$a->{-ftext}
6918
? ()
6919
: ('1=1')) # !!! TRUE may be? But database dependent!
6920
)
6921
. ($a->{-group} # Group by
6922
? ' GROUP BY '
6923
.(ref($a->{-group})
6924
0
0
0
? join(', ', map {!ref($_) ? $_ : join(' ',@$_)} @{$a->{-group}})
0
0
0
6925
: $a->{-group})
6926
: '')
6927
. ($a->{-order} # Order by
6928
? ' ORDER BY '
6929
.(ref($a->{-order})
6930
? join(', '
6931
0
,map { ref($_)
6932
? join(' ',@$_)
6933
: $_ !~/[\s,]/
6934
? $_ .($a->{-keyord} && ($a->{-keyord} =~/^-[db]/) ? ' desc' : '')
6935
: $_
6936
0
} @{$a->{-order}})
6937
: $a->{-order} =~/^-[db]/
6938
0
? join(',', map {"$_ desc"} @$kn)
6939
: substr($a->{-order},0,1) eq '-' # $a->{-order}=~/^-[af]/
6940
? join(',', @$kn)
6941
: $a->{-order} !~/[\s,]/
6942
? $a->{-order} .($a->{-keyord} && ($a->{-keyord} =~/^-[db]/) ? ' desc' : '')
6943
: $a->{-order})
6944
: $a->{-keyord} # -keyord
6945
? ' ORDER BY '
6946
.($a->{-keyord} =~/-[db]/
6947
0
0
0
? join(',', map {"$_ desc"} @$kn)
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
6948
: join(',', @$kn))
6949
: '')
6950
. ($a->{-having} # Having
6951
? ' HAVING ' .$a->{-having}
6952
: ''
6953
. ($a->{-limit} # Limit
6954
&& $s->dbiEng('mysql')
6955
? ' LIMIT ' .$a->{-limit}
6956
: '')
6957
)
6958
);
6959
0
0
$s->logRec('dbiSel', @c, @cv ? {} : (), @cv);
6960
0
0
$r =$s->dbi->prepare(@c) || return(&{$s->{-die}}($s->lng(0,'dbiSel') .": prepare() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef);
6961
0
0
0
$r->execute(@cv) || return(&{$s->{-die}}($s->lng(0,'dbiSel') .": execute() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef);
6962
0
0
0
$r =DBIx::Web::dbiCursor->new($r, -flt=>$cf)
6963
if $cf || 1; # !!! DBI::st hides keys!
6964
0
$r->{-rec} ={map {($_ => undef)} @{$r->{NAME}}};
0
0
6965
0
$r->{-rfr} =[map {\($r->{-rec}->{$_})} @{$r->{NAME}}];
0
0
6966
0
$r->{-flt} =$cf;
6967
0
$r->bind_columns(undef, @{$r->{-rfr}});
0
6968
0
0
0
$s->logRec('dbiSel', 'FETCH') if !$s->{-affect} || ($s->{-affect} >1);
6969
0
0
0
$s->dbiExplain(@c) if $s->{-debug} && $s->dbiEng('mysql');
6970
}
6971
elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') {
6972
0
$r =$s->dbmSeek($a);
6973
0
0
0
return(&{$s->{-die}}($s->lng(0,'dbiSel') .": dbiSeek() -> $@" .$s->{-ermd}) && undef) if !defined($r);
6974
0
0
0
if ($a->{-data} && (ref($a->{-data}) eq 'ARRAY')) {
0
6975
0
$r->setcols($a->{-data})
6976
}
6977
elsif (my $m =$s->{-table}->{$f}->{-field}) {
6978
0
$r->setcols(ref($m) eq 'HASH'
6979
? keys %$m
6980
0
0
: map {$_->{-fld}} grep {(ref($_) eq 'HASH') && $_->{-fld}} @$m)
0
0
6981
}
6982
}
6983
$r
6984
0
}
6985
6986
6987
sub recCommit { # commit changes in the database
6988
0
0
1
$_[0]->logRec('recCommit');
6989
0
0
if ($_[0]->{-dbi}) {
6990
$_[0]->{-dbi}->commit
6991
0
0
0
|| ($DBI::errstr && return(&{$_[0]->{-die}}($_[0]->lng(0,'recCommit') .": commit() -> " .($DBI::errstr||'Unknown') .$_[0]->{-ermd}) && undef))
0
6992
}
6993
0
$_[0]
6994
}
6995
6996
6997
sub recRollback {# rollback changes in the database
6998
0
0
1
$_[0]->logRec('recRollback');
6999
0
0
if ($_[0]->{-dbi}) {
7000
$_[0]->{-dbi}->rollback
7001
0
0
0
|| ($DBI::errstr && return(&{$_[0]->{-die}}($_[0]->lng(0,'recRollback') .": rollback() -> " .($DBI::errstr||'Unknown') .$_[0]->{-ermd}) && undef))
0
7002
}
7003
0
$_[0]
7004
}
7005
7006
7007
#########################################################
7008
# CGI User Interface
7009
#########################################################
7010
7011
7012
sub cgiRun { # Execute CGI query
7013
0
0
1
my $s =$_[0];
7014
0
my $r;
7015
0
local($s->{-pcmd}, $s->{-pdta}, $s->{-pout});
7016
# Automatic upgrade
7017
0
0
0
if ($s->{-setup} && !$ARGV[0]
0
0
7018
&& (!$s->{-diero} ||($s->{-diero} ne 'e'))) {
7019
0
0
my $ds =(stat(main::DATA))[9] ||0;
7020
0
0
my $dv =($ds && (stat($s->varFile()))[9])||0;
7021
0
0
$ARGV[0] ='-setup' if $ds >$dv;
7022
}
7023
# Command line service options
7024
0
0
0
if ($ARGV[0] && ($ARGV[0] =~/^-/)) {
7025
0
$s->start();
7026
0
print "Content-type: text/plain\n\n";
7027
0
print "'$0' service operation: '" .$ARGV[0] ."'...\n";
7028
0
0
if ($ARGV[0] eq '-reindex') {
0
0
7029
0
$r =$s->recReindex(1);
7030
}
7031
elsif ($ARGV[0] eq '-setup') {
7032
0
$r =$s->setup();
7033
0
$s->varStore();
7034
}
7035
elsif ($ARGV[0] eq '-call') {
7036
0
$r =$ARGV[1];
7037
0
$r =$s->$r(@ARGV[2..$#ARGV]);
7038
}
7039
# print "'$0' service operation: '" .$ARGV[0] ."'->$r\n";
7040
0
$s->end();
7041
0
return($s)
7042
}
7043
# Error display handler
7044
0
$s->{-ermu} ='/*User*/ ';
7045
0
$s->{-ermd} =' /*Trace*/ ';
7046
0
local $SELF =$s;
7047
my $he =sub{
7048
0
0
my $s =$SELF;
7049
0
0
0
if (!$s
7050
||$s->ineval()) {
7051
0
0
0
if ($s && $s->{-diero} && ($s->{-diero} eq 'o')) {
0
7052
0
CORE::die(@_)
7053
}
7054
return
7055
0
}
7056
0
0
delete $s->{-pcmd}->{-xml} if $s->{-pcmd};
7057
0
my $e =join('',@_); chomp($e);
0
7058
0
my $ermu =$s->{-ermu};
7059
0
0
0
if ($ermu && ($e =~/^\Q$ermu\E(.*)/)) {$e =$1}
0
0
7060
else {$ermu =undef}
7061
0
0
eval{$s->logRec('Die', $e)} if !$ermu;
0
7062
0
eval{$s->recRollback()};
0
7063
0
0
0
$s->{-c}->{-httpheader} =$s->{-c}->{-httpheader} ||"Content-type: text/html\n\n"
7064
if *fatalsToBrowser{CODE};
7065
0
0
eval{ $s->output($s->htmlStart());
0
7066
0
local $s->{-pcmd}->{-cmd} ='frmErr';
7067
0
local $s->{-pcmd}->{-cmg} ='frmHelp';
7068
0
local $s->{-pcmd}->{-backc} =0;
7069
0
$s->output($s->htmlHidden(),$s->htmlMenu());
7070
}
7071
if !$s->{-c}->{-htmlstart};
7072
0
eval{ my $h2;
0
7073
0
my $ermd =$s->{-ermd};
7074
0
0
if ($e =~/\Q$ermd\E/) {
0
7075
0
$h2 =$`;
7076
0
$e =$';
7077
}
7078
elsif ($e =~/[\n\r]/) {
7079
0
$h2 =$`;
7080
0
$e =$';
7081
0
0
if ($h2 =~/\s+(?:at\s+)*line\s+\d+\s+at\s+[^\s]+?\s+line\s+\d+\s*$/) {
0
7082
0
$h2 =$`;
7083
0
$e =$& ."\n\r" .$e
7084
}
7085
elsif ($h2 =~/\s+at\s+[^\s]+?\s+line\s+\d+$/) {
7086
0
$h2 =$`;
7087
0
$e =$& ."\n\r" .$e
7088
}
7089
}
7090
else {
7091
0
$h2 =$e;
7092
0
$e ='';
7093
}
7094
0
$e =~s/[\n\r]/ \n/g;
7095
0
0
0
$s->output(' '
0
7096
,''
7097
, htmlEscape($s, lng($s, 0,'Error')), ' '
7098
, htmlEscape($s, lng($s, 0, ($s->{-pcmd} && $s->{-pcmd}->{-cmd})||'Open'))
7099
, '@'
7100
, htmlEscape($s, lng($s, 0, ($s->{-pcmd} && $s->{-pcmd}->{-cmg})||'Start'))
7101
, "\n"
7102
, $h2
7103
? ''
7104
.$h2
7105
."\n"
7106
: ()
7107
, $e, "\n");
7108
0
$s->cgiFooter();
7109
0
$s->output(" \n",$s->htmlEnd())};
7110
0
eval{$s->end()};
0
7111
0
0
0
if ($s->{-diero} && ($s->{-diero} eq 'o')) {
7112
0
0
if ($ermu) {goto cgiRunEND}
0
0
7113
else {CORE::die(@_)}
7114
0
}};
7115
0
0
0
if ($s->{-diero}) {
0
0
0
7116
}
7117
elsif (1 && ($ENV{MOD_PERL} || (($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {
7118
0
local $s->{-diero} ='e';
7119
0
$SIG{__DIE__}='DEFAULT';
7120
# $s->{-serial} =0 if $s->{-serial};
7121
0
my $r =eval{$s->cgiRun(); 1};
0
0
7122
0
local $CACHE->{-destroy} =0;
7123
0
0
if (!$r) {
7124
0
&$he($@);
7125
0
$s->DESTROY();
7126
0
return(undef);
7127
}
7128
else {
7129
0
$s->DESTROY();
7130
0
return($s);
7131
}
7132
}
7133
elsif (0 && ($ENV{GATEWAY_INTERFACE} && ($ENV{GATEWAY_INTERFACE} =~/PerlEx/))) {
7134
# !!! Remove this obsolette fix code and clean above
7135
$s->{-diero} ='o';
7136
$s->{-die} =$he;
7137
$SIG{__DIE__} ='DEFAULT';
7138
if (*fatalsToBrowser{CODE}) {
7139
!*CGI::Carp::set_message{CODE} && eval('use CGI::Carp');
7140
CGI::Carp::set_message($he);
7141
}
7142
if ($s->{-serial}) { # prevent locking buzz
7143
$s->logRec('cgiRun', 'PerlEx', -serial =>0);
7144
$s->{-serial} =0;
7145
}
7146
}
7147
elsif (*fatalsToBrowser{CODE}) {
7148
0
0
!*CGI::Carp::set_message{CODE} && eval('use CGI::Carp');
7149
0
$SIG{__DIE__} =\&CGI::Carp::die;
7150
0
CGI::Carp::set_message($he);
7151
}
7152
else {
7153
0
$SIG{__DIE__} =$he;
7154
}
7155
7156
# Start operation
7157
0
$s->start();
7158
0
$s->set(-autocommit=>0);
7159
0
local $s->{-affect} =1;
7160
7161
# cmg transitions:
7162
# global commands
7163
# ------- --------
7164
# recList: recList, recForm, recQBF->
7165
# recQBF: recQBF, recForm, recList->
7166
# recNew: recNew, recForm, recIns->
7167
# recRead: recRead, recEdit, recForm, recIns, recUpd, recDel->, recNew->
7168
# recDel: recForm
7169
# recForm? recForm
7170
7171
# Accept & parse CGI params, find form, command, global command, key...
7172
0
$s->cgiParse();
7173
0
local $s->{-pcmd}->{-ui} =1;
7174
0
my $oa =$s->{-pcmd}->{-cmd};
7175
0
0
my $og =$s->{-pcmd}->{-cmg} ||$oa;
7176
0
0
my $on =$s->{-pcmd}->{-form} ||'default';
7177
0
my ($om, $oc);
7178
7179
# Login redirection, if needed
7180
0
0
0
if ($s->{-pcmd}->{-login} && $s->uguest()) {
7181
0
0
print $s->cgi->redirect(-uri=>$s->urlAuth(), -nph=>(($ENV{SERVER_SOFTWARE}||'') =~/IIS/) ||($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER}));
7182
0
$s->end();
7183
0
return($s);
7184
}
7185
7186
# Navigation Search Pane or LEFT / RIGHT Frameset
7187
0
0
0
if ($s->{-pcmd}->{-search} && (length($s->{-pcmd}->{-search}) >1)) {
0
7188
0
$s->{-c}->{-search} =$s->{-pcmd}->{-search}
7189
}
7190
elsif ($s->{-search}) {
7191
0
0
$s->{-c}->{-search} =ref($s->{-search}) ? &{$s->{-search}}($s,$s->{-pcmd}) : $s->{-search};
0
7192
0
0
0
delete $s->{-c}->{-search}
0
0
7193
if !defined($s->{-c}->{-search})
7194
|| (($s->{-c}->{-search} =~/\b_frame=RIGHT\b/)
7195
&& !$s->{-pcmd}->{-search}
7196
&& ($on !~/^(?:default|start|index)$/));
7197
}
7198
0
0
0
if ($s->{-pcmd}->{-search} && ($s->{-c}->{-search} =~/\b_frame=RIGHT\b/)) {
7199
0
my $sch =$s->{-c}->{-search};
7200
0
$sch =~s/\b_search=1\b/_search=0/;
7201
0
0
$sch =$s->url .$sch if $sch =~/^?/;
7202
0
0
0
$s->output(''
7203
, $s->cgi->header(-charset => $s->charset()
7204
,-type => 'text/html')
7205
,'
7206
.($s->{-lang} ? ' lang="' .$s->lang(0,'-lang') .'"' : '')
7207
.">\n\n"
7208
,''
7209
,$s->{-title} ||$s->cgi->server_name()
7210
,"\n"
7211
,' ' ."\n"
7212
,'',"\n"
7213
,''
7214
,'
7215
,$s->htmlEscape($sch)
7216
,'">'
7217
,'
7218
,$s->urlOpt(-search=>0)
7219
,'">'
7220
,''
7221
,'',"\n");
7222
0
$s->end();
7223
0
return($s)
7224
}
7225
7226
# TOP / BOTTOM Frameset
7227
0
0
0
if ($s->{-pcmd}->{-frame} && ($s->{-pcmd}->{-frame} eq 'set')) {
7228
0
delete $s->{-pcmd}->{-frame};
7229
0
0
0
$s->output(''
0
0
0
7230
, $s->cgi->header(-charset => $s->charset()
7231
,-type => 'text/html')
7232
,'
7233
.($s->{-lang} ? ' lang="' .$s->lang(0,'-lang') .'"' : '')
7234
.">\n\n"
7235
,''
7236
,$s->{-title} ||$s->cgi->server_name()
7237
,"\n"
7238
,' ' ."\n"
7239
,'',"\n"
7240
,'',"\n"
7241
,'
7242
.($s->{-pcmd}->{-form} eq 'default'
7243
? $s->htmlEscape($s->urlCmd('',-frame=>'BOTTOM'))
7244
: $s->htmlEscape($s->urlOpt(-frame=>'BOTTOM',
7245
uc($ENV{REQUEST_METHOD}||'') ne 'GET'
7246
? ()
7247
: ('_all'=>1)))
7248
) # !!! Mozilla no OnLoad target
7249
.'">',"\n"
7250
,'
7251
.$s->urlCat($s->url)
7252
.'">',"\n"
7253
,'',"\n"
7254
,'',"\n");
7255
0
return($s);
7256
}
7257
7258
0
0
0
if (($on =~/\.psp$/i) # Perlscript file immediate
7259
&& ($oa =~/^(?:frmCall|recForm|recList)$/)) {
7260
0
0
0
return(&{$s->{-die}}($s->lng(0,'cgiRun') .": Operation object '$on' illegal" .$s->{-ermd}) && undef)
7261
if $on =~/[\\\/]\.+[\\\/]/;
7262
0
0
my $f =$0 =~/^(.+[\\\/])[^\\\/]+$/ ? $1 .$on : $on;
7263
0
$s->psEval('-', $f, undef, $on, $om, $s->{-pcmd}, $s->{-pdta});
7264
0
$s->end();
7265
0
return($s);
7266
}
7267
7268
# Wikiname
7269
0
0
if ($s->{-pcmd}->{-wikn}) {
7270
0
0
my $v =$s->recWikn($s->{-pcmd}->{-wikn},$s->{-pcmd}->{-wikq} ||$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table});
7271
0
0
if ($v) {
7272
0
foreach my $k (keys %$v) {
7273
0
$s->{-pcmd}->{$k} =$v->{$k}
7274
}
7275
0
$on =$s->{-pcmd}->{-form} =$v->{-table};
7276
0
0
$oa =$og =$s->{-pcmd}->{-cmd} =$s->{-pcmd}->{-cmg}
7277
=$s->{-pcmd}->{-cmh} =$v->{-cmd}
7278
if $v->{-cmd};
7279
}
7280
}
7281
# Encoded form / table
7282
0
0
0
if ((!$s->{-pcmd}->{-form} || ($s->{-pcmd}->{-form} eq 'default'))
0
0
7283
&& ($s->{-pcmd}->{-key} || $s->{-pdta})) {
7284
0
$s->rmlKey($s->{-pcmd}, $s->{-pdta});
7285
0
0
$on =$s->{-pcmd}->{-form} if $s->{-pcmd}->{-form};
7286
}
7287
7288
# Determine / Delegate operation object requested / Execute
7289
0
while (1) {
7290
0
0
0
if ($s->{-form} && $s->{-form}->{$on}) {$oc ='f'; $om =$s->{-form}->{$on}}
0
0
0
0
0
7291
0
elsif ($s->{-table} && $s->mdeTable($on)) {$oc ='t'; $om =$s->mdeTable($on)}
0
7292
0
else {$oc ='' ; $om =undef}
7293
0
0
0
return(&{$s->{-die}}($s->lng(0,'cgiRun') .": Operation object '$on' not found" .$s->{-ermd}) && undef)
7294
if !$om;
7295
0
0
$s->{-pcmd}->{-table} =($oc eq 't' ? $on : $om->{-table});
7296
7297
# translation trigger
7298
0
0
&{$s->{-cgiRun0A}}($s,$s->{-pcmd})
0
7299
if $s->{-cgiRun0A};
7300
0
0
0
&{$s->{-table}->{$s->{-pcmd}->{-table}}->{-cgiRun0A}}($s,$s->{-pcmd})
0
0
0
7301
if $s->{-table}
7302
&& $s->{-pcmd}->{-table}
7303
&& $s->mdeTable($s->{-pcmd}->{-table})
7304
&& $s->{-table}->{$s->{-pcmd}->{-table}}->{-cgiRun0A};
7305
0
0
0
&{$om->{-cgiRun0A}}($s,$s->{-pcmd})
0
7306
if $om && $om->{-cgiRun0A};
7307
7308
# redirectional implemtation: '-cgcURL'
7309
0
foreach my $e (map {$om->{$_}} ('-cgcURL', '-redirect')) {
0
7310
0
0
next if !defined($e);
7311
0
0
last if !$e;
7312
0
0
last if $oa eq 'frmHelp';
7313
0
0
print $s->cgi->redirect(-uri=>$e, -nph=>(($ENV{SERVER_SOFTWARE}||'') =~/IIS/) ||($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER}));
7314
0
$s->end();
7315
0
return($r);
7316
}
7317
# external implemtation: '-cgcXXX'
7318
0
0
foreach my $e (map {$om->{"-cgc$_"}}
0
0
7319
$oa =~/^rec(.+)/ ? $1 : $oa
7320
,$og =~/^rec(.+)/ ? $1 : $og, 'Call') {
7321
0
0
next if !defined($e);
7322
0
0
last if !$e;
7323
0
0
last if $oa eq 'frmHelp';
7324
0
$s->cgibus(1);
7325
0
0
$s->{-pcmd}->{-form} =$on if !ref($e);
7326
0
0
0
$e =$` .$e if !ref($e) && !-f $e && ($0=~/[^\\\/]+$/);
0
7327
0
$_ =$s;
7328
0
0
$r = ref($e)
0
7329
? &$e($s, $on, $om, $s->{-pcmd}, $s->{-pdta})
7330
: $e =~/\.psp$/i
7331
? $s->psEval('-', $e, undef, $on, $om, $s->{-pcmd}, $s->{-pdta})
7332
: do($e);
7333
0
$s->end();
7334
0
return($r)
7335
}
7336
7337
0
my $nxt; # delegation - substitute object
7338
0
0
foreach my $v (map {$om->{"-$_"}}
0
7339
'subst', $oa
7340
, $og =~/rec(New|Read|Del|QBF)/
7341
? ($og, 'recForm')
7342
: $og) {
7343
0
0
0
next if !defined($v) || ref($v);
7344
0
0
last if !$v;
7345
0
$on = $nxt =$v;
7346
last
7347
0
}
7348
0
0
0
$on =$nxt =$s->{-pcmd}->{-form} =$om->{-table}
0
0
0
0
0
0
0
7349
if !$nxt
7350
&& ($og eq 'recNew') && ($oc eq 'f')
7351
&& !exists($om->{-recNew}) && !exists($om->{-recForm})
7352
&& !$om->{-field}
7353
&& $om->{-table} && $s->mdeTable($om->{-table})
7354
&& !$s->{-table}->{$om->{-table}}->{-ixcnd};
7355
0
0
next if $nxt;
7356
0
last;
7357
}
7358
7359
# Execute action
7360
0
$s->cgibus(1);
7361
0
0
if (ref(my $e =$om->{"-$oa"}) eq 'CODE') {
7362
0
$s->{-pout} =&$e($s, $on, $om, $s->{-pcmd}, $s->{-pdta});
7363
}
7364
else {
7365
0
$s->{-pout} =$s->cgiAction($on, $om, $s->{-pcmd}, $s->{-pdta});
7366
}
7367
7368
# Reassign form if changed
7369
0
0
$s->{-pcmd}->{-form} =(isa($s->{-pout}, 'HASH') && $s->{-pout}->{-form})
7370
|| $s->{-pcmd}->{-form} ||$on;
7371
7372
# Execute external presentation '-cgvXXX'
7373
0
0
foreach my $e (map {$om->{"-cgv$_"}}
0
0
7374
$oa =~/^rec(.+)/ ? $1 : $oa
7375
,$og =~/^rec(.+)/ ? $1 : $og, 'Call') {
7376
0
0
next if !defined($e);
7377
0
0
last if !$e;
7378
0
0
last if $oa eq 'frmHelp';
7379
0
$_ =$s;
7380
0
0
$r = ref($e)
0
7381
? &$e($s, $on, $om, $s->{-pcmd}, $s->{-pout})
7382
: $e =~/\.psp$/i
7383
? $s->psEval('-', $e, undef, $on, $om, $s->{-pcmd}, $s->{-pout})
7384
: do($e);
7385
0
$s->end();
7386
0
return($r);
7387
}
7388
7389
# Execute predefined presentation implementation
7390
$s->output(
7391
0
$s->htmlStart($s->{-pcmd}->{-form}, $om) # HTTP/HTML/Form headers
7392
,$s->htmlHidden($s->{-pcmd}->{-form}, $om) # common hidden fields
7393
,$s->htmlMenu($on, $om) # Menu bar
7394
);
7395
0
0
$s->cgiForm($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('recFormRWQ');
7396
0
0
$s->cgiList($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('recList');
7397
0
0
$s->cgiHelp($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('frmHelp');
7398
0
$s->recCommit();
7399
0
$s->cgiFooter();
7400
0
$s->output($s->htmlEnd());
7401
0
$s->end();
7402
0
cgiRunEND:
7403
$s
7404
}
7405
7406
7407
sub cgiParse { # Parse CGI call parameters
7408
0
0
1
my ($s) =@_;
7409
0
my $g =$s->cgi;
7410
0
my $d =$g->Vars;
7411
0
$s->{-pcmd} ={};
7412
0
$s->{-pdta} ={};
7413
0
0
$s->{-lng} =$g->http('Accept_language')||'';
7414
0
0
$s->set(-lng =>lc($s->{-lng} =~/^([^ ;,]+)/ ? $1 : $s->{-lng}));
7415
0
foreach my $k (keys %$d) {
7416
0
0
0
next if !defined($d->{$k} || $d->{$k} eq '');
7417
0
0
if($k =~/^_(quname)__S$/) { # cgiDDLB choise
0
0
0
0
0
7418
0
$s->{-pcmd}->{"-$1"} =$d->{'_' .$1 .'__L'};
7419
0
$s->{-pdta}->{$k} =$d->{$k};
7420
0
$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
7421
}
7422
elsif($k =~/^(.+)__S$/) { # cgiDDLB choise
7423
0
$s->{-pdta}->{$1} =$d->{$1 .'__L'};
7424
0
$s->{-pdta}->{$k} =$d->{$k};
7425
0
$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
7426
}
7427
elsif($k =~/^(.+)__R$/) { # cgiDDLB reset
7428
0
$s->{-pdta}->{$1} =undef;
7429
0
$s->{-pdta}->{$1 .'__S'} =$d->{$k};
7430
0
$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
7431
}
7432
elsif($k =~/^(.+)__O$/) { # cgiDDLB open
7433
0
$s->{-pdta}->{$k} =$d->{$k};
7434
0
$d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm';
7435
}
7436
elsif($k =~/^_(new|file)$/) { # record attribute
7437
0
$s->{-pdta}->{"-$k"} =$d->{$k}
7438
}
7439
elsif ($k =~/^_(cmd|cmg|frmCall|frmName\d*|frmLso|frmLsc|frmHelp|recNew|recRead|recPrint|recXML|recHist|recEdit|recIns|recUpd|recDel|recForm|recList|recQBF|submit.*|app.*|form|key|wikn|wikq|proto|urm|qjoin|qkey|qwhere|qurole|quname|qftext|qversion|version|qorder|qkeyord|qlist|qlimit|qdisplay|qftwhere|qftord|qftlimit|edit|backc|login|print|xml|hist|refresh|style|frame|search)(?:\.[xXyY]){0,1}$/i) {
7440
0
my ($c, $v) =($1, $d->{$k}); # command
7441
0
0
0
$v =$1 if ($k !~/^_(key|proto|qkey|qftext)/i)
7442
&& ($v =~/^\s*(.+?)\s*$/);
7443
0
0
if ($k =~/^(.+)\.[xXyY]$/) {
7444
0
$g->param($1, 1);
7445
0
$g->delete($k);
7446
0
$v=1;
7447
}
7448
0
0
0
if ($c =~/^(?:rec|frmCall|frmHelp|submit)/i) {
0
7449
0
$s->{-pcmd}->{-cmd} =$c
7450
}
7451
elsif (($c eq 'frmLso') && ($v =~/,/)) {
7452
0
$s->{-pcmd}->{"-$c"}=[split /\s*,\s*/, $v];
7453
}
7454
else {
7455
0
$s->{-pcmd}->{"-$c"}=$v
7456
}
7457
}
7458
else { # data
7459
0
$s->{-pdta}->{$k} =$d->{$k}
7460
}
7461
}
7462
0
my $c =$s->{-pcmd};
7463
7464
0
0
0
$c->{-cmg} ='recList'
7465
if !$c->{-cmg} && !$c->{-cmd};
7466
0
0
$c->{-cmd} =!$c->{-cmg}? 'frmCall'
0
0
7467
: $c->{-cmg} eq 'recList' ? 'recList' : 'recForm'
7468
if !$c->{-cmd};
7469
0
0
$c->{-cmg} =$c->{-cmd} eq 'recForm' ? 'recList' : $c->{-cmd}
0
7470
if !$c->{-cmg};
7471
7472
0
map {$c->{$_} =datastr($s, $c->{$_})
0
7473
0
} grep {$c->{$_}} qw(-key -qkey -proto);
7474
0
0
0
$c->{-key} =$s->rmlKey($c, $s->{-pdta})
0
7475
if $c->{-key} && !ref($c->{-key}) && $s->{-idsplit};
7476
0
0
0
$c->{-form}=$c->{-table}
7477
if !$c->{-form} && $c->{-table};
7478
7479
0
0
0
if ($c->{-frmLso} && $c->{-frmLso} eq 'recQBF') {
7480
0
$c->{-cmd} =$c->{-frmLso};
7481
0
delete $c->{-frmLso};
7482
0
$g->delete('_frmLso');
7483
}
7484
0
0
if ($c->{-cmd} eq 'frmCall') {
7485
0
0
my $frm =($c->{-frmName1} ||$c->{-frmName} ||$c->{-form} ||'default');
7486
0
0
if ($frm eq '-frame=set') {
7487
0
$c->{-frame} ='set';
7488
0
0
$c->{-form} =$c->{-form} ||'default';
7489
}
7490
else {
7491
0
0
$c->{-cmd} =$c->{-cmg} =($frm =~/[+]+\s*$/
0
7492
? 'recNew'
7493
: $frm =~/[&.^]+\s*$/
7494
? 'recForm'
7495
: 'recList');
7496
0
0
$frm =($frm=~/^(.+)(?:\s*[+&.^]+\s*)$/ ? $1 : $frm);
7497
0
0
0
if ($frm ne ($c->{-form}||'')) {
7498
# !!! query parameters for current view only, not table
7499
0
map {delete $c->{$_}
0
7500
} qw (-frmLso -frmLsc -qjoin -qkey -qwhere -qurole -quname -qversion -qorder -qkeyord);
7501
0
$g->delete('_frmLso');
7502
0
0
0
delete $c->{-key}
7503
if ($c->{-cmd} eq 'recList')
7504
|| ($c->{-cmg} eq 'recList');
7505
0
$c->{-backc} =0;
7506
}
7507
0
$c->{-form} =$frm;
7508
}
7509
}
7510
7511
0
0
if ($c->{-cmd} eq 'recNew') {
0
0
0
0
0
0
0
7512
0
$c->{-edit} =1;
7513
0
$c->{-backc}=0;
7514
}
7515
elsif ($c->{-cmd} eq 'recEdit') {
7516
0
$c->{-edit} =1;
7517
0
$c->{-cmd} ='recRead'
7518
}
7519
elsif ($c->{-cmd} eq 'recQBFReset') {
7520
0
foreach my $k (qw(-qjoin -qkey -qwhere -qurole -quname -frmLso -frmLsc)) {
7521
0
delete $c->{$k};
7522
}
7523
0
$c->{-cmd} ='recList';
7524
0
$c->{-cmg} ='recList';
7525
0
0
$c->{-form} =$c->{-qlist} || $c->{-form};
7526
0
$c->{-backc}=0;
7527
}
7528
elsif ($c->{-cmd} eq 'recPrint') {
7529
0
$c->{-print} =1;
7530
0
$c->{-cmd} ='recRead'
7531
}
7532
elsif ($c->{-cmd} eq 'recXML') {
7533
0
$c->{-xml} =1;
7534
0
0
$c->{-cmd} =$c->{-cmg} ||'recRead';
7535
0
0
$c->{-cmd} ='recList' if $c->{-cmd} =~/^(?:recXML|recQBF)$/;
7536
}
7537
elsif ($c->{-cmd} eq 'recHist') {
7538
0
$c->{-hist} =1;
7539
0
$c->{-cmd} ='recRead';
7540
# $c->{-backc}=0;
7541
}
7542
elsif ($c->{-cmd} eq 'frmHelp') {
7543
0
$c->{-edit} =undef;
7544
0
0
$c->{-backc}=0 if ($c->{-cmg} ne $c->{-cmd});
7545
}
7546
elsif ($c->{-cmd} !~/^(recIns|recUpd|recForm)/) {
7547
0
$c->{-edit} =undef
7548
}
7549
7550
0
0
0
if ($c->{-cmd} =~/recList/ and $c->{-key}) {
7551
0
$c->{-qkey} =$c->{-key};
7552
0
delete $c->{-key};
7553
}
7554
7555
0
0
0
if ($c->{-cmd} =~/recList/ and $c->{-cmg} =~/recQBF/) {
0
0
7556
0
$c->{-qkey} =$s->cgiQKey($c->{-form}, undef, $s->{-pdta});
7557
0
0
$c->{-qkey} ='' if !%{$c->{-qkey}};
0
7558
0
0
foreach my $k (qw(-frmLso -frmLsc)) {delete $c->{$k} if !$c->{$k}};
0
7559
0
0
$c->{-form} =$c->{-qlist} || $c->{-form};
7560
0
$c->{-backc}=0;
7561
}
7562
elsif ($c->{-cmd} =~/recQBF/ && $c->{-cmg} =~/recList/) {
7563
0
$c->{-edit} =1;
7564
0
$s->{-pdta} ={};
7565
0
0
0
map { $s->{-pdta}->{$_} =$c->{-qkey}->{$_}
0
7566
if defined($c->{-qkey}->{$_})
7567
&& $c->{-qkey}->{$_} ne ''
7568
0
0
} keys %{$c->{-qkey}}
7569
if ref($c->{-qkey});
7570
0
$c->{-qlist}=$c->{-form};
7571
0
$c->{-backc}=0;
7572
}
7573
7574
0
0
if ($c->{-cmd} !~/recList/) {
7575
0
delete $c->{-refresh};
7576
}
7577
0
0
0
$c->{-backc} =( ($c->{-cmd} eq 'recForm')
0
7578
|| ($c->{-cmd} eq 'recIns')
7579
|| ($c->{-cmd} eq 'frmHelp')
7580
|| (($c->{-cmd} eq 'recRead') || ($c->{-cmg} eq 'recRead'))
7581
|| (($c->{-cmd} eq 'recList') || ($c->{-cmg} eq 'recList'))
7582
? ($c->{-backc}||0) +1
7583
: 1);
7584
0
$c->{-cmh} =$c->{-cmg}; # history general command
7585
0
$c->{-cmg} =$s->cgiHook('cmgNext'); # actual general command
7586
0
$s
7587
}
7588
7589
7590
sub cgiHook { # HTML generation hook condition
7591
0
0
0
0
$_[0]->cgiParse() if !$_[0]->{-pcmd}->{-cmd};
7592
0
my $c =$_[0]->{-pcmd};
7593
0
0
return($c->{-cmd}) if !$_[1];
7594
0
($_[1] eq $c->{-cmd}) # current operation
7595
? $c->{-cmd}
7596
: ($_[1] eq 'recOp') # record operation (exept 'recList')
7597
&& ($c->{-cmd} =~/^rec(New|Form|Read|Edit|Ins|Upd|Del)/)
7598
? $c->{-cmd}
7599
: ($_[1] eq 'cmgNext') # next global command to output as hidden
7600
? ( $c->{-cmd} eq 'recForm'
7601
? $c->{-cmg}
7602
0
0
0
: (grep {$c->{-cmd} eq $_} qw(recIns recUpd))
0
0
0
0
0
0
0
0
0
0
0
7603
? 'recRead'
7604
: $c->{-cmd} eq 'recDel'
7605
? $c->{-cmd}
7606
: $c->{-cmd})
7607
: ($_[1] =~/^recForm/) # generate HTML form of record
7608
&&($c->{-cmd} !~/app|Help/)
7609
&&( $_[1] !~/^recForm([RWDQL]+)/
7610
||($_[1] =~/[WR]/ && $c->{-cmg} =~/^rec(Form|Read)/)
7611
||($_[1] =~/[W]/ && $c->{-cmg} =~/^rec(New|Form|Read|Ins|Upd)/)
7612
||($_[1] =~/[D]/ && $c->{-cmg} =~/^rec(Del)/)
7613
||($_[1] =~/[Q]/ && $c->{-cmg} eq 'recQBF')
7614
||($_[1] =~/[L]/ && $c->{-cmg} eq 'recList')
7615
)
7616
? $c->{-cmd}
7617
: ($_[1] eq 'recList') # generate HTML list of records
7618
&& ($c->{-cmd} eq 'recList')
7619
? $c->{-cmd}
7620
: ($_[1] eq 'recCommit') # commit database operation
7621
&& ($c->{-cmd} =~/^rec(New|Form|Read|Ins|Upd|Del|List)/)
7622
? $c->{-cmd}
7623
: ''
7624
}
7625
7626
7627
sub urlAuth { # Login URL
7628
0
0
1
my $s =$_[0];
7629
0
my $u =$s->{-login};
7630
0
0
if ($u =~/\/$/) {
7631
0
my $u0=$u;
7632
0
my $u1=$s->cgi->self_url; #url(-absolute=>1);
7633
0
0
$u1=($u1=~/^\w+:\/\/[^\/]+(.+)/ ? $1 : $u1);
7634
0
my $i;
7635
0
0
while (($i =index($u0, '/')) >=0 and substr($u0,0,$i) eq substr($u1,0,$i)) {
7636
0
$u0 =substr($u0, $i+1); $u1 =substr($u1, $i+1);
0
7637
}
7638
0
$u .=$u1
7639
}
7640
$u
7641
0
}
7642
7643
7644
7645
sub urlOptl { # Option URL arg list
7646
0
0
0
my $s =$_[0];
7647
0
my %v =();
7648
0
my $l =0;
7649
0
my $m =800; # query length limit, was 100
7650
# MSDN: METHOD Attribute | method Property:
7651
# the URL cannot be longer than 2048 bytes
7652
0
for (my $i =1; $i <$#_; $i+=2) {
7653
0
0
0
next if !defined($_[$i+1]) ||($_[$i+1] eq '');
7654
0
0
$v{$_[$i] =~/^-/ ? '_' .substr($_[$i],1) : $_[$i]}
0
7655
=ref($_[$i+1]) ? $s->strdata($_[$i+1]) : $_[$i+1];
7656
};
7657
0
0
if ($v{'_all'}) {$m =0; delete $v{'_all'}};
0
0
7658
0
0
foreach my $k (keys %v) {$l +=length($k) +length($v{$k}||0)};
0
7659
0
((map { my $n =$_;
0
7660
0
my $v;
7661
0
0
0
if ( defined($s->{-pcmd}->{$_})
0
0
0
0
7662
&& ($s->{-pcmd}->{$_} ne '')
7663
&& ($n =$_ =~/^-/ ? '_' .substr($_,1) : $_)
7664
&& ($n !~/_(?:frmName|cmg|cmh|cmdf|cmdt|backc|ui)/i)
7665
&& !exists($v{$n}) ) {
7666
0
0
$v =ref($s->{-pcmd}->{$_})
7667
? $s->strdata($s->{-pcmd}->{$_})
7668
: $s->{-pcmd}->{$_};
7669
0
$l +=length($n) +length($v);
7670
0
0
0
$v =undef if $m && ($l >$m);
7671
}
7672
0
0
defined($v) ? ($n => $v) : ()
7673
0
} sort keys %{$s->{-pcmd}}), %v)
7674
}
7675
7676
7677
sub urlOpt { # Option URL
7678
0
0
1
$_[0]->urlCat($_[0]->url, $_[0]->urlOptl(@_[1..$#_]))
7679
}
7680
7681
7682
sub psParse { # PerlScript Parse Source
7683
0
0
1
my $s =shift; # (?options, perl script source, base URL)
7684
0
0
my $opt=substr($_[0],0,1) eq '-' ? shift : '-';
7685
0
my $i =$_[0]; # input source
7686
0
my $b =$_[1]; # base URL
7687
0
my $o =''; # output source
7688
0
my ($ol,$or) =('','');
7689
0
my ($ts,$tl,$ta,$tc) =('','','','');
7690
0
0
0
if ($i =~/<(!DOCTYPE|html|head)/i && $`) {
7691
0
$i ='<' .$1 .$'
7692
}
7693
0
0
0
if ($b && $i =~m{(]*>)}i) {
7694
0
my ($i0,$i1) =($` .$1 ,$');
7695
0
$i =$i0 .(' ') .$i1
7696
}
7697
0
0
0
if ($opt =~/e/i && $i =~m{]*>}i) { # '-e'mbeddable html
7698
0
$i =$';
7699
0
0
$i =$` if $i =~m{}i
7700
}
7701
0
while ($i) {
7702
0
0
0
if (not $i =~/<(\%@|\%|script)\s*(language\s*=\s*|)*\s*(PerlScript|Perl|)*\s*(runat\s*=\s*Server|)*[\s>]*/i) {
0
0
0
0
7703
0
$ol =$i; $i ='';
0
7704
0
$ts ='';
7705
}
7706
elsif (($2 && !$3) || (!$3 && $tl eq '1')) {
7707
0
$ol =$` .$&;
7708
0
$i =$';
7709
0
$tl =1;
7710
0
$tc =$ts ='';
7711
}
7712
elsif ($1) {
7713
0
$ol =$`; $i =$';
0
7714
0
0
$ts =uc($1||''); $tl =($2 && $3)||''; $ta=$4||'';
0
0
0
0
7715
0
0
if ($i =~/\s*(\%>|<\/script\s*>)/i) {$tc =$`; $i =$'}
0
0
0
7716
else {$tc =''}
7717
}
7718
else {
7719
0
$ol =$i; $i ='';
0
7720
}
7721
0
$ol =~s/(["\$\@%\\])/\\$1/g;
7722
0
$ol =~s/[\n]/\\n");\n\$_[0]->output("/g;
7723
0
$o .= "\$_[0]->output(\"$ol\\n\");\n";
7724
0
0
0
next if !$ts || !$tc || $ts eq '%@';
0
7725
0
$tc =~s/\<?/
7726
0
$tc =~s/\>?/>/g;
7727
0
$tc =~s/\&?/\&/g;
7728
0
$tc =~s/\"?/"/g;
7729
0
0
if ($ts eq '%') { $o .= "\$_[0]->output($tc);\n" }
0
0
7730
0
elsif ($ts eq 'SCRIPT') { $o .= $tc .";\n"}
7731
}
7732
0
$o;
7733
}
7734
7735
7736
sub psEval { # Evaluate perl script file
7737
0
0
1
my $s =shift; # (?options, filename, ?base URL,...)
7738
0
0
my $o =substr($_[0],0,1) eq '-' ? shift : '-';
7739
0
my $f =shift; # filename
7740
0
my $u =shift; # base URL
7741
0
my $c =undef; # code
7742
0
0
0
if ($f !~/^(\/|\w:[\\\/])/ && !-e $f) {
7743
0
$f =$s->{-path} .'/psp/' .$f;
7744
0
0
$u =$s->{-url} if !$u;
7745
}
7746
0
my $h =$s->hfNew($f); $h->read($c, -s $f); $h->close();
0
0
7747
0
$s->output($s->{-c}->{-httpheader} =$s->cgi->header(
7748
-charset => $s->charset()
7749
# , -expires => 'now'
7750
, uc($ENV{REQUEST_METHOD}||'') ne 'POST' ? (-expires=>'now') : ()
7751
, ref($s->{-httpheader})
7752
0
0
0
? %{$s->{-httpheader}}
0
0
7753
: ()))
7754
if $o !~/e/; # '-e'mbeddable html
7755
0
local $SELF =$s;
7756
0
$c =eval('sub{' .$s->psParse($o, $c, $u, @_) .'}');
7757
0
0
0
return(&{$s->{-die} }("psParse($o, $f)->$@" .$s->{-ermd}) && undef) if !$c;
7758
0
local $_ =$s;
7759
0
eval{&$c($s, $o, $f, @_)};
0
7760
0
0
0
return(&{$s->{-die} }("psEval($o, $f)->$@" .$s->{-ermd}) && undef) if $@;
7761
0
$s
7762
}
7763
7764
7765
sub cgiAction { # cgiRun Action Executor encapsulated
7766
# self, obj name, ?obj meta, ?command, ?data
7767
0
0
0
my ($s, $on, $om, $oc, $od) =@_;
7768
0
0
0
$om =$s->{-form}->{$on}||$s->mdeTable($on) if !$om;
7769
0
0
$oc =$s->{-pcmd} if !$oc;
7770
0
0
$od =$s->{-pdta} if !$od;
7771
0
my $oa =$s->{-pcmd}->{-cmd};
7772
0
my $og =$oc->{-cmg};
7773
0
0
0
if ($oc->{-table} && $oa =~/^rec/) {
0
7774
0
0
0
if ($oa =~/^recList/) {
0
0
7775
0
$s->{-pout} =$s->cgiQuery($on, $om)
7776
}
7777
elsif ($oa =~/^recQBF/ ||$og =~/^rec(?:List|QBF)/) {
7778
0
$s->{-pout} ={%{$od}};
0
7779
}
7780
elsif ($oa =~/^rec(?:Read)/) {
7781
0
$s->rmiTrigger($oc, $od, undef, qw(-recTrim0A -recForm0A));
7782
0
0
if (ref($oc->{-key})) {
7783
0
0
my $m =$s->{-table}->{$oc->{-table}} ||$s->{-form}->{$oc->{-table}};
7784
0
0
0
if ($m && $m->{-key}) {
7785
0
my ($f, %v) =(1);
7786
0
foreach my $e (@{$m->{-key}}) {
0
7787
0
0
if (exists($oc->{-key}->{$e})) {
7788
0
$v{$e} =$oc->{-key}->{$e}
7789
}
7790
else {
7791
0
$f =undef;
7792
}
7793
}
7794
0
0
%{$oc->{-key}} =%v if $f
0
7795
}
7796
}
7797
0
$s->{-pout} =$s->recRead(
7798
0
0
(map {($_=>$oc->{$_})
7799
0
} grep {defined($oc->{$_})
7800
&& $oc->{$_} ne ''
7801
} qw(-table -key -wikn -wikq -form -edit -ui -version))
7802
, ref($om->{-recRead}) eq 'HASH'
7803
0
0
? %{$om->{-recRead}}
7804
: ());
7805
}
7806
else {
7807
0
0
$s->rmiTrigger($oc, $od, undef, qw(-recTrim0A))
7808
if $oa =~/^rec(?:New|Form|Ins|Upd|Del)/;
7809
0
0
$s->rmiTrigger($oc, $od, undef, qw(-recForm0A -recEdt0A))
7810
# uncleaned data may be needed for -recEdt0A
7811
if $oa =~/^rec(?:Form|Ins|Upd|Del)/;
7812
0
$od =$s->cgiDBData($on, $om, $oc, $od);
7813
0
$s->{-pout} =$s->$oa(-data=>$od
7814
, $oa =~/^rec(?:Upd|Del)/ ? (-version =>'+') : ()
7815
0
0
,(map {($_=>$oc->{$_})
7816
0
0
} grep {defined($oc->{$_})
7817
&& $oc->{$_} ne ''
7818
} qw(-table -form -edit -ui -key -proto)));
7819
}
7820
0
0
0
$oc->{-key} =$s->recKey($oc->{-table}, $s->{-pout})
7821
if $oa =~/^rec(?:Read)/
7822
&& !$oc->{-edit};
7823
0
0
0
$oc->{-key} =$s->recWKey($oc->{-table}, $s->{-pout})
7824
if $oa =~/^rec(?:Read|Ins|Upd)/
7825
&& $oc->{-edit};
7826
0
0
delete $oc->{-key}
7827
if $oa =~/^rec(?:New)/;
7828
0
0
0
delete $oc->{-edit}
7829
if $oc->{-edit}
7830
&& $oa =~/^rec(?:Ins|Upd|Del)/;
7831
0
$s->{-pout} =$s->recRead(
7832
0
0
(map {($_=>$oc->{$_})
7833
0
} grep {defined($oc->{$_})
7834
&& $oc->{$_} ne ''
7835
} qw(-table -key -form -ui))
7836
0
0
0
, %{$om->{-recRead}})
7837
if ref($om->{-recRead}) eq 'HASH'
7838
&& $oa =~/^rec(?:Ins|Upd)/;
7839
0
0
0
$s->rmiTrigger($oc, $s->{-pout}, undef, qw(-recForm0A -recEdt0A))
7840
if $oc->{-edit} && ($oa =~/^rec(?:Read|New)/);
7841
0
0
$s->rmiTrigger($oc, $s->{-pout}, undef, qw(-recEdt1A))
7842
if $oa =~/^rec(?:Ins|Upd)/;
7843
0
0
$s->rmiTrigger($oc, $s->{-pout}, undef, qw(-recForm1A))
7844
if $oa =~/^rec(?:New|Form|Ins|Upd|Read)/;
7845
}
7846
elsif ($oa =~/^(recForm|frmHelp)/) {
7847
# nothing needed
7848
}
7849
else {
7850
0
0
return(&{$s->{-die}}($s->lng(0,'cgiRun') .": Action '$oa\@$og' not found" .$s->{-ermd}) && undef)
7851
}
7852
0
$s->{-pout}
7853
}
7854
7855
7856
sub htmlStart { # HTTP/HTML/Form headers
7857
0
0
1
my ($s,$on,$om)=@_; # (object name, object meta)
7858
0
0
0
$on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||'default'
7859
if !$on;
7860
0
0
0
my $cs = $s->{-c}->{-htmlclass}
0
0
0
0
0
0
0
0
0
0
7861
= $s->{-pcmd}->{-xml}
7862
? undef
7863
: ref($s->{-htmlstart}) && $s->{-htmlstart}->{-class}
7864
? $s->{-htmlstart}->{-class}
7865
: $s->cgiHook('recOp')
7866
? 'Form' .($on ? ' ' .$on : '')
7867
: $s->cgiHook('recFormQ')
7868
? 'Form' .($on ? ' ' .$on : '') .' QBF' .($on ? ' ' .$on .'__QBF' : '')
7869
: $s->cgiHook('frmHelp')
7870
? 'Form Help' .($on ? ' ' .$on .'__Help' : '')
7871
: 'Form' .($on ? ' ' .$on : '') .' List' .($on ? ' ' .$on .'__List' : '');
7872
0
my $r =join(""
7873
, $s->{-c}->{-httpheader}
7874
? ()
7875
: do{$s->{-c}->{-httpheader} =$s->cgi->header(
7876
-charset => $s->charset()
7877
# , -expires => 'now'
7878
, uc($ENV{REQUEST_METHOD}||'') ne 'POST' ? (-expires=>'now') : ()
7879
, ref($s->{-httpheader})
7880
0
0
0
? %{$s->{-httpheader}}
0
0
7881
: ()
7882
, $s->{-pcmd}->{-xml}
7883
? (-type => 'text/xml')
7884
: ()
7885
)}
7886
, $s->{-c}->{-htmlstart} =
7887
$s->{-pcmd}->{-xml}
7888
? (ref($s->{-xmlstart})
7889
? $s->xmlsTag($s->{-xmlstart})
7890
: ($s->{-xmlstart}
7891
||('
7892
.(!$s->{-charset}
7893
? ''
7894
: ' encoding="' .$s->charset() .'"')
7895
.' ?>'))
7896
.($s->{-pcmd}->{-style}
7897
? '{-pcmd}->{-style} .'" type="text/css" ?>'
7898
: '')
7899
)
7900
: $s->cgi->start_html(
7901
-head => ' '
7902
.($s->{-pcmd}->{-refresh}
7903
? ' '
7904
: '')
7905
,-lang => $s->lang(0,'-lang')
7906
,-encoding => $s->charset()
7907
,-style => {-code=>''
7908
.".Body {font-size: 70%; font-family: Verdana, Helvetica, Arial, sans-serif; }\n"
7909
.".Input {font-size: 100%; font-family: Verdana, Helvetica, Arial, sans-serif; }\n"
7910
.".Form {margin-top:0px; }\n"
7911
."td.Form {border-style: none; border-width: 0px; padding: 0px;}\n"
7912
."th.Form {border-style: none; border-width: 0px; padding: 0px;}\n"
7913
."table.ListTable {border-collapse: collapse; }\n"
7914
."th.ListTable {border-style: inset; border-color: buttonface; border-width: 0px; border-bottom-width: 1px; }\n"
7915
."td.ListTable {border-style: inset; border-color: buttonface; border-width: 0px; border-bottom-width: 1px; padding: 0px; padding-left: 2px; padding-right: 1px; padding-top: 2px;}\n"
7916
.".ListTableFocus {background-color: buttonface;}\n"
7917
#.".MenuArea {background-color: navy; color: white;}\n"
7918
.".MenuButton {background-color: buttonface; color: black; text-decoration:none; font-size: 7pt}\n"
7919
.".MenuInput {font-size: 8pt}\n"
7920
.".htmlMQHsel {text-decoration: none; font-weight: bolder; border-style: inset;}\n"
7921
}
7922
,-title =>
7923
0
0
(do{ my $v =($s->{-pcmd} && $s->{-pcmd}->{-cmd} ||'') eq 'frmHelp'
0
7924
? $s->lng(0,'frmHelp')
7925
0
0
0
: (eval{$om && $s->lnglbl($om)});
7926
0
0
$v ? $v .' - ' : ''})
7927
.($s->{-title} ||$s->cgi->server_name())
7928
,-class => "Body $cs"
7929
,$s->{-pcmd}->{-frame}
7930
? (-target=>$s->{-pcmd}->{-frame})
7931
: $s->cgiHook('recFormRWQ') && $s->{-pcmd}->{-edit}
7932
? (-target=>'_blank')
7933
: (-target=>'_self')
7934
,ref($s->{-htmlstart})
7935
0
0
0
? %{$s->{-htmlstart}}
0
7936
: ()
7937
,$s->{-pcmd}->{-style}
7938
? (-style=>{'src'=>$s->{-pcmd}->{-style}})
7939
: ())
7940
, "\n"
7941
, $s->{-pcmd}->{-xml}
7942
? $s->xmlsTag($s->{-pcmd}->{-form}||'default'
7943
0
, (map { defined($s->{-pcmd}->{$_}) && ($s->{-pcmd}->{$_} ne '')
7944
? ((substr($_,0,1) eq '-' ? substr($_,1) : $_)
7945
,$s->{-pcmd}->{$_})
7946
: ()
7947
0
0
0
} sort keys %{$s->{-pcmd}})
0
0
0
0
0
0
0
0
0
0
0
0
0
7948
, 'xmlns'=>$s->url
7949
, '0')
7950
: $s->cgi->start_multipart_form(-method=>($s->{-pcmd}->{-refresh} ? 'get' : 'post')
7951
,-class => "$cs"
7952
,-action=> $s->url
7953
,-target=> '_self'
7954
,-name=>'DBIx_Web'
7955
# !!! 'DBIx_Web.' or 'forms[0].' syntax inflexible
7956
)
7957
) ."\n";
7958
0
0
eval{warningsToBrowser(1)} if *warningsToBrowser{CODE};
0
7959
0
$r;
7960
}
7961
7962
7963
sub htmlEnd { # End of HTML/HTTP output
7964
0
0
1
my ($s) =@_;
7965
0
0
if ($s->{-pcmd}->{-xml}) {
7966
0
0
return("\n" .$s->xmlTagEscape($s->{-pcmd}->{-form}||'default') .">\n")
7967
}
7968
else {
7969
return($s->cgi->endform()
7970
,"\n"
7971
,$s->htmlOnLoadW(
7972
(!$s->{-c}->{-jswload}
7973
0
0
0
|| !(grep {($_=~/\.target/) && ($_=~/'BASE'/)} @{$s->{-c}->{-jswload}})
0
0
0
0
7974
? "{var e=document.getElementsByTagName('BASE'); if(e && e[0] && (e[0].target=='_self')){e[0].target=(self.name=='BOTTOM' ? 'TOP1' : self.name=='TOP' ? 'BOTTOM'"
7975
.($s->{-pcmd}->{-frame}
7976
? " : self.name=='" .$s->{-pcmd}->{-frame} ."' ? 'TOP1'"
7977
." : self.name!='" .$s->{-pcmd}->{-frame} ."' ? '" .$s->{-pcmd}->{-frame} ."'"
7978
: '')
7979
." : e[0].target)}}"
7980
: ())
7981
,($s->{-pcmd}->{-search} && $s->{-c}->{-search}
7982
? ("{window.document.open('"
7983
.($s->{-c}->{-search} =~/^\?/
7984
? $s->url() .$s->{-c}->{-search}
7985
: $s->{-c}->{-search}) ."','_search','',true)}")
7986
: ())
7987
)
7988
,$s->cgi->end_html())
7989
}
7990
}
7991
7992
7993
sub htmlOnLoad {# OnLoad event JavaScript store
7994
0
0
0
0
$_[0]->{-c}->{-jswload} =[] if !$_[0]->{-c}->{-jswload};
7995
0
push @{$_[0]->{-c}->{-jswload}}, @_[1..$#_];
0
7996
0
''
7997
}
7998
7999
8000
sub htmlOnLoadW {# OnLoad event JavaScript write
8001
0
0
0
0
$_[0]->htmlOnLoad(@_[1..$#_]) if $#_;
8002
0
0
return() if !$_[0]->{-c}->{-jswload};
8003
0
my $v ="\n";
8006
0
delete $_[0]->{-c}->{-jswload};
8007
0
$v
8008
}
8009
8010
8011
sub htmlHidden {# Common hidden fields
8012
0
0
1
my ($s, $on, $om) =@_;
8013
0
0
0
return('') if $s->{-pcmd}->{-xml} ||$s->{-pcmd}->{-print};
8014
0
0
0
$on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||''
8015
if !$on;
8016
0
0
0
join("\n"
0
0
8017
,' '
8018
,' '
8019
,' '
8020
0
0
,(map { !defined($s->{-pcmd}->{"-$_"})
8021
|| (($s->{-pcmd}->{"-$_"} eq '')
8022
&& ($_ !~/^(?:qkey|qwhere|qurole)$/))
8023
? ()
8024
: ('
8025
.$s->htmlEscape(!defined($s->{-pcmd}->{"-$_"})
8026
? ''
8027
: ref($s->{-pcmd}->{"-$_"})
8028
? strdata($s, $s->{-pcmd}->{"-$_"})
8029
: $s->{-pcmd}->{"-$_"})
8030
.'" />')
8031
} qw(edit backc key style frame)
8032
,($s->{-pcmd}->{-cmg} ne 'recQBF'
8033
? qw(qkey qjoin qwhere qurole quname qversion qorder qkeyord qlimit qdisplay)
8034
: qw(qlist))
8035
)
8036
) ."\n"
8037
}
8038
8039
8040
sub htmlMenu { # Screen menu bar
8041
0
0
1
my ($s,$on,$om) =@_;
8042
0
0
0
return('') if $s->{-pcmd}->{-xml} ||$s->{-pcmd}->{-print};
8043
0
0
0
$on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||''
8044
if !$on;
8045
0
0
0
$om =$on && $s->{-form}->{$on}||$s->mdeTable($on) if !$om;
8046
0
0
my $ot=$om && $om->{-table} && $s->mdeTable($om->{-table}) || $om;
8047
0
my $c =$s->{-pcmd};
8048
0
0
my $a =$c->{-cmd} ||'';
8049
0
0
my $g =$c->{-cmg} ||'';
8050
0
my $e =$c->{-edit};
8051
0
my $d =$s->{-pdta};
8052
0
0
my $n =$d->{-new} ||($c->{-cmg} eq 'recNew');
8053
0
0
my $cs=join(' '
8054
,$s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) : ()
8055
,'MenuArea');
8056
0
0
local $c->{-cmdt} =$ot || $om; # table metadata
8057
0
0
local $c->{-cmdf} =$om || $ot; # form metadata
8058
0
my @r =();
8059
0
0
if ($s->{-logo}) { # Logotype
0
8060
0
push @r, htmlMB($s, 'logo');
8061
}
8062
elsif ($s->{-icons}) { # Home
8063
0
0
push @r, htmlMB($s, $s->{-c}->{-search} ? 'schpane' : 'home');
8064
}
8065
0
if (1) { # 'back' js button
8066
0
0
0
push @r, htmlMB($s, 'back'
0
0
8067
, $g ne 'recList'
8068
? $s->urlCmd('',-form=>$on, -cmd=>'recList', $c->{-frame} ? (-frame=>$c->{-frame}) : ())
8069
: $s->urlCmd('',$c->{-frame} ? (-frame=>$c->{-frame}) : ())
8070
, ($c->{-backc}||1));
8071
}
8072
0
0
0
if ($s->uguest()
8073
&& $s->{-login}) { # Login
8074
0
push @r,htmlMB($s, 'login', $s->urlAuth());
8075
}
8076
0
0
if ($g eq 'recList') { # View menu items
0
0
0
8077
0
local @{$s}{-menuchs, -menuchs1} =@{$s}{-menuchs, -menuchs1};
0
0
8078
0
0
$s->htmlMChs()
8079
if !$s->{-menuchs};
8080
# push @r, htmlMB($s, 'recForm');
8081
0
0
0
push @r, htmlML($s, 'frmName', $s->{-menuchs}
0
8082
, !$c->{-frame} || ($c->{-frame} =~/^(?:TOP|BOTTOM)$/)
8083
? '-frame=set'
8084
: ()
8085
) if $s->{-menuchs};
8086
0
push @r, htmlML($s, 'frmLso'
8087
, ref($om->{-frmLso}) eq 'CODE'
8088
0
0
0
? &{$om->{-frmLso}}($s, $on, $om, $c, exists($c->{-frmLso}) ? $c->{-frmLso} ||'' : ())
0
0
8089
: $om->{-frmLso}
8090
) if $om->{-frmLso};
8091
0
0
push @r, htmlMB($s, htmlField($s, '_qftext', lng($s,1,'-qftext'), {-asize=>5, -class=>'Input ' .$cs .' MenuInput'}, $s->{-pcmd}->{-qftext}))
8092
if $s->{-menuchs};
8093
0
0
push @r, htmlML($s, 'frmName1', $s->{-menuchs1})if $s->{-menuchs1};
8094
0
local $c->{-frame} =undef;
8095
0
0
push @r, htmlMB($s, 'frmCall', ['', $s->urlOptl(-cmd=>'frmCall')])
8096
if $s->{-menuchs};
8097
0
push @r, htmlMB($s, 'recXML', ['', $s->urlOptl(-cmd=>'frmCall',-xml=>1)]);
8098
0
push @r, htmlMB($s, 'recQBF');
8099
0
0
0
if ($s->uguest) {}
0
0
0
0
0
0
0
0
0
0
0
8100
elsif ($om->{-recNew} || $om->{-recForm}
8101
0
0
0
|| ($on && (grep {( !ref($_)
8102
? $_
8103
: ref($_) eq 'HASH'
8104
? $_->{-val}
8105
: $_->[0]) =~/^\Q$on\E\+/
8106
0
} @{$s->{-menuchs1} ||$s->{-menuchs} ||[]})) ) {
8107
0
push @r, htmlMB($s, 'recNew')
8108
}
8109
elsif ( $om->{-table}
8110
&& !$om->{-field}
8111
&& $s->{-table}->{$om->{-table}}
8112
&& !$s->{-table}->{$om->{-table}}->{-ixcnd}
8113
&& do{my $on =$om->{-table};
8114
0
0
0
grep {( !ref($_)
0
0
0
8115
? $_
8116
: ref($_) eq 'HASH'
8117
? $_->{-val}
8118
: $_->[0]) =~/^\Q$on\E\+/
8119
0
} @{$s->{-menuchs1} ||$s->{-menuchs} ||[]}} ){
8120
0
push @r, htmlMB($s, 'recNew')
8121
}
8122
}
8123
elsif ($g eq 'recQBF') { # QBF menu items
8124
0
push @r, htmlMB($s, 'recForm', '');
8125
0
push @r, htmlMB($s, 'recQBFReset' );
8126
0
push @r, htmlMB($s, 'recList', '');
8127
0
push @r, htmlMB($s, 'recXML', '');
8128
}
8129
elsif ($g eq 'recDel') { # Deleted record menu items
8130
}
8131
elsif ($s->cgiHook('recOp')) { # Record menu items
8132
0
0
my $ea =(!$s->{-rac} ||$s->{-pout}->{-editable}) &&!$s->uguest
8133
&& ((ref($s->{-pout}->{-editable}) && $s->{-pout}->{-editable}->{-fr}) ||1);
8134
0
my @rk =('','_form'=>$_[0]->{-pcmd}->{-form}, '_key'=>strdata($_[0], $_[0]->{-pcmd}->{-key}));
8135
0
my $ll =$s->lnghash();
8136
0
0
0
local $ll->{'recIns'} = $e && $n
8137
? [$ll->{'recUpd'}->[0], $ll->{'recIns'}->[1]]
8138
: $ll->{'recIns'};
8139
0
0
0
local $IMG->{'recIns'}= $e && $n
8140
? $IMG->{'recUpd'}
8141
: $IMG->{'recIns'};
8142
0
0
push @r, htmlMB($s, 'recRead', [@rk, '_cmd'=>'recRead'])
8143
if !$n;
8144
0
0
0
push @r, htmlMB($s, 'recPrint', [@rk, '_cmd'=>'recRead', '_print'=>1])
8145
if !$n && !$e;
8146
0
0
0
push @r, htmlMB($s, 'recXML', [@rk, '_cmd'=>'recRead', '_xml'=>1])
8147
if !$n && !$e;
8148
0
0
0
push @r, htmlMB($s, 'recHist', [@rk, '_cmd'=>'recRead', '_hist'=>1])
0
0
8149
if !$n && !$e
8150
&& ($ot->{-rvcActPtr} ||$s->{-rvcActPtr});
8151
0
0
0
push @r, htmlMB($s, 'recEdit', [@rk, '_cmd'=>'recEdit'])
0
8152
if !$n && !$e && $ea;
8153
0
0
push @r, htmlMB($s, 'recForm', '') if $e;
8154
0
0
0
push @r, htmlMB($s, 'recUpd', '') if $e && !$n;
8155
0
0
0
push @r, htmlMB($s, 'recNew' # ,undef)
0
8156
,['','_cmd'=>'recNew','_form'=>$_[0]->{-pcmd}->{-form}
8157
, '_proto'=>strdata($_[0], $_[0]->{-pcmd}->{-key})])
8158
if !$n && !$e && !$s->uguest;
8159
0
0
push @r, htmlMB($s, 'recIns', '') if $e;
8160
0
0
0
push @r, htmlMB($s, 'recDel', '') if !$n && $ea
0
0
8161
&& (!ref($ea) ||!$ea->{-recDel});
8162
}
8163
0
0
if ($a ne 'frmHelp') { # Help button
8164
0
push @r, htmlMB($s, 'frmHelp');
8165
# push @r, htmlMB($s, 'frmHelp', ['','_cmd'=>'frmHelp','_form'=>$_[0]->{-pcmd}->{-form}]);
8166
8167
}
8168
0
delete $c->{-htmlMQH};
8169
0
my $mi ='[\'' .htmlEscape($s,lng($s, 0, $c->{-cmd}))
8170
.'\'@\'' .htmlEscape($s,lng($s, 0, $c->{-cmg}))
8171
.'\', ' .htmlEscape($s, $s->user()) .']';
8172
0
0
my $mh =htmlEscape($s
8173
,($a eq 'frmHelp'
8174
? $s->lng(0, 'frmHelp')
8175
: $s->lngcmt($om, $ot))
8176
|| (($s->{-title} ||$s->cgi->server_name() ||'') .' - ' .($c->{-form} ||'')));
8177
0
my $mc =$g ne 'recList'
8178
? ''
8179
: join("; "
8180
, grep {$_
8181
}
8182
(defined($c->{-qkey})
8183
? $c->{-qkey}
8184
: ($om->{-query} && $om->{-query}->{-qkey}))
8185
0
0
0
? do { my $kq =$c->{-qkey} ||($om->{-query} && $om->{-query}->{-qkey});
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
8186
0
0
my $ko =$c->{-qkeyord}
8187
|| ($c->{-qorder} && (substr($c->{-qorder},0,1) eq '-') && $c->{-qorder})
8188
|| '-aeq';
8189
0
0
$ko ={'eq'=>'=','ge'=>'>=','gt'=>'>','le'=>'<=','lt'=>'<'}->{substr($ko,2)}||'=';
8190
0
$s->htmlEscape(
8191
0
join(', ', map { "$_ $ko "
8192
.dsdQuot($s," $ko ",$kq->{$_})
8193
} sort keys %$kq))
8194
}
8195
: ()
8196
, ($c->{-qkeyord} ? htmlEscape($s, lng($s, 0, '-qkeyord') .' ' .lng($s, 0, $c->{-qkeyord} =~/^-*[db]/ ? 'desc' : 'asc')) : '')
8197
, (!$c->{-qwhere}
8198
? ''
8199
: $c->{-qwhere} =~/^(?:\[\[\]\]|\/\*\*\/)+(.*)/
8200
? htmlEscape($s, $1)
8201
: htmlEscape($s, $c->{-qwhere}))
8202
, ($c->{-qjoin} ? htmlEscape($s, ($c->{-qjoin} =~/^\s*(?:CROSS|JOIN|INNER|STRAIGHT_JOIN|LEFT|NATURAL|RIGHT|OUTER)\b/i ? '' : (lng($s, 0, '-qjoin') .' ')) .$c->{-qjoin}) : '')
8203
, ($c->{-qurole} ? htmlEscape($s, lng($s, 0, '-qurole') .' ' .$c->{-qurole} .' /*' .$s->mddUrole($om, $c->{-qurole}) .'*/') : '')
8204
, ($c->{-quname} ? htmlEscape($s, lng($s, 0, '-quname') .' ' .$c->{-quname}) : '')
8205
, ($c->{-qftext} ? htmlEscape($s, lng($s, 0, '-qftext') .' ' .$c->{-qftext}) : '')
8206
, ($c->{-qversion}? htmlEscape($s, lng($s, 0, '-qversion') .' ' .$c->{-qversion}) : '')
8207
, ($c->{-qorder} ? htmlEscape($s, lng($s, 0, '-qorder') .' ' .($c->{-qorder} !~/^-/ ? $c->{-qorder} : lng($s, 0, $c->{-qorder} =~/^-[db]/ ? 'desc' : 'asc'))) : '')
8208
);
8209
0
0
$mc = ($g eq 'recList') && ($om->{-frmLso1C} ||($ot->{-frmLso1C} && !exists($om->{-frmLso1C})))
8210
0
0
0
? &{$om->{-frmLso1C}||$ot->{-frmLso1C}}($s,$on,$om,$c,$mc)
8211
: $mc;
8212
8213
($s->{-banner}
8214
0
0
? (do{ my $v =ref($s->{-banner}) ? &{$s->{-banner}}($s,$on,$om) : $s->{-banner};
0
0
0
0
0
0
0
0
8215
0
0
$v
8216
? "\n$v
"
8217
: ''
8218
})
8219
: '')
8220
.(!$s->{-icons}
8221
? "\n" .join("\n", @r, $mi, ' ', $mh, ' ', $mc ? ($mc, ' ') : ()) ."
\n\n"
8222
: ("\n\n"
8223
# cellspacing=\"1px\"
8224
# style=\"position: absolute; top: 0; left: 0;\" # scrolled up
8225
#
8226
# scrollHeight
8227
.join("\n", @r)
8228
."\n" .'
8229
. $mi .' '
8230
."\n"
8231
."
\n
\n"
8240
.(0 && ($s->user() =~/diags/i) ? $s->diags('-html') : '')
8241
.(!$c->{-refresh}
8242
? $s->htmlOnLoad('{var w=window.document.getElementsByTagName(\'table\')[' .($e ? 1 : 0) .']; if(w){w.focus()}}')
8243
: '')
8244
.(0 # scrollTop==0
8245
? '' ."\n"
8246
: '')
8247
."\n"))
8248
}
8249
8250
8251
sub htmlMB { # CGI menu bar button
8252
# self, command, url, back|
8253
0
0
0
0
my $cs =($_[0]->{-c}->{-htmlclass} ? $_[0]->htmlEscape($_[0]->{-c}->{-htmlclass}) .' ' : '')
8254
.'MenuArea MenuButton';
8255
0
my $td0='
8256
0
0
0
my $tdb=($ENV{HTTP_USER_AGENT}||'') =~/MSIE/
8257
? ' onmousedown="if(window.event.button==1){this.style.borderStyle="inset"}" onmouseup="this.style.borderStyle="outset"" onmouseout="this.style.borderStyle="outset"" onmousein="this.style.cursor="hand""'
8258
: ' onmousedown="if(event.which==1){this.style.borderStyle="inset"}" onmouseup="this.style.borderStyle="outset"" onmouseout="this.style.borderStyle="outset""';
8259
0
0
if (!$_[0]->{-icons}) {
0
0
0
0
0
0
8260
0
0
if ($_[1] =~/^) {
0
0
0
8261
0
$_[1]
8262
}
8263
elsif ($_[1] eq 'logo') {
8264
0
ref($_[0]->{-logo}) eq 'CODE'
8265
0
0
? &{$_[0]->{-logo}}(@_)
8266
: $_[0]->{-logo}
8267
}
8268
elsif ($_[1] eq 'login') {
8269
0
$_[1]
8270
}
8271
elsif ($_[1] eq 'back') {
8272
0
0
0
'
8273
.' value="' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'" '
8274
.' onclick="{'
8275
.(!$_[3] ||$_[3] <2
8276
? 'window.history.back()'
8277
: 'window.history.go(-' .($_[3]-1) .'); window.history.back()')
8278
.'; return(false)}" '
8279
.' title="' .htmlEscape($_[0],lng($_[0], 1, $_[1])) .'" />'
8280
}
8281
else {
8282
0
'
8283
.' value="' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'" '
8284
.' title="' .htmlEscape($_[0],lng($_[0], 1, $_[1])) .'" />'
8285
}
8286
}
8287
elsif ($_[1] =~/^) {
8288
0
$td0 .">\n" .$_[1] ."\n "
8289
}
8290
elsif ($_[1] eq 'logo') {
8291
0
$_[0]->{-logo}
8292
? $td0 .">\n"
8293
.( ref($_[0]->{-logo}) eq 'CODE'
8294
0
0
? &{$_[0]->{-logo}}(@_)
0
8295
: $_[0]->{-logo}) ."\n "
8296
: htmlMB($_[0],'home')
8297
}
8298
elsif ($_[1] eq 'login') {
8299
0
my $jc =' onclick="{window.location.replace("'
8300
.htmlEscape($_[0], $_[2])
8301
.'"); return(false)}" ';
8302
0
my $tl =htmlEscape($_[0], lng($_[0], 1, 'login'));
8303
0
0
$td0 .' title="' .$tl .'"'
0
8304
.($tdb ? $tdb .$jc : '') .">\n"
8305
.'
8306
.' title="' .$tl .'" '
8307
.' class="' .$cs .'" target="_self" '
8308
.($tdb ? '' : $jc)
8309
.' >
8310
.'" border=0 align="bottom" height="22" class="' .$cs .'" />'
8311
.htmlEscape($_[0], lng($_[0], 0, 'login')) ."\n "
8312
}
8313
elsif ($_[1] eq 'schpane') {
8314
0
my $pu =$_[0]->{-c}->{-search};
8315
0
my $fr =$pu=~/\b_frame=RIGHT\b/;
8316
0
0
my $su =$fr ? $_[0]->urlOpt(-search=>1) : $_[0]->{-c}->{-search};
8317
0
my $tl =htmlEscape($_[0], lng($_[0], 1, 'schpane'));
8318
0
0
$td0
0
8319
.$tdb
8320
.' title="' .$tl .'"'
8321
.'>
8322
.' title="' .$tl .'"'
8323
.' class="' .$cs .'"'
8324
.' target="' .($fr ? '_top' : '_search') .'">
8325
.$_[0]->{-icons} .'/' .($fr ? $IMG->{'schframe'} : $IMG->{'schpane'}) .'" border=0 align="bottom" class="' .$cs .'" '
8326
.' />' ."\n "
8327
}
8328
elsif ($_[1] eq 'home') {
8329
0
0
my $jc =' onclick="{window.document.open(\''
8330
.$_[0]->urlCat($_[0]->url,$_[0]->{-pcmd}->{-frame} ? ('_frame'=>$_[0]->{-pcmd}->{-frame}) : ())
8331
."','_self','',false); return(false)}\" ";
8332
0
my $tl =htmlEscape($_[0], lng($_[0], 1, 'home'));
8333
0
0
0
$td0
0
8334
.($tdb ? $tdb .$jc : '')
8335
.' title="' .$tl .'"'
8336
.'>
8337
.($tdb ? '' : $jc)
8338
.' title="' .$tl .'"'
8339
.' class="' .$cs .'" target="_self">
8340
.' />' ."\n "
8341
}
8342
elsif ($_[1] eq 'back') {
8343
0
0
0
my $jc =' onclick="{'
0
0
8344
.(!$_[3] ||$_[3] <2
8345
? 'window.history.back(); '
8346
: ($ENV{HTTP_USER_AGENT}||'') =~/MSIE/
8347
?('window.history.go(-' .($_[3]-1)
8348
.'); window.history.back(); ')
8349
: 1 # !!! Non MSIE backwarding omission
8350
?("window.document.open('" .htmlEscape($_[0],$_[2]) ."','_self','',false); ")
8351
:('window.history.back();' x $_[3])
8352
)
8353
.'return(false)}" ';
8354
0
my $jo =$jc =~/window\.document\.open/i;
8355
0
0
0
my $tl =htmlEscape($_[0], (!$jo ? '<-' .($_[3]||1) .'- ' : '') .lng($_[0], 1, 'back'));
8356
0
0
0
$td0
0
0
8357
.' title="' .$tl .'"'
8358
.($tdb ? $tdb .$jc : '') .">\n"
8359
.'
8360
.($tdb ? '' : $jc)
8361
.' title="' .$tl .'"'
8362
.' class="' .$cs .'" target="_self">
8363
.' />' ."\n "
8364
}
8365
else {
8366
0
my $hl =defined($_[2]) && !$_[2]
8367
? undef
8368
: urlCat($_[0], !$_[2]
8369
? ('', '_form'=>$_[0]->{-pcmd}->{-form},'_cmd'=>$_[1])
8370
0
0
0
: ref($_[2]) ? @{$_[2]} : $_[2]);
0
0
8371
0
my $jc =' onclick="{'
8372
.(!$hl
8373
? ''
8374
: $_[1] =~/^(?:recRead|recPrint|recXML|recHist|recEdit|recNew|frmHelp)$/
8375
? "if((self.name=='BOTTOM') || (self.name=='TOP') ||document.getElementsByName('_frame').length){window.document.open('"
8376
.(($_[1] =~/^(?:recNew)$/ && ($hl =~/_proto=/))
8377
0
0
0
? (do {my $v=$hl; $v =~s/([?&;])_proto=/${1}_key=/; $v})
0
0
0
0
8378
: $hl)
8379
."','_blank','',false); return(false)}\n"
8380
: '')
8381
.'window.document.DBIx_Web._cmd.value="' .$_[1] .'"; window.document.DBIx_Web.submit(); return(false)}" ';
8382
0
my $tl =htmlEscape($_[0],lng($_[0], 1, $_[1]));
8383
0
0
0
$td0 .' title="' .$tl .'"'
0
0
0
8384
.($tdb ? $tdb .$jc : '') .">\n"
8385
.'
8386
.' src="' .$_[0]->{-icons} .'/' .($IMG->{$_[1]}||'none') .'" '
8387
.' align="bottom" title="' .$tl .'" class="' .$cs .'" style="cursor: default;"/>'
8388
.(!$hl
8389
?('
8390
.' title="' .$tl .'">' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'')
8391
.($tdb ? '' : $jc)
8392
:('
8393
.($tdb ? '' : $jc)
8394
.' title="' .$tl .'">'
8395
.htmlEscape($_[0],lng($_[0], 0, $_[1]))
8396
.''))
8397
."\n "
8398
}
8399
}
8400
8401
8402
sub htmlML { # CGI menu bar list
8403
1
1
65355
use locale; # (self, name, values, ? add values)
1
2
1
11
8404
0
0
0
0
my $cs =join(' '
8405
,'Input'
8406
,$_[0]->{-c}->{-htmlclass} ? $_[0]->htmlEscape($_[0]->{-c}->{-htmlclass}) : ()
8407
,'MenuArea');
8408
0
0
0
my $i = $_[1] eq 'frmName'
0
0
0
0
8409
? $_[0]->cgi->param('_' .$_[1])
8410
||$_[0]->{-pcmd}->{'-' .$_[1]}
8411
||$_[0]->{-pcmd}->{-form} ||''
8412
: $_[1] eq 'frmLso'
8413
? (($_[0]->{-pcmd}->{'-' .$_[1]} ||'') eq '-all'
8414
? ''
8415
: ($_[0]->{-pcmd}->{'-' .$_[1]} ||''))
8416
: '';
8417
0
my $li =$_[3];
8418
0
my $f1 =undef;
8419
0
($_[0]->{-icons}
8420
? '
.$_[0]->htmlEscape(lng($_[0], 1, $_[1]))
8422
.'" style="border-width: thin; border-style: outset;" >'
8423
: '')
8424
0
.do{$cs .=' MenuInput'; ''}
8425
.'
8426
.'" class="' .$cs .'" onchange="{'
8427
.( $_[1] eq 'frmLso'
8428
? 'if (_frmLso.value=="recQBF") {window.document.DBIx_Web._cmd.value=_frmLso.value; _frmLso.value="' .$_[0]->htmlEscape($i) .'"; window.document.DBIx_Web.submit(); return(true);} else {window.document.DBIx_Web._cmd.value="frmCall"; window.document.DBIx_Web.submit(); return(false);}}">'
8429
: 1 && ($_[1] eq 'frmName1')
8430
? ("var v=_frmName1.value; _frmName1.value=''; document.body.style.cursor=_frmName1.style.cursor='wait'; window.document.open('" .$_[0]->url ."?_cmd=frmCall;_frmName1=' +encodeURIComponent(v)"
8431
.",self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length ? '_blank' : '_self'"
8432
.", '', false); document.body.style.cursor=_frmName1.style.cursor='auto'; return(true);}\">")
8433
: 1 && ($_[1] eq 'frmName')
8434
? ('window.document.DBIx_Web._cmd.value="frmCall"; '
8435
.($_[0]->{-menuchs1} && ($_[1] eq 'frmName')
8436
? '_frmName1.value=""; '
8437
: '')
8438
."if((_frmName.value=='-frame=set') && (self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length)){window.document.DBIx_Web.target='_parent'; _frmName.value=_form.value ? _form.value : ''; if (document.getElementsByName('_frame').length) {_frame.value=''}}"
8439
."else if(_frmName.value.match(/[+^]\$/) && (self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length)){var v=_frmName.value; _frmName.value=_form.value ? _form.value : ''; window.document.open('" .$_[0]->url ."?_cmd=frmCall;_frmName=' +encodeURIComponent(v), '_blank', '', false); return(true)}"
8440
#."else {var v=_frmName.value; document.body.style.cursor=_frmName.style.cursor='wait'; _frmName.value=_form.value ? _form.value : ''; window.document.open('" .$_[0]->url ."?_cmd=frmCall;_frmName=' +encodeURIComponent(v) +(document.getElementsByName('_frame').length ? ';_frame=' +_frame.value : '') +((v=='-frame=set') && _form.value ? ';_form=' +_form.value : ''), '_self', '', false); document.body.style.cursor=_frmName.style.cursor='auto'; return(true)};"
8441
."else {var v=_frmName.value; _frmName.value=_form.value ? _form.value : ''; _frmName.disabled=true; window.document.open('" .$_[0]->url ."?_cmd=frmCall;_frmName=' +encodeURIComponent(v) +(document.getElementsByName('_frame').length ? ';_frame=' +_frame.value : '') +((v=='-frame=set') && _form.value ? ';_form=' +_form.value : ''), '_self', '', false); _frmName.disabled=false; return(true)};"
8442
.'window.document.DBIx_Web.submit(); return(false);}">')
8443
: 'return(true)}')
8444
."\n\t"
8445
.join("\n\t"
8446
, map { my ($n, $l) =!ref($_)
8447
? ($_ , $_[1] !~/^frmName/
8448
? ucfirst($_[0]->lng(0, $_))
8449
: !$_
8450
? '--- ' .$_[0]->lng(0, 'frmCallNew') .' ---'
8451
0
0
0
: (do { my($n, $x) =/([+&.^]*)$/ ? ($`, $1) : ($_,'');
0
0
0
0
0
0
0
8452
0
0
my $o =$_[0]->{-form}->{$n} ||$_[0]->{-table}->{$n};
8453
0
0
$o =$_[0]->lngslot($o,'-lbl') if $o;
8454
0
0
$o =&$o($_[0]) if ref($o);
8455
0
0
0
($o || ucfirst($_[0]->lng(0, $n)))
0
8456
.(!$f1 && $x && (substr($x,0,1) eq '+') ? " $x$x" : '')
8457
}))
8458
: ref($_) eq 'ARRAY'
8459
? ($_->[0]
8460
, (ref($_->[1]) ? $_[0]->lnglbl($_->[1]) : $_->[1])
8461
|| ucfirst($_[0]->lng(0, $_->[0])))
8462
: ($_->{-val}||$_->{-lbl}, $_[0]->lnglbl($_) ||ucfirst($_[0]->lng(0, $_->{-val})));
8463
0
0
0
$f1 =1 if (!$_ || !$n) && ($_[1] =~/^frmName/);
0
8464
0
'
8465
.($i && ($n eq $i)
8466
0
0
0
? do{$i =''; 'selected'}
0
0
0
8467
: '')
8468
.(($n eq '') || ($l =~/^[-]+/)
8469
?(' class="' .$cs .' MenuInputSeparator"')
8470
:(' class="' .$cs .'"'))
8471
.' value="'
8472
.htmlEscape($_[0], $n)
8473
.'">'
8474
.htmlEscape($_[0], $l)
8475
.''
8476
} $li
8477
0
0
0
? (map {if (!(!ref($_) ? $_ : ref($_) eq 'ARRAY' ? $_->[0] : $_) && $li) {
0
0
0
8478
0
my $v =$li;
8479
0
$li =undef;
8480
0
0
(ref($v) eq 'ARRAY' ? @$v : $v, $_)
8481
}
8482
else {
8483
0
($_)
8484
0
}} @{$_[2]})
8485
0
: @{$_[2]}
8486
0
0
0
, !$li ? () : ref($li) eq 'ARRAY' ? @{$li} : ($li)
0
0
0
0
0
0
0
0
0
0
0
0
0
8487
)
8488
.($i eq ''
8489
? ''
8490
:('
8491
.(($i eq '') || ($i =~/^[-]+/)
8492
? ' MenuSeparator'
8493
: '')
8494
.'" value="'
8495
.htmlEscape($_[0], $i) .'">'
8496
.htmlEscape($_[0]
8497
, $_[1] =~/^frmName/
8498
? ($_[0]->{-form} && $_[0]->{-form}->{$i} && $_[0]->lnglbl($_[0]->{-form}->{$i}))
8499
||($_[0]->{-table} && $_[0]->{-table}->{$i} && $_[0]->lnglbl($_[0]->{-table}->{$i}))
8500
||$_[0]->lng(0, $i)
8501
: $_[0]->lng(0, $i))
8502
.''))
8503
."\n"
8504
.($_[0]->{-icons} ? ' ' : '')
8505
}
8506
8507
8508
sub htmlMChs { # Adjust CGI forms list
8509
0
0
0
0
if (!$_[0]->{-menuchs}) {
8510
0
$_[0]->{-menuchs} =[];
8511
0
0
if ($_[0]->{-form}) {
8512
0
0
push @{$_[0]->{-menuchs}},
0
8513
0
0
0
map {[$_, ($_[0]->lnglbl($_[0]->{-form}->{$_},$_)||$_)]
8514
0
} grep {($_ ne 'default')
8515
&& ((ref($_[0]->{-form}->{$_}) ne 'HASH')
8516
|| !$_[0]->{-form}->{$_}->{-hide})
8517
0
} keys %{$_[0]->{-form}}
8518
}
8519
0
0
if ($_[0]->{-table}) {
8520
0
0
push @{$_[0]->{-menuchs}},
0
8521
0
0
map {[$_, ($_[0]->lnglbl($_[0]->{-table}->{$_},$_)||$_)]
8522
0
} grep {(ref($_[0]->{-table}->{$_}) ne 'HASH')
8523
|| !$_[0]->{-table}->{$_}->{-hide}
8524
0
} keys %{$_[0]->{-table}}
8525
}
8526
0
0
@{$_[0]->{-menuchs}} =sort {lc(ref($a) && $a->[1] || $a) cmp lc(ref($b) && $b->[1] || $b)
0
0
0
8527
0
} @{$_[0]->{-menuchs}};
8528
0
0
0
if ($_[0]->{-menuchs} && !$_[0]->uguest()) {
8529
0
my @a =( ['','--- ' .lng($_[0], 0, 'frmCallNew') .' ---']
8530
0
, map {[$_->[0] .'+', $_->[1] ] # .' ++' # also $f1 in htmlML()
8531
0
} grep { my $m;
8532
0
0
($m =$_[0]->{-form}->{$_->[0]})
0
8533
? $m->{-field}
8534
: ($m =$_[0]->{-table}->{$_->[0]})
8535
? !$m->{-ixcnd}
8536
: 0
8537
0
} @{$_[0]->{-menuchs}}
8538
);
8539
0
0
if (@{$_[0]->{-menuchs}} <6) {push @{$_[0]->{-menuchs}}, @a}
0
0
0
0
8540
else {$_[0]->{-menuchs1} =[@a]}
8541
}}
8542
0
0
0
if ($_[0]->{-menuchs1}
0
0
8543
&& (!ref($_[0]->{-menuchs1}->[0])
8544
? $_[0]->{-menuchs1}->[0]
8545
: ref($_[0]->{-menuchs1}->[0]) eq 'HASH'
8546
? $_[0]->{-menuchs1}->[0]->{-val}
8547
: $_[0]->{-menuchs1}->[0]->[0])) {
8548
0
unshift @{$_[0]->{-menuchs1}}, ['', '--- ' .lng($_[0], 0, 'frmCallNew') .' ---']
0
8549
}
8550
0
$_[0]->{-menuchs}
8551
}
8552
8553
8554
sub cgiDBData { # Database data fields/values
8555
# self, form, meta, value hash
8556
0
0
0
my ($s, $n, $m, $c, $v) =@_;
8557
0
0
0
$m =$s->{-form}->{$n}||$s->{-table}->{$n} if !$m;
8558
0
0
my $mt=$m->{-field}||($m->{-table} && $s->{-table}->{$m->{-table}}->{-field})||[];
8559
0
0
my $mn=exists($m->{-null}) ? $m->{-null} : $m->{-table} ? $s->{-table}->{$m->{-table}}->{-null} : undef;
0
8560
0
0
my $cc=($c && $c->{-cmd} ||'');
8561
0
my @xx;
8562
0
my $r ={};
8563
0
local $_;
8564
0
0
0
if (($c && $c->{-cmg} ||'') eq 'recNew') {
8565
0
$r->{-new} =$s->strtime;
8566
}
8567
0
foreach my $f (@$mt) {
8568
0
0
next if ref($f) ne 'HASH';
8569
0
0
0
$r->{$f->{-fld}} =!defined($v->{$f->{-fld}})
0
0
0
0
0
0
0
8570
? $v->{$f->{-fld}}
8571
: exists($f->{-null})
8572
? (defined($f->{-null}) && ($v->{$f->{-fld}} eq $f->{-null})
8573
? undef : $v->{$f->{-fld}})
8574
: defined($mn)
8575
? ($v->{$f->{-fld}} eq $mn ? undef : $v->{$f->{-fld}})
8576
: $v->{$f->{-fld}}
8577
if exists ($v->{$f->{-fld}})
8578
&& (!defined($f->{-flg})
8579
|| $f->{-flg} =~/[aeu]/); # 'a'll, 'e'dit, 'u'pdate
8580
0
0
if ($cc =~/^rec(?:Ins|Upd)/) {
8581
0
0
0
push @xx
0
0
8582
, ("'" .$s->lnglbl($f,'-fld')
8583
."' - " .$s->lng(0,'fldReqStp'))
8584
if $f->{-flg} && ($f->{-flg} =~/[m]/)
8585
&& (!defined($r->{$f->{-fld}}) || ($r->{$f->{-fld}} eq ''));
8586
0
0
if ($f->{-chk}) {
8587
0
$_ =$r->{$f->{-fld}}; $@ ='';
0
8588
0
&{$f->{-chk}}($s,$m,$f,$r);
0
8589
0
0
if ($@) {push @xx, ("'" .$s->lnglbl($f,'-fld') ."' - "
0
0
8590
.$@ .' - ' .$s->lng(0,'fldChkStp'))}
8591
else {$r->{$f->{-fld}} =$_}
8592
}
8593
}
8594
}
8595
0
0
0
return(&{$s->{-die}}($s->{-ermu} .join("\n",@xx). "\n\n") && undef)
8596
if scalar(@xx);
8597
0
0
%$r ? $r : undef
8598
}
8599
8600
8601
sub cgiForm { # Print CGI screen form
8602
# self, form name, form meta, command, data
8603
0
0
1
my ($s, $n, $m, $c, $d) =@_;
8604
0
0
0
$m =$s->{-form}->{$n}||$s->mdeTable($n) if !$m;
8605
0
0
$c =$s->{-pcmd} if !$c;
8606
0
0
$d =$s->{-pout} if !$d;
8607
0
0
0
return($s) if ($c->{-cmg}||'') eq 'recDel';
8608
8609
0
0
my $qm=($c->{-cmg}||'') eq 'recQBF';
8610
0
0
my $em=$c->{-edit} || $qm;
8611
0
0
0
my $fm=($em || $qm ? 'e' : '') .($qm ? 'q' : '') .($c && $c->{-print} ? 'p' : '');
0
0
0
8612
0
0
my $fr=ref($d) && ref($d->{-editable}) && $d->{-editable}->{-fr};
8613
8614
0
0
my $mt=$m->{-table} ? $s->mdeTable($m->{-table}) : $m;
8615
0
0
local $c->{-cmdt} =$mt || $m; # table metadata
8616
0
0
local $c->{-cmdf} =$m || $mt; # form metadata
8617
0
local $s->{-pout} =$s->{-pout};
8618
8619
0
0
my $lt =$c->{-xml} ? 1 : 0; # 1 - closed table, 2 - table & labels
8620
0
my $lr =1; # 1 - nxt row before
8621
0
my $hide =0; # 1 - field hidden, 2 - hidden left
8622
0
my $edit =0; # 1 - field editable
8623
8624
0
0
if($qm) {
8625
0
$s->cgiQDflt($n, $m, $c);
8626
0
0
0
$d =$c->{-qkey} && {%{$c->{-qkey}}} || {} if (!$d ||!%$d);
0
8627
0
0
map { $d->{$_} =ref($d->{$_})
0
8628
? $s->dsdQuot($d->{$_})
8629
: $d->{$_}
8630
} keys %$d;
8631
0
0
0
$c->{-frmLso} ='' if $c->{-frmLso} && ($c->{-frmLso} =~/^-/);
8632
}
8633
8634
0
0
0
$s->output(''
0
0
0
0
8635
# cellspacing="0" cellpadding="0"
8636
# margin + left + border + padding ["Measuring Element Dimension and Location"]
8637
, $qm && $c->{-frmLso}
8638
? ("\n \n"
8639
, ' '
8640
, $s->lng(0,'frmLso')
8641
, "\n\n"
8642
, ' '
8643
, $c->{-frmLso}
8644
? $s->htmlField('_frmLso', $s->lng(1,'frmLso')
8645
, {-labels=>
8646
{ref($c->{-frmLso}) eq 'ARRAY'
8647
? ($c->{-frmLso}->[0]=>$s->lng(0,$c->{-frmLso}->[0]))
8648
: ($c->{-frmLso}=>$s->lng(0,$c->{-frmLso}))
8649
}}
8650
, ref($c->{-frmLso}) eq 'ARRAY'
8651
? $c->{-frmLso}->[0]
8652
: $c->{-frmLso})
8653
: ()
8654
, "\n \n \n"
8655
)
8656
: ()
8657
,"\n \n")
8658
if !$c->{-xml};
8659
8660
# form additions - using sub{} fields
8661
# file attachments - using 'tfdRFD' / 'htmlRFD'
8662
# versions - using sub{} fields with queries
8663
# embedded views - using sub{} fields with queries
8664
0
0
foreach my $rhe ($c->{-hist} # history loop
0
8665
? @{$s->recHist(-key=>$s->recKey($c->{-table}, $d)
8666
,-table=>$c->{-table})}
8667
: $d) {
8668
0
0
next if !$rhe;
8669
0
0
if ($c->{-hist}) {
8670
0
$d =$s->{-pout} =$rhe->[3];
8671
0
$s->output(" \n"
8672
,' '
8673
,'
8674
,$HS ,'_form=', $s->htmlEscape($n)
8675
,$HS ,'_key=', $s->htmlEscape($rhe->[0]), '"'
8676
,' title="', $s->htmlEscape($s->lng(1,'utime')), '"'
8677
,'>', $s->htmlEscape($rhe->[1]), "\n"
8678
,'
8679
,' title="', $s->htmlEscape($s->lng(1,'updater')),,'"'
8680
,'>'
8681
,$s->htmlEscape($s->udisp($rhe->[2])), " \n"
8682
," \n");
8683
}
8684
0
0
0
foreach my $v (@{$m->{-field} # field loop
0
0
0
8685
||($m->{-query} && $m->{-query}->{-data})
8686
||($m->{-table} && $s->mdeTable($m->{-table})->{-field})
8687
}) {
8688
0
0
my $f =(ref($v) && $v) || ($mt->{-mdefld} && $mt->{-mdefld}->{$v}) || $v;
8689
0
0
if ($c->{-xml}) {
0
0
0
0
0
0
0
0
8690
0
0
next if !ref($f);
8691
0
0
0
if (ref($f) eq 'CODE') {next}
0
0
0
0
0
0
8692
elsif ($f->{-inp}
8693
&& $f->{-inp}->{-rfd}
8694
0
&& $s->{-pout}->{-file}) {
8695
0
my $u =$s->rfdPath(-url=>$s->{-pcmd}, $s->{-pout});
8696
0
0
$u =$s->url(-base=>1) .$u if $u !~/\/\/\w+:/;
8697
0
my $v =join("\n", map { $u .'/' .$_
0
8698
} $s->rfdGlobn($s->{-pcmd}, $s->{-pout}));
8699
0
$s->output($s->xmlsTag('files',''=>$v),"\n");
8700
next
8701
0
}
8702
elsif (!$f->{-fld}
8703
||!defined($d->{$f->{-fld}})
8704
||($d->{$f->{-fld}} eq '')) {next}
8705
0
my $v =$d->{$f->{-fld}};
8706
0
0
0
if ($f->{-inp} && $f->{-inp}->{-htmlopt}
0
0
0
8707
&& $s->ishtml($v)) {
8708
0
0
$s->output('<',$f->{-fld},'>'
8709
,$s->trURLhtm($v, sub{$_[1]}
8710
0
0
0
, sub{ $_[1] =~/^[\w-]{3,7}:\/{2}/
0
8711
? $_[1]
8712
: $_[1] =~/^\//
8713
? $_[0]->url(-base=>1) .$_[1]
8714
: $_[0]->url .$_[1]
8715
})
8716
0
,'',$f->{-fld},">\n");
8717
}
8718
elsif ($f->{-inp} && $f->{-inp}->{-hrefs}) {
8719
0
0
$v =$s->trURLtxt($v
8720
, sub{$_[1]}
8721
0
0
0
, sub{ $_[1] =~/^[\w-]{3,7}:\/{2}/
0
8722
? $_[1]
8723
: $_[1] =~/^\//
8724
? $_[0]->url(-base=>1) .$_[1]
8725
: $_[0]->url .$_[1]
8726
0
});
8727
0
$s->output($s->xmlsTag($f->{-fld}, ''=>$v), "\n")
8728
}
8729
else {
8730
0
$s->output($s->xmlsTag($f->{-fld}, ''=>$v), "\n")
8731
}
8732
next
8733
0
}
8734
elsif ($c->{-hist}) {
8735
0
0
next if ref($f) ne 'HASH';
8736
0
0
0
next if $f->{-inp} && $f->{-inp}->{-rfd}
0
0
8737
? (!$d->{-file})
8738
: (!$f->{-fld} || !exists($d->{$f->{-fld}}));
8739
}
8740
elsif ($f eq '') { # next col
8741
0
0
0
$lr =$hide && ($hide ==2) ? 1 : 0;
8742
0
$hide =0;
8743
next
8744
0
}
8745
elsif ($f =~/^(\n*)(\t*)$/) {
8746
0
$lr =0;
8747
0
0
if ($1) { # new lines
8748
0
0
$s->output((!$lt ? "\n \n\n" : "\n \n")
8749
x (length($1)/length("\n")));
8750
0
$lr =1;
8751
}
8752
0
0
if ($2) { # skip cells
8753
0
0
$s->output($lr ? "\n \n\n" : ''
0
8754
, " \n" x length($2))
8755
if !$lt;
8756
0
$lr =0;
8757
}
8758
0
next;
8759
}
8760
elsif ($f eq "\f") { # close table
8761
0
0
$s->output("\n \n
\n") if !$lt;
8762
0
$lt =1; $lr =1;
0
8763
next
8764
0
}
8765
0
elsif ($f eq '
') { # close table & labels