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
(
$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
;
}
require
5.005;
require
'ARSar-h.pm'
;
require
'ARSarerrno-h.pm'
;
require
'ARSnt-h.pm'
;
require
'ARSnterrno-h.pm'
;
require
'ARSnparm.pm'
;
require
'ARSOOform.pm'
;
require
'ARSOOmsgs.pm'
;
require
'ARSOOsup.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_Export ars_GetListFilter ars_GetListEscalation
ars_GetListCharMenu ars_GetListAdminExtension ars_padEntryid
ars_GetFilter ars_SetFilter
ars_GetListEntryWithFields ars_GetMultipleEntries
ars_GetProfileInfo ars_Import ars_GetCharMenu ars_GetServerStatistics
ars_NTDeregisterServer ars_NTGetListServer ars_NTInitializationServer
ars_NTNotificationServer ars_NTTerminationServer ars_NTDeregisterClient
ars_NTInitializationClient ars_NTRegisterClient ars_NTTerminationClient
ars_NTRegisterServer ars_GetCurrentServer ars_EncodeDiary
ars_CreateEntry ars_MergeEntry ars_DeleteFilter
ars_DeleteMultipleFields ars_DeleteActiveLink
ars_DeleteAdminExtension ars_DeleteCharMenu
ars_DeleteEscalation ars_DeleteField ars_DeleteSchema
ars_DeleteVUI ars_ExecuteAdminExtension ars_ExecuteProcess
ars_GetAdminExtension ars_GetEscalation ars_GetFullTextInfo
ars_GetListGroup ars_GetListSQL ars_GetListUser
ars_GetListVUI
ars_GetServerInfo ars_SetServerInfo
ars_GetEntryBLOB
ars_CreateActiveLink ars_CreateAdminExtension
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::VERSION
=
'1.90'
;
$ARS::DEBUGGING
= 0;
$ARS::logging_file_ptr
= 0;
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;
%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
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
;
}
sub
ars_padEntryid {
my
(
$c
) =
shift
;
my
(
$schema
) =
shift
;
my
(
$entry_id
) =
shift
;
my
(
$field
);
(
$field
= ars_GetField(
$c
,
$schema
, 1)) ||
return
undef
;
return
(
"0"
x(
$field
->{limit}{maxLength}-
length
(
$entry_id
))).
$entry_id
;
}
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
{
$retval
[
$enum
]->{USER} =
undef
;
$retval
[
$enum
]->{TIME} =
undef
;
}
$enum
++;
}
return
@retval
;
}
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);
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"
);
}
}
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(
@_
);
}
sub
ars_encodeStatusHistory {
my
@sh
= ();
while
(
my
$hr
=
shift
) {
push
@sh
,
$hr
->{USER} ?
"$hr->{TIME}\cD$hr->{USER}"
:
""
;
}
join
"\cC"
,
@sh
;
}
ARS::__ars_init()
if
(
&ARS::ars_APIVersion
() < 4);
1;