-
Notifications
You must be signed in to change notification settings - Fork 5
/
ARS.pm
509 lines (452 loc) · 14.1 KB
/
ARS.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
#
# ARSperl - An ARS v5-v7 / Perl5 Integration Kit
#
# Copyright (C) 1995-2007 Joel Murphy, [email protected]
# Jeff Murphy, [email protected]
#
# This program is free software; you can redistribute it and/or modify
# it under the terms as Perl itself.
#
# Refer to the file called "Artistic" that accompanies the source distribution
# of ARSperl (or the one that accompanies the source distribution of Perl
# itself) for a full description.
#
# Official Home Page:
# http://www.arsperl.org
#
# Mailing List (must be subscribed to post):
#
# Routines for grabbing the current error message "stack"
# by simply referring to the $ars_errstr scalar.
package ARS::ERRORSTR;
sub TIESCALAR {
bless {};
}
sub FETCH {
my($s, $i) = (undef, undef);
my(%mTypes) = ( 0 => "OK", 1 => "WARNING", 2 => "ERROR", 3 => "FATAL",
4 => "INTERNAL ERROR",
-1 => "TRACEBACK");
for($i = 0; $i < $ARS::ars_errhash{numItems}; $i++) {
# If debugging is not enabled, don't show traceback messages
if($ARS::DEBUGGING == 1) {
$s .= sprintf("[%s] %s (ARERR \#%d)",
$mTypes{@{$ARS::ars_errhash{messageType}}[$i]},
@{$ARS::ars_errhash{messageText}}[$i],
@{$ARS::ars_errhash{messageNum}}[$i]);
$s .= "\n" if($i < $ARS::ars_errhash{numItems}-1);
} else {
if(@{$ARS::ars_errhash{messageType}}[$i] != -1) {
$s .= sprintf("[%s] %s (ARERR \#%d)",
$mTypes{@{$ARS::ars_errhash{messageType}}[$i]},
@{$ARS::ars_errhash{messageText}}[$i],
@{$ARS::ars_errhash{messageNum}}[$i]);
$s .= "\n" if($i < $ARS::ars_errhash{numItems}-1);
}
}
}
return $s;
}
package ARS;
require 5.005;
use strict "vars";
require Exporter;
require DynaLoader;
require Carp unless $^S;
use AutoLoader 'AUTOLOAD';
use Config;
require 'ARS/ar-h.pm';
require 'ARS/arerrno-h.pm';
require 'ARS/nparm.pm';
@ARS::ISA = qw(Exporter DynaLoader);
@ARS::EXPORT = qw(isa_int isa_float isa_string ars_LoadQualifier ars_Login
ars_Logoff ars_GetListField ars_GetFieldByName ars_GetFieldTable
ars_DeleteEntry ars_GetEntry ars_GetListEntry ars_GetListSchema
ars_GetListServer ars_GetActiveLink ars_GetCharMenuItems ars_GetSchema
ars_ExpandCharMenu
ars_GetField ars_simpleMenu ars_GetListActiveLink ars_SetEntry
ars_perl_qualifier ars_qualifier_ptr ars_Export ars_GetListFilter ars_GetListEscalation
ars_GetListCharMenu ars_padEntryid
ars_GetFilter ars_SetFilter
ars_GetListEntryWithFields ars_GetMultipleEntries
ars_GetProfileInfo ars_Import ars_GetCharMenu ars_GetServerStatistics
ars_GetCurrentServer ars_EncodeDiary
ars_CreateEntry ars_MergeEntry ars_DeleteFilter
ars_DeleteMultipleFields ars_DeleteActiveLink
ars_DeleteCharMenu
ars_DeleteEscalation ars_DeleteField ars_DeleteSchema
ars_DeleteVUI ars_ExecuteProcess
ars_GetEscalation ars_GetFullTextInfo
ars_GetListGroup ars_GetListSQL ars_GetListUser ars_GetListRole
ars_GetListVUI
ars_GetServerInfo ars_SetServerInfo
ars_GetEntryBLOB
ars_CreateActiveLink
ars_GetControlStructFields ars_GetVUI
ars_GetListContainer ars_GetContainer ars_DeleteContainer ars_SetServerPort
ars_SetLogging ars_SetSessionConfiguration ars_SetImpersonatedUser
ars_CreateField ars_SetField ars_CreateSchema ars_SetSchema ars_CreateVUI ars_SetVUI
ars_CreateContainer ars_SetContainer ars_CreateCharMenu ars_SetCharMenu
ars_SetActiveLink ars_CreateFilter ars_CreateEscalation ars_SetEscalation
$ars_errstr %ARServerStats %ars_errhash
ars_decodeStatusHistory ars_APIVersion ars_encodeStatusHistory
ars_BeginBulkEntryTransaction ars_EndBulkEntryTransaction
ars_Signal ars_GetTextForErrorMessage ars_DateToJulianDate
ars_GetListLicense ars_ValidateMultipleLicenses
ars_GetServerCharSet ars_GetClientCharSet
ars_GetAlertCount ars_RegisterForAlerts ars_DeregisterForAlerts ars_GetListAlertUser
ars_DecodeAlertMessage ars_CreateAlertEvent ars_VerifyUser
ars_GetListImage ars_GetImage ars_CreateImage ars_SetImage ars_DeleteImage
ars_GetListEntryWithMultiSchemaFields
ars_GetSessionConfiguration
ars_SetOverlayGroup ars_SwitchToBestPracticeMode ars_SwitchToBaseMode
);
$ARS::VERSION = '2.00';
$ARS::DEBUGGING = 0;
$ARS::logging_file_ptr = 0;
# definitions required for backwards compatibility
if (!defined &ARS::AR_IMPORT_OPT_CREATE) {
eval 'sub AR_IMPORT_OPT_CREATE { 0; }';
}
if (!defined &ARS::AR_IMPORT_OPT_OVERWRITE) {
eval 'sub AR_IMPORT_OPT_OVERWRITE { 1; }';
}
bootstrap ARS $ARS::VERSION;
tie $ARS::ars_errstr, ARS::ERRORSTR;
# This HASH is used by the ars_GetServerStatistics call.
# Refer to your ARS API Programmer's Manual or the "ar.h"
# file for an explaination of what each of these stats are.
#
# Usage of this hash would be something like:
#
# %stats = ars_GetServerStatistics($ctrl,
# $ARServerStats{'START_TIME'},
# $ARServerStats{'CPU'});
#
%ARS::ARServerStats = (
'START_TIME' ,1,
'BAD_PASSWORD' ,2,
'NO_WRITE_TOKEN' ,3,
'NO_FULL_TOKEN' ,4,
'CURRENT_USERS' ,5,
'WRITE_FIXED' ,6,
'WRITE_FLOATING' ,7,
'WRITE_READ' ,8,
'FULL_FIXED' ,9,
'FULL_FLOATING' ,10,
'FULL_NONE' ,11,
'API_REQUESTS' ,12,
'API_TIME' ,13,
'ENTRY_TIME' ,14,
'RESTRUCT_TIME' ,15,
'OTHER_TIME' ,16,
'CACHE_TIME' ,17,
'GET_E_COUNT' ,18,
'GET_E_TIME' ,19,
'SET_E_COUNT' ,20,
'SET_E_TIME' ,21,
'CREATE_E_COUNT' ,22,
'CREATE_E_TIME' ,23,
'DELETE_E_COUNT' ,24,
'DELETE_E_TIME' ,25,
'MERGE_E_COUNT' ,26,
'MERGE_E_TIME' ,27,
'GETLIST_E_COUNT' ,28,
'GETLIST_E_TIME' ,29,
'E_STATS_COUNT' ,30,
'E_STATS_TIME' ,31,
'FILTER_PASSED' ,32,
'FILTER_FAILED' ,33,
'FILTER_DISABLE' ,34,
'FILTER_NOTIFY' ,35,
'FILTER_MESSAGE' ,36,
'FILTER_LOG' ,37,
'FILTER_FIELDS' ,38,
'FILTER_PROCESS' ,39,
'FILTER_TIME' ,40,
'ESCL_PASSED' ,41,
'ESCL_FAILED' ,42,
'ESCL_DISABLE' ,43,
'ESCL_NOTIFY' ,44,
'ESCL_LOG' ,45,
'ESCL_FIELDS' ,46,
'ESCL_PROCESS' ,47,
'ESCL_TIME' ,48,
'TIMES_BLOCKED' ,49,
'NUMBER_BLOCKED' ,50,
'CPU' ,51,
'SQL_DB_COUNT' ,52,
'SQL_DB_TIME' ,53,
'FTS_SRCH_COUNT' ,54,
'FTS_SRCH_TIME' ,55,
'SINCE_START' ,56,
'IDLE_TIME', 57,
'NET_RESP_TIME', 58,
'FILTER_FIELDP', 59,
'ESCL_FIELDP', 60,
'FILTER_SQL', 61,
'ESCL_SQL', 62,
'NUM_THREADS', 63,
'FILTER_GOTO_ACTION', 64,
'FILTER_CALL_GUIDE', 65,
'FILTER_EXIT_GUIDE', 66,
'FILTER_GOTO_GUIDE_LB', 67,
'FILTER_FIELDS_SQL', 68,
'FILTER_FIELDS_PROCESS', 69,
'FILTER_FIELDS_FLTAPI', 70,
'ESCL_FIELDS_SQL', 71,
'ESCL_FIELDS_PROCESS', 72,
'ESCL_FIELDS_FLTAPI', 73,
'WRITE_RESTRICTED_READ', 74
);
sub new {
require 'ARS/OOform.pm';
require 'ARS/OOmsgs.pm';
require 'ARS/OOsup.pm';
return newObject( @_ );
}
# ROUTINE
# ars_simpleMenu(menuItems, prepend)
#
# DESCRIPTION
# merges all sub-menus into a single level menu. good for web
# interfaces.
#
# RETURNS
# array of menu items.
sub ars_simpleMenu {
my($m) = shift;
my($prepend) = shift;
my(@m) = @$m;
my(@ret, @submenu);
my($name, $val);
while (($name, $val, @m) = @m) {
if (ref($val)) {
@submenu = ars_simpleMenu($val, $name);
@ret = (@ret, @submenu);
} else {
if ($prepend) {
@ret = (@ret, "$prepend/$name", $val);
} else {
@ret = (@ret, $name, $val);
}
}
}
@ret;
}
# ROUTINE
# ars_padEntryid(control, schema, entry-id)
#
# DESCRIPTION
# this routine will left-pad the entry-id with
# zeros out to the appropriate number of place (15 max)
# depending upon if your prefix your entry-id's with
# anything
#
# RETURNS
# a new scalar on success
# undef on error
sub ars_padEntryid {
my($c) = shift;
my($schema) = shift;
my($entry_id) = shift;
my($field);
# entry id field is field id #1
($field = ars_GetField($c, $schema, 1)) ||
return undef;
if( $field->{defaultVal} ){
return $field->{defaultVal}.("0"x($field->{limit}{maxLength}-length($field->{defaultVal})-length($entry_id))).$entry_id;
}else{
return ("0"x($field->{limit}{maxLength}-length($entry_id))).$entry_id;
}
}
# ROUTINE
# ars_decodeStatusHistory(field-value)
#
# DESCRIPTION
# this routine, when given an encoded status history field
# (returned by GetEntry) will decode it into a hash like:
#
# $retval[ENUM]->{USER}
# $retval[ENUM]->{TIME}
#
# so if you have a status field that has two states: Open and Closed,
# where Open is enum 0 and Closed is enum 1, this routine will return:
#
# $retval[0]->{USER} = the user to last selected this enum
# $retval[1]->{TIME} = the time that this enum was last selected
#
# You can map from enum values to selection words by using
# arsGetField().
sub ars_decodeStatusHistory {
my ($sval) = shift;
my ($enum) = 0;
my ($pair, $ts, $un);
my (@retval);
foreach $pair (split(/\003/, $sval)) {
if($pair ne "") {
($ts, $un) = split(/\004/, $pair);
$retval[$enum]->{USER} = $un;
$retval[$enum]->{TIME} = $ts;
} else {
# no value for this enumeration
$retval[$enum]->{USER} = undef;
$retval[$enum]->{TIME} = undef;
}
$enum++;
}
return @retval;
}
#define AR_DEFN_DIARY_SEP '\03' /* diary items separator */
#define AR_DEFN_DIARY_COMMA '\04' /* char between date/user/text */
# ROUTINE
# ars_EncodeDiary(diaryhash1, diaryhash2, ...)
#
# DESCRIPTION
# given a list of diary hashs (see ars_GetEntry),
# encode them into an ars-internal diary string. this can
# then be fed into ars_MergeEntry() in order to alter the contents
# of an existing diary entry.
#
# RETURNS
# an encoded diary string (scalar) on success
# undef on failure
sub ars_EncodeDiary {
my ($diary_string) = undef;
my ($entry);
foreach $entry (@_) {
$diary_string .= $entry->{timestamp}.pack("c",4).$entry->{user}.pack("c",4).$entry->{value};
$diary_string .= pack("c",3) if ($diary_string);
}
return $diary_string;
}
sub insertValueForCurrentTransaction {
my ($c, $s, $q) = (shift, shift, shift);
die Carp::longmess("Usage: insertValueForCurrentTransaction(ctrl, schema, qualifier, ...)\n")
if(!defined($q));
die Carp::longmess("Usage: insertValueForCurrentTransaction(ctrl, schema, qualifier, ...)\nEven number of arguments must follow 'qualifier'\n")
if($#_ % 2 == 1);
#foreach (field, value) pair {
# look up field
# if field = text then wrap value in double quotes
# if field = numeric then no quotes
# search thru qual and change field ref to value
#}
# compile new qual
# pass to Expand2
if(ref($q) eq "ARQualifierStructPtr") {
$q = ars_perl_qualifier($c, $q);
die Carp::longmess("ars_perl_qualifier failed: $ARS::ars_errstr")
unless defined($q);
}
if(0) {
while($#_) {
my ($f, $v) = (shift @_, shift @_);
my $fh = ars_GetField($c, $s, $f);
if(($fh->{'dataType'} eq "char") ||
($fh->{'dataType'} eq "diary")) {
$v = "\"$v\"";
}
}
}
print "walktree..\n";
walkTree($q);
exit 0;
}
sub walkTree {
my $q = shift;
print "($q) ";
if(defined($q->{'oper'})) {
print "oper: ".$q->{'oper'}."\n";
if($q->{'oper'} eq "not") {
walkTree($q->{'not'});
return;
} elsif($q->{'oper'} eq "rel_op") {
walkTree($q->{'rel_op'});
return;
} else {
walkTree($q->{'left'});
walkTree($q->{'right'});
return;
}
}
else {
if(defined($q->{'left'}{'queryCurrent'})) {
print "l ", $q->{'left'}{'queryCurrent'}, "\n";
}
if(defined($q->{'right'}{'queryCurrent'})) {
print "r ", $q->{'right'}{'queryCurrent'}, "\n";
}
foreach (keys %$q) {
print "key: ", $_,"\n";
print "val: ", $q->{$_},"\n";
dumpHash ($q->{$_}) if(ref($q->{$_}) eq "HASH");
}
}
}
sub dumpHash {
my $h = shift;
foreach (keys %$h) {
print "key: ", $_,"\n";
print "val: ", $h->{$_},"\n";
dumpHash($h->{$_}) if(ref($h->{$_}) eq "HASH");
}
}
# ars_GetCharMenuItems(ctrl, menuName, qualifier)
# qual is optional.
# if it's specified:
# menuType must be "query"
# qualifier must compile against the form that the menu
# is written for.
sub ars_GetCharMenuItems {
my ($ctrl, $menuName, $qual) = (shift, shift, shift);
if(defined($qual)) {
my $menu = ars_GetCharMenu($ctrl, $menuName);
die "ars_GetCharMenuItems failed: $ARS::ars_errstr"
unless defined($menu);
die "ars_GetCharMenuItems failed: qualifier was specified, but menu is not a 'query' menu"
if($menu->{'menuType'} ne "query");
if(ref($qual) ne "ARQualifierStruct") {
$qual = ars_LoadQualifier($ctrl, $menu->{'menuQuery'}{'schema'}, $qual);
}
return ars_ExpandCharMenu2($ctrl, $menuName, $qual);
}
return ars_ExpandCharMenu2($ctrl, $menuName);
}
sub ars_ExpandCharMenu {
return ars_ExpandCharMenu2(@_);
}
# encodes status history from the same format
# as returned by ars_decodeStatusHistory()
sub ars_encodeStatusHistory {
my @sh = ();
while(my $hr = shift) {
push @sh, $hr->{USER} ? "$hr->{TIME}\cD$hr->{USER}" : "";
}
join "\cC", @sh;
}
sub ars_SetOverlayGroup {
my ($ctrl, $value) = (shift, shift);
ars_SetSessionConfiguration($ctrl, 12, $value);
ars_SetSessionConfiguration($ctrl, 13, $value);
}
sub ars_SwitchToBaseMode {
my $ctrl = shift;
ars_SetOverlayGroup($ctrl, 0);
}
sub ars_SwitchToBestPracticeMode {
my $ctrl = shift;
ars_SetOverlayGroup($ctrl, 1);
}
# As of ARS4.0, these routines (which call ARInitialization and ARTermination)
# need to pass a control struct. this means that we now must move them into
# ars_Login and ars_Logoff in order to have access to that control struct.
# the implications of this are that your script should always call ars_Logoff()
# inorder to ensure that licenses are released (i.e. ARTermination is called)
# as for ARInitialization: this is used for private servers, mostly, and shouldnt
# affect anything by moving it into the ars_Login call.
# call ARInitialization
ARS::__ars_init() if(&ARS::ars_APIVersion() < 4);
1;
__END__