ARSperl
view release on metacpan or search on metacpan
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;
}
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.
ARError(ret, status);
#ifdef PROFILE
AP_FREE(ctrl);
#else
safefree(ctrl);
#endif
goto ar_login_end;
}
/*
printf( "ctrl->localeInfo.customDateFormat <%s>\n", ctrl->localeInfo.customDateFormat );
printf( "ctrl->localeInfo.separators <%s>\n", ctrl->localeInfo.separators );
*/
#endif
if (!server || !*server) {
DBG( ("no server given. picking one.\n") );
#if AR_EXPORT_VERSION >= 4
ret = ARGetListServer(ctrl, &serverList, &status);
#else
ret = ARGetListServer(&serverList, &status);
#endif
ARBoolean adminFlag = 0,
subAdminFlag = 0,
customFlag = 0;
ARStatusList status;
(void) ARError_reset();
Zero(&status, 1, ARStatusList);
ret = ARVerifyUser( ctrl, &adminFlag, &subAdminFlag, &customFlag, &status );
/* printf( "ret = %d, adminFlag = %d, subAdminFlag = %d, customFlag = %d\n",
ret, adminFlag, subAdminFlag, customFlag ); */
if(! ARError(ret, status)) {
RETVAL = newHV();
sv_2mortal( (SV*) RETVAL );
hv_store( RETVAL, "adminFlag", strlen("adminFlag"), newSViv(adminFlag), 0);
hv_store( RETVAL, "subAdminFlag", strlen("subAdminFlag"), newSViv(subAdminFlag), 0);
hv_store( RETVAL, "customFlag", strlen("customFlag"), newSViv(customFlag), 0);
}else{
getFieldIds.internalIdList = NULL;
/* try to get data type from field cache, collect fieldIds which are not cached */
for (i=0; i<c; ++i) {
ARInternalId fieldId;
a = i*2+2;
fieldId = fieldList.fieldValueList[i].fieldId = SvIV(ST(a));
dataType = fieldcache_get_data_type( cacheFields, fieldId );
if (dataType <= AR_DATA_TYPE_MAX_TYPE) {
/* printf( "%s [%d] found in cache\n", schema, fieldId ); fflush(stdout); */ /* _DEBUG_ */
if (sv_to_ARValue(ctrl, ST(a+1), dataType, &fieldList.fieldValueList[i].value) < 0) {
goto create_entry_end;
}
}else{
if( getFieldIds.numItems == 0 ){
AMALLOCNN(getFieldIds.internalIdList,c,ARInternalId);
}
/* printf( "%s [%d] collect for loading\n", schema, fieldId ); fflush(stdout); */ /* _DEBUG_ */
getFieldIds.internalIdList[getFieldIds.numItems] = fieldId;
++getFieldIds.numItems;
}
}
/* load missing fields into cache */
if( getFieldIds.numItems > 0 ){
/* printf( "--- load missing fields ---\n" ); fflush(stdout); */ /* _DEBUG_ */
/* if( fieldcache_load_schema(ctrl,schema,&getFieldIds,NULL) != AR_RETURN_OK ){ */
if( fieldcache_load_schema(ctrl,schema,&getFieldIds,NULL) > AR_RETURN_WARNING ){
goto create_entry_end;
}
}
/* now get data type from the freshly cached fields */
i = 0;
for (j=0; j<getFieldIds.numItems; ++j) {
ARInternalId fieldId = getFieldIds.internalIdList[j];
while(fieldId != fieldList.fieldValueList[i].fieldId) ++i;
a = i*2+2;
dataType = fieldcache_get_data_type( cacheFields, fieldId );
if (dataType <= AR_DATA_TYPE_MAX_TYPE) {
/* printf( "%s [%d] freshly loaded\n", schema, fieldId ); fflush(stdout); */ /* _DEBUG_ */
if (sv_to_ARValue(ctrl, ST(a+1), dataType, &fieldList.fieldValueList[i].value) < 0) {
goto create_entry_end;
}
}else{
char errTxt[256];
sprintf( errTxt, "Failed to fetch field %d from hash", fieldId );
ARError_add(AR_RETURN_ERROR, AP_ERR_FIELD_TYPE);
ARError_add(AR_RETURN_ERROR, AP_ERR_CONTINUE, errTxt );
goto create_entry_end;
}
}
/* printf( "--------------------\n" ); fflush(stdout); */ /* _DEBUG_ */
ret = ARCreateEntry(ctrl, schema, &fieldList, entryId, &status);
#ifdef PROFILE
((ars_ctrl *)ctrl)->queries++;
#endif
if (! ARError( ret, status)) rv = 1;
create_entry_end:;
if(rv == 0) {
RETVAL = newSVsv(&PL_sv_undef);
} else {
/* determine data type and pass value */
dataType = fieldcache_get_data_type( cacheFields, fieldId );
if (dataType <= AR_DATA_TYPE_MAX_TYPE) {
if (sv_to_ARValue(ctrl, ST(a+1), dataType, &fieldList.fieldValueList[i].value) < 0) {
goto set_entry_end;
}
}else{
if( getFieldIds.numItems == 0 ){
AMALLOCNN(getFieldIds.internalIdList,c,ARInternalId);
}
/* printf( "%s [%d] collect for loading\n", schema, fieldId ); fflush(stdout); */ /* _DEBUG_ */
getFieldIds.internalIdList[getFieldIds.numItems] = fieldId;
++getFieldIds.numItems;
}
}
}
/* load missing fields into cache */
if( getFieldIds.numItems > 0 ){
/* printf( "--- load missing fields ---\n" ); fflush(stdout); */ /* _DEBUG_ */
/* if( fieldcache_load_schema(ctrl,schema,&getFieldIds,NULL) != AR_RETURN_OK ){ */
if( fieldcache_load_schema(ctrl,schema,&getFieldIds,NULL) > AR_RETURN_WARNING ){
goto set_entry_end;
}
}
/* now get data type from the freshly cached fields */
i = 0;
for (j=0; j<getFieldIds.numItems; ++j) {
ARInternalId fieldId = getFieldIds.internalIdList[j];
while(fieldId != fieldList.fieldValueList[i].fieldId) ++i;
a = i*2+offset;
dataType = fieldcache_get_data_type( cacheFields, fieldId );
if (dataType <= AR_DATA_TYPE_MAX_TYPE) {
/* printf( "%s [%d] freshly loaded\n", schema, fieldId ); fflush(stdout); */ /* _DEBUG_ */
if (sv_to_ARValue(ctrl, ST(a+1), dataType, &fieldList.fieldValueList[i].value) < 0) {
goto set_entry_end;
}
}else{
char errTxt[256];
sprintf( errTxt, "Failed to fetch field %d from hash", fieldId );
ARError_add(AR_RETURN_ERROR, AP_ERR_FIELD_TYPE);
ARError_add(AR_RETURN_ERROR, AP_ERR_CONTINUE, errTxt );
goto set_entry_end;
}
}
/* printf( "--------------------\n" ); fflush(stdout); */ /* _DEBUG_ */
/* build entryList */
if(perl_BuildEntryList(ctrl, &entryList, entry_id) != 0){
goto set_entry_end;
}
ret = ARSetEntry(ctrl, schema, &entryList, &fieldList, getTime, option, &status);
if (entryList.entryIdList) AP_FREE(entryList.entryIdList);
#ifdef PROFILE
StructItemTypeMap,
SvPV(ST(a), PL_na)
);
if(et == TYPEMAP_LAST) {
(void) ARError_add(AR_RETURN_ERROR, AP_ERR_BAD_EXP);
(void) ARError_add(AR_RETURN_ERROR, AP_ERR_CONTINUE,
SvPV(ST(a), PL_na) );
ok = 0;
} else {
structItems.structItemList[i].type = et;
/* printf( "structItems.structItemList[i].type <%d>\n", structItems.structItemList[i].type ); */ /* _DEBUG_ */
strncpy(structItems.structItemList[i].name,
SvPV(ST(a+1), PL_na),
sizeof(ARNameType) );
structItems.structItemList[i].name[sizeof(ARNameType)-1] = '\0';
/* printf( "structItems.structItemList[i].name <%s>\n", structItems.structItemList[i].name ); */ /* _DEBUG_ */
}
}
}
#if AR_EXPORT_VERSION >= 8L
workflowLockStruct.lockType = 0;
workflowLockStruct.lockKey[0] = '\0';
#endif
if(ok) {
ret = ARExport(ctrl, &structItems, displayTag,
serverInfo.serverInfoList[j].value.dataType = infoType;
switch(infoType) {
case AR_DATA_TYPE_CHAR:
serverInfo.serverInfoList[j].value.u.charVal = strdup(SvPV(ST(i+1), PL_na));
break;
case AR_DATA_TYPE_INTEGER:
serverInfo.serverInfoList[j].value.u.intVal = SvIV(ST(i+1));
break;
default:
sprintf( buf, "(%d) type = %d", serverInfo.serverInfoList[j].operation, serverInfo.serverInfoList[j].value.dataType );
(void) ARError_add(AR_RETURN_ERROR, AP_ERR_INV_ARGS,
buf);
FreeARServerInfoList(&serverInfo, FALSE);
XPUSHs(sv_2mortal(newSViv(0))); /* ERR */
goto SetServerInfo_fail;
}
}
ret = ARSetServerInfo(ctrl, &serverInfo, &status);
FreeARServerInfoList(&serverInfo, FALSE);
if(ARError(ret, status)) {
ret = ARGetServerInfo(ctrl, &requestList, &serverInfo, &status);
#ifdef PROFILE
((ars_ctrl *)ctrl)->queries++;
#endif
if(!ARError( ret, status)) {
for(ui = 0 ; ui < serverInfo.numItems ; ui++) {
/* provided we have a mapping for the operation code,
* push out it's translation. else push out the code itself
*/
if(serverInfo.serverInfoList[ui].operation <= AR_MAX_SERVER_INFO_USED) {
/* printf( "%d %s: data type = %d\n", serverInfo.serverInfoList[ui].operation, ServerInfoMap[serverInfo.serverInfoList[ui].operation].name, serverInfo.serverInfoList[ui].value.dataType ); */
XPUSHs(sv_2mortal(newSVpv(ServerInfoMap[serverInfo.serverInfoList[ui].operation].name, 0)));
} else {
XPUSHs(sv_2mortal(newSViv(serverInfo.serverInfoList[ui].operation)));
}
XPUSHs(sv_2mortal(perl_ARValueStruct(ctrl,
&(serverInfo.serverInfoList[ui].value))));
}
}
FreeARServerInfoList(&serverInfo, FALSE);
}
if( defaultVal != NULL ){
FreeARValueStruct( defaultVal, TRUE );
}
FreeARPermissionList( &permissions, FALSE );
if( limit != NULL ){
FreeARFieldLimitStruct( limit, TRUE );
}
FreeARDisplayInstanceList( &dInstanceList, FALSE );
/*
FreeARStatusList( &status, FALSE );
printf( "-- FreeARStatusList -- OK\n" ); // _DEBUG_
*/
#else /* < 5.0 */
XPUSHs(sv_2mortal(newSViv(0))); /* ERR */
(void) ARError_add( AR_RETURN_ERROR, AP_ERR_DEPRECATED,
"ARSperl supports CreateField() only for ARSystem >= 5.0");
RETVAL = AR_RETURN_ERROR;
#endif
}
OUTPUT:
RETVAL
FreeARPermissionList( permissions, TRUE );
}
if( limit != NULL ){
FreeARFieldLimitStruct( limit, TRUE );
}
if( dInstanceList != NULL ){
FreeARDisplayInstanceList( dInstanceList, TRUE );
}
/*
FreeARStatusList( &status, FALSE );
printf( "-- FreeARStatusList -- OK\n" ); // _DEBUG_
*/
#else /* < 5.0 */
XPUSHs(sv_2mortal(newSViv(0))); /* ERR */
(void) ARError_add( AR_RETURN_ERROR, AP_ERR_DEPRECATED,
"ARSperl supports SetField() only for ARSystem >= 5.0");
RETVAL = AR_RETURN_ERROR;
#endif
}
OUTPUT:
RETVAL
}
XPUSHs(sv_2mortal(newSVpv(joinId, 0)));
}
/*
* push field/value hash reference onto list
*/
if ( existList.booleanList[i] ) {
fieldValue_hash = newHV();
/* sv_2mortal( (SV *)fieldValue_hash ); */
for (field=0; field < fieldList.valueListList[i].numItems; field++) {
sprintf(intstr,"%ld",fieldList.valueListList[i].fieldValueList[field].fieldId);
hv_store( fieldValue_hash,
intstr, strlen(intstr),
perl_ARValueStruct(ctrl,&fieldList.valueListList[i].fieldValueList[field].value),
0 );
}
XPUSHs( sv_2mortal( newRV_noinc((SV *)fieldValue_hash) ) );
} else {
XPUSHs(&PL_sv_undef);
}
}
char *joinId = (char *)NULL;
char joinSep[2] = {AR_ENTRY_ID_SEPARATOR, 0};
for (entry=0; entry < entryFieldValueList.entryList[i].entryId.numItems; entry++) {
joinId = strappend(joinId, entryFieldValueList.entryList[i].entryId.entryIdList[entry]);
if(entry < entryFieldValueList.entryList[i].entryId.numItems-1)
joinId = strappend(joinId, joinSep);
}
XPUSHs(sv_2mortal(newSVpv(joinId, 0)));
}
for (field=0; field < entryFieldValueList.entryList[i].entryValues->numItems; field++) {
sprintf(intstr,"%ld",entryFieldValueList.entryList[i].entryValues->fieldValueList[field].fieldId);
hv_store( fieldValue_hash,
intstr, strlen(intstr),
perl_ARValueStruct(ctrl,&entryFieldValueList.entryList[i].entryValues->fieldValueList[field].value),
0 );
}
XPUSHs( sv_2mortal( newRV_noinc((SV *)fieldValue_hash) ) );
}
getlistentry_end:
FreeAREntryListFieldValueList( &entryFieldValueList,FALSE );
FreeARSortList( &sortList, FALSE );
ARMultiSchemaFieldIdList getListFields;
ARMultiSchemaFieldValueListList entryFieldValueList;
#endif
ARMultiSchemaQualifierStruct qualifierStruct;
ARMultiSchemaSortList sortList;
unsigned int i;
int i2, field_off = 6;
int ret = 0, rv = 0;
HV *hDummy;
/* printf( "\n\n!!!! ars_GetListEntryWithMultiSchemaFields(): experimental implementation, not really working yet !!!!\n\n" ); */
(void) ARError_reset();
#if AR_CURRENT_API_VERSION >= 17
Zero( &queryFromList, 1, ARMultiSchemaFuncQueryFromList );
Zero( &getListFields, 1, ARMultiSchemaFieldFuncList );
Zero( &entryFieldValueList, 1, ARMultiSchemaFieldFuncValueListList );
#else
Zero( &queryFromList, 1, ARMultiSchemaQueryFromList );
Zero( &getListFields, 1, ARMultiSchemaFieldIdList );
Zero( &entryFieldValueList, 1, ARMultiSchemaFieldValueListList );
goto getlistentry_multischema_end;
}
#if AR_CURRENT_API_VERSION >= 17
for( i = 0; i < entryFieldValueList.numItems; ++i ){
HV * fieldValue_hash = newHV();
unsigned int field;
char keyStr[AR_MAX_NAME_SIZE + 1 + 12 + 1 + 12 + 1];
for( field = 0; field < entryFieldValueList.listPtr[i].numItems; ++field ){
ARMultiSchemaFieldFuncValueStruct *valPtr = &(entryFieldValueList.listPtr[i].listPtr[field]);
sprintf( keyStr, "%s.%ld.%ld", valPtr->fieldId.queryFromAlias, valPtr->fieldId.fieldId, valPtr->fieldId.funcId );
hv_store( fieldValue_hash,
keyStr, strlen(keyStr),
perl_ARValueStruct(ctrl, &(valPtr->value)),
0 );
}
XPUSHs( sv_2mortal( newRV_noinc((SV *)fieldValue_hash) ) );
}
#else
for( i = 0; i < entryFieldValueList.numItems; ++i ){
HV * fieldValue_hash = newHV();
unsigned int field;
char keyStr[AR_MAX_NAME_SIZE + 1 + 12 + 1];
for( field = 0; field < entryFieldValueList.listPtr[i].numItems; ++field ){
ARMultiSchemaFieldValueStruct *valPtr = &(entryFieldValueList.listPtr[i].listPtr[field]);
sprintf( keyStr, "%s.%ld", valPtr->fieldId.queryFromAlias, valPtr->fieldId.fieldId );
hv_store( fieldValue_hash,
keyStr, strlen(keyStr),
perl_ARValueStruct(ctrl, &(valPtr->value)),
0 );
}
XPUSHs( sv_2mortal( newRV_noinc((SV *)fieldValue_hash) ) );
}
#endif
getlistentry_multischema_end:
unsigned long whereToWriteMask = AR_WRITE_TO_STATUS_LIST;
unsigned long logTypeMask = logTypeMask_arg;
#endif
int ret;
FILE *logFilePtr = NULL;
(void) ARError_reset();
Zero(&status, 1, ARStatusList);
logFilePtr = get_logging_file_ptr();
/* printf( "GET logging_file_ptr = %p\n", logFilePtr ); */
if( items > 2 && logTypeMask != 0 ){
char *fileName;
STRLEN len;
fileName = SvPV(ST(2),len);
if( logFilePtr != NULL ){
fclose( logFilePtr );
logFilePtr = NULL;
}
whereToWriteMask = AR_WRITE_TO_FILE;
logFilePtr = fopen( fileName, "a" );
if( logFilePtr == NULL ){
char buf[2048];
sprintf( buf, "Cannot open file: %s", fileName );
(void) ARError_add( AR_RETURN_ERROR, AP_ERR_INV_ARGS, buf);
XPUSHs(sv_2mortal(newSViv(0))); /* ERR */
goto SetLogging_fail;
}
set_logging_file_ptr( logFilePtr );
/* printf( "SET logging_file_ptr = %p\n", logFilePtr ); */
}
ret = ARSetLogging( ctrl, logTypeMask, whereToWriteMask, logFilePtr, &status );
if( logTypeMask == 0 && logFilePtr != NULL ){
fclose( logFilePtr );
set_logging_file_ptr( NULL );
}
if(ARError(ret, status)) {
(void) ARError_reset();
Zero(&status, 1, ARStatusList);
variableValue.dataType = AR_DATA_TYPE_INTEGER;
variableValue.u.intVal = value;
if (variableId == 12 || variableId == 13)
{
// just a quick and dirty solution because those variables need to be characters
sprintf(numToCharBuf, "%ld", value);
variableValue.dataType = AR_DATA_TYPE_CHAR;
variableValue.u.charVal = numToCharBuf;
}
ret = ARSetSessionConfiguration( ctrl, variableId, &variableValue, &status );
if(ARError(ret, status)) {
XPUSHs(sv_2mortal(newSViv(0))); /* ERR */
} else {
XPUSHs(sv_2mortal(newSViv(1))); /* OK */
#endif
}
char *
field_cache_key(ctrl)
ARControlStruct * ctrl
CODE:
{
char server_tag[100];
sprintf( server_tag, "%s:%p", ctrl->server, ctrl );
RETVAL = server_tag;
}
OUTPUT:
RETVAL
MODULE = ARS PACKAGE = ARQualifierStructPtr
void
DESTROY(qual)
ARS/CodeTemplate.pm view on Meta::CPAN
my @input = split( /\n/, $input );
my( $pFlag, $pCode, $output ) = ( 0, '', '' );
my $line;
foreach $line ( @input ){
if( $line =~ /^@@\s+(\S+)\s+(.*)$/ ){
my( $openMode, $outFile ) = ( $1, $2 );
if( $outFile =~ /^<@(.*)@>\s*$/ ){
eval( 'package '.caller()."; \$outFile = $1; package ARS::CodeTemplate;" );
# print "OUTFILE: $outFile\n";
}
# print "OM($openMode) FILE($outFile)\n";
die "Syntax error in \"$line\"\n" unless $openMode =~ /^[>|]+$/;
if( defined $opt{debug} ){
print "#------------------------------------------------------------\n";
print "# OUTPUT: $line\n";
print $pCode;
print "#------------------------------------------------------------\n\n";
}else{
eval( 'package '.caller()."; $pCode; package ARWT::Template;" );
if( $@ ){
warn $@, "\n";
exit 1;
}
open( OUTPUT, "$openMode $outFile" ) or die "Open Error($openMode $outFile): $!\n";
print OUTPUT $output;
close OUTPUT;
}
( $pFlag, $pCode, $output ) = ( 0, '', '' );
}elsif( $line =~ s/^@>+// ){
$pCode .= "$line\n";
}else{
$pCode .= '$output .= $LINE_INDENT;';
$pCode .= '$output .= ';
$pCode .= "'' . \"\\n\";\n" if $line eq '';
while( $line ){
ARS/CodeTemplate.pm view on Meta::CPAN
$line =~ s/'/\\'/g;
$pCode .= "'$line' . \"\\n\";\n";
$line = '';
}
}
}
}
}
if( defined $opt{debug} ){
print $pCode;
exit;
}else{
eval( 'package '.caller()."; $pCode; package ARWT::Template;" );
if( $@ ){
warn $@, "\n";
exit 1;
}
}
return $output;
}
ARS/CodeTemplate.pm view on Meta::CPAN
sub procdef {
my( $text ) = @_;
my $outfile;
if( defined $opt{'o'} ){
$outfile = $opt{'o'};
}else{
$outfile = '-';
}
open( OUTFILE, ">$outfile" ) or die "$outfile: $!\n";
print OUTFILE get_header( $outfile, $0 ) if $opt{'o'};
print OUTFILE $text;
close OUTFILE;
}
sub include {
my( $file ) = @_;
local $/ = undef;
local *FILE;
open( FILE, $file ) or do {
warn "Cannot open \"$file\": $!\n";
ARS/OOform.pm view on Meta::CPAN
$connection->tryCatch();
$self->{'fields'} = \%f;
my %rev = reverse %f; # convenient
$self->{'fields_rev'} = \%rev;
my(%t, %enums);
foreach (keys %f) {
print "caching field: $_\n" if $self->{'connection'}->{'.debug'};
my $fv = ARS::ars_GetField($self->{'connection'}->{'ctrl'},
$self->{'form'},
$f{$_});
$connection->tryCatch();
$t{$_} = $fv->{'dataType'};
print "\tdatatype: $t{$_}\n" if $self->{'connection'}->{'.debug'};
if ($fv->{'dataType'} eq "enum") {
if (ref($fv->{'limit'}->{'enumLimits'}) eq "ARRAY") {
my $i = 0;
$enums{$_} = { map { $i++, $_ } @{$fv->{'limit'}->{'enumLimits'}} };
}
elsif (exists $fv->{'limit'}->{'enumLimits'}->{'regularList'}) {
my $i = 0;
$enums{$_} = { map { $i++, $_ } @{$fv->{'limit'}->{'enumLimits'}->{'regularList'}} };
} else {
ARS/OOform.pm view on Meta::CPAN
# query(-query => "qualifier", -maxhits => 100, -firstretrieve => 0)
sub query {
my ($this) = shift;
my ($query, $maxhits, $firstretr) = ARS::rearrange([QUERY,MAXHITS,FIRSTRETRIEVE], @_);
$query = "(1 = 1)" unless defined($query);
$maxhits = 0 unless defined($maxhits);
$firstretr = 0 unless defined($firstretr);
if($this->{'connection'}->{'.debug'}) {
print "form->query(".$this->{'form'}.", $query, ".$this->{'vui'}.")\n";
}
$this->{'qualifier'} =
ARS::ars_LoadQualifier($this->{'connection'}->{'ctrl'},
$this->{'form'},
$query,
$this->{'vui'});
$this->{'connection'}->tryCatch();
my @sortOrder = ();
ARS/OOform.pm view on Meta::CPAN
"usage: form->getFieldType(-field => name, -id => id)\none of the parameters must be specified.");
}
if(defined($name) && !defined($this->{'fieldtypes'}->{$name})) {
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81001,
"field '$name' not in view: ".$this->{'vui'}."\n"
);
}
#print "getFieldType($name, $id)\n" if $this->{'connection'}->{'.debug'};
return $this->{'fieldtypes'}->{$name} if defined($name);
# they didnt give us a name, but instead gave us an id. look up the
# name and return the type.
if(defined($id)) {
my $n = $this->getFieldName(-id => $id);
return $this->{'fieldtypes'}->{$n};
}
ARS/OOform.pm view on Meta::CPAN
unless ref($vals) eq "HASH";
my (%realmap);
# as we work thru each value, we need to perform translations for
# enum fields.
foreach (keys %{$vals}) {
my ($rv) = $this->value2internal(-field => $_,
-value => $vals->{$_});
#print "[form->merge] realval for $_ = $rv\n";
$realmap{$this->getFieldID($_)} = $rv;
}
print "merge/type=$type\n" if $this->{'connection'}->{'.debug'};
my ($rv) = ARS::ars_MergeEntry($this->{'connection'}->{'ctrl'},
$this->{'form'},
$type,
%realmap);
$this->{'connection'}->tryCatch();
# if ($rv is "") and there are no FATAL or ERRORs and
ARS/OOform.pm view on Meta::CPAN
unless ref($vals) eq "HASH";
my (%realmap);
# as we work thru each value, we need to perform translations for
# enum fields.
foreach (keys %{$vals}) {
my ($rv) = $this->value2internal(-field => $_,
-value => $vals->{$_});
#print "realval for $_ = $rv\n";
$realmap{$this->getFieldID($_)} = $rv;
}
my ($rv) = ARS::ars_SetEntry($this->{'connection'}->{'ctrl'},
$this->{'form'},
$entry,
$gettime,
%realmap);
$this->{'connection'}->tryCatch();
ARS/OOform.pm view on Meta::CPAN
my ($f, $v) = ARS::rearrange([FIELD,VALUE], @_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->value2internal(-field => name, -value => value)\nfield parameter is required.")
unless (defined($f));
return $v unless defined $v;
my ($t) = $this->getFieldType($f);
print "value2internal($f, $v) type=$t\n"
if $this->{'connection'}->{'.debug'};
# translate an text value into an enumeration number if this
# field is an enumeration field and we havent been passed a number
# to begin with.
if(($t eq "enum") && ($v !~ /^\d+$/)) {
if(!defined($this->{'fieldEnumValues'}->{$f})) {
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81004,
ARS/OOform.pm view on Meta::CPAN
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->internal2value(-field => name, -id => id, -value => value)\nid or field parameter are required.")
unless (defined($f) || defined($id));
$f = $this->getFieldName(-id => $id) unless defined($f);
my ($t) = $this->getFieldType($f);
print "internal2value($f, $v) type=$t\n"
if $this->{'connection'}->{'.debug'};
# translate an enumeration value into a text value
if($t eq "enum") {
# if the field doesnt exist in our cache, or if the
# enumeration value exceeds the known list of enumerations,
# barf.
return undef unless defined $v;
ARS/OOform.pm view on Meta::CPAN
"usage: form->create(-values => { field1 => value1, ... })\nvalues parameter is required.")
unless defined($vals);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->create(-values => { field1 => value1, ... })\nvalues parameter must be HASH ref.")
unless ref($vals) eq "HASH";
my (%realmap);
print "Mapping field information.\n" if $self->{'connection'}->{'.debug'};
foreach (keys %{$vals}) {
my ($rv) = $this->value2internal(-field => $_,
-value => $vals->{$_});
#print "realval for $_ = $rv\n";
$realmap{$this->getFieldID($_)} = $rv;
}
print "calling ars_CreateEntry..\n" if $self->{'connection'}->{'.debug'};
my ($id) = ARS::ars_CreateEntry($this->{'connection'}->{'ctrl'},
$this->{'form'},
%realmap);
print "calling tryCatch()..\n" if $self->{'connection'}->{'.debug'};
$this->{'connection'}->tryCatch();
return $id;
}
# get(-entry => entryid, -fields => [ field1, field2 ])
sub get {
my $this = shift;
my ($eid, $fields) = ARS::rearrange([ENTRY,[FIELD,FIELDS]],@_);
ARS/OOform.pm view on Meta::CPAN
foreach (@{$fields}) {
push @fieldlist, $this->getFieldID($_);
}
}
# what we want to do is: retrieve all of the values, but for
# certain datatypes (attachments) we want to insert
# an object instead of the field value. for enum types,
# we want to decode the value.
#print "("; print $this->{'form'}; print ", $eid, @fieldlist)\n";
my @v;
if($allfields == 0) {
@v = ARS::ars_GetEntry($this->{'connection'}->{'ctrl'},
$this->{'form'},
$eid, @fieldlist);
} else {
@v = ARS::ars_GetEntry($this->{'connection'}->{'ctrl'},
$this->{'form'},
$eid);
ARS/OOmsgs.pm view on Meta::CPAN
sub messages {
my(%mTypes) = ( 0 => "OK", 1 => "WARNING", 2 => "ERROR", 3 => "FATAL",
4 => "INTERNAL ERROR",
-1 => "TRACEBACK");
my ($this, $type, $str) = (shift, shift, undef);
return $ars_errstr if(!defined($type));
for(my $i = 0; $i < $ARS::ars_errhash{numItems}; $i++) {
if(@{$ARS::ars_errhash{'messageType'}}[$i] == $type) {
$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;
}
ARS/OOsup.pm view on Meta::CPAN
# if we've received a ctrl parameter, then we'll used that
# and ignore the other three parameters. in addition, we'll
# leave it upto the user to call ars_Logoff() since they must've
# called ars_Login() in order to pass us the ctrl parameter.
# this allows the user to mix-and-match OO and non-OO ARS module
# routines with greater ease.
if(defined($ctrl)) {
print "new connection object: reusing existing ctrl struct.\n"
if $self->{'.debug'};
if(ref($ctrl) ne "ARControlStructPtr") {
$self->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"ctrl parameter should be an ARControlStructPtr reference. you passed a ".ref($ctrl)." reference."
);
}
$self->{'ctrl'} = $ctrl;
$self->{'.nologoff'} = 1;
} else {
print "new connection object: ($server, $username, $password)\n"
if $self->{'.debug'};
$self->{'ctrl'} = ars_Login($server, $username, $password, "","", $tcpport);
$self->{'.nologoff'} = 0;
$self->tryCatch();
}
return $blessed;
}
sub DESTROY {
my ($self) = shift;
print "destroying connection object: " if $self->{'.debug'};
if(defined($self->{'.nologoff'}) && $self->{'.nologoff'} == 0) {
print "ars_Logoff called.\n" if $self->{'.debug'};
ars_Logoff($self->{'ctrl'}) if defined($self->{'ctrl'});
} else {
print "ars_Logoff suppressed.\n" if $self->{'.debug'};
}
}
sub ctrl {
my $this = shift;
return $this->{'ctrl'};
}
sub print {
my $this = shift;
my($cacheId, $operationTime, $user, $password, $lang,
$server) = ars_GetControlStructFields($this->{'ctrl'});
print "connection object details:\n";
print "\tcacheId = $cacheId\n";
print "\toperationTime = ".localtime($operationTime)."\n";
print "\tuser = $user\n";
print "\tpassword = $password\n";
print "\tserver = $server\n";
print "\tlang = $lang\n";
}
sub availableSchemas {
my $this = shift;
my ($changedSince, $schemaType, $name) =
rearrange([CHANGEDSINCE,SCHEMATYPE,NAME],@_);
$changedSince = 0 unless defined($changedSince);
$schemaType = ARS::AR_LIST_SCHEMA_ALL unless defined($schemaType);
$name = "" unless defined($name);
ARS/nparm.pm view on Meta::CPAN
# were borrowed from the CGI module. these routines implement
# named parameters.
# (http://stein.cshl.org/WWW/software/CGI/cgi_docs.html)
# Copyright 1995-1997 Lincoln D. Stein. All rights reserved.
sub make_attributes {
my($attr) = @_;
return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
my(@att);
foreach (keys %{$attr}) {
#print "attr=$_\n";
my($key) = $_;
$key=~s/^\-//; # get rid of initial - if present
$key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
}
return @att;
}
# rearrange(order, params)
# order will be an array reference (might contain other array refs)
ARS/nparm.pm view on Meta::CPAN
foreach (@$order) {
if(ref($_) && (ref($_) eq "ARRAY")) {
foreach my $P (@{$_}) {
push @possibilities, $P;
}
} else {
push @possibilities, $_;
}
}
#print "possibilities=".join(',', @possibilities)."\n";
unless (ref($param[0]) eq 'HASH') {
return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');
$param = {@param}; # convert into associative array
} else {
$param = $param[0];
}
my($key)='';
ARS/nparm.pm view on Meta::CPAN
s/^\-//; # get rid of initial - if present
tr/a-z/A-Z/; # parameters are upper case
next if $_ eq $old;
$param->{$_} = $param->{$old};
delete $param->{$old};
}
# scan the keys in param and make sure they are valid.
foreach my $key (keys %$param) {
#print "validating: $key\n";
my (@t) = grep(/^$key$/, @possibilities);
Carp::confess( "invalid named parameter \"$key\"" ) if $#t == -1;
}
my(@return_array);
foreach $key (@$order) {
#print "key=$key\n";
my($value);
# this is an awful hack to fix spurious warnings when the
# -w switch is set.
if (ref($key) && ref($key) eq 'ARRAY') {
foreach (@$key) {
last if defined($value);
$value = $param->{$_};
delete $param->{$_};
}
(GDF) remove unused num_entries parameter from ARGetListEntry
(JCM) added ARTermination calls to ars_Login
Released: 11/13/2001 Version: 1.73
(JCM) fixed windows cpp error in support.c
(JCM) fixed a leftover fprintf warning in support.c that was causing
compilation warnings on windows
(JCM) disabled t/11entry.t
(JCM) minor Makefile.PL tweak
(JCM) bug fix in perl_ARStatusStruct that caused segv with api >= 4.0
Released: 10/24/2001 Version: 1.72
(JCM) added updated doc tree to main distribution (contributed by
{D.J.Adams at soton.ac.uk})
(JCM) new functions and doc on new functions and new examples for some
of these new functions.
(JCM) ! altered return value of perl_ARStatusStruct so that it
returns a hash of the various StatusStruct members so that
reversing the operation is simpler. scripts that, for example,
retrieve active link definitions and print them out that previous
expected the {message} key to point to a string will need to
be updated.
(JCM) added valueType to the assign structure to assist in
reversing the operation (converting perl to C API assign
structure).
(JCM) added displayTag as an optional parameter to ars_LoadQualifier()
so that you can build queries against customized views (that
are stored on the server).
Makefile.PL view on Meta::CPAN
# does, try subscribing to the mailing list and ask for help there.
# subscription information is available at http://www.arsperl.org/
if( $ENV{ARSPERLTEST_PARAM} ){
( $ARSVERSION, $ARSAPI, $ARSPERLTEST_SERVER, $ARSPERLTEST_USERNAME, $ARSPERLTEST_PASSWORD, $ARSPERLTEST_TCPPORT )
= split( /;/, $ENV{ARSPERLTEST_PARAM} );
}
my $ra_arlibs = findArLibs($ARSAPI);
# use Data::Dumper;
# print "found ar libraries: ", Dumper($ra_arlibs);
$ARAPIVERSION = findAPIVersion($ARSAPI);
$ARSVERSION = ARSVersionString($ARAPIVERSION);
$WINDOWS = $^O eq 'MSWin32';
$GNU_WIN = ($^O eq 'MSWin32' || $^O eq 'cygwin') && $Config{'cc'} eq "gcc";
$AUTODEFINES = " -g ";
$AUTODEFINES = " -D_WIN32 " if($WINDOWS);
Makefile.PL view on Meta::CPAN
# e.g for 5.004_03 ..
#
# baserev = 5.0 ( = PERL_REVISION as of 5.6.0)
# PATCHLEVEL = 4
# SUBVERSION = 3 ( = PERL_SUBVERSION as of 5.6.0)
#
# baserev/SUBVERSION still work in 5.6.0, but who knows for how long.
print "Building against perl $]\n";
$AUTODEFINES .= " -DPERL_PATCHLEVEL_IS=$Config{'PATCHLEVEL'} -DPERL_SUBVERSION_IS=$Config{'SUBVERSION'} -DPERL_BASEREV_IS=".($Config{'baserev'}*10)." ";
if($Config{'baserev'} == 5 &&
$Config{'PATCHLEVEL'} == 4 &&
$Config{'SUBVERSION'} == 3) {
print "\n\nWARNING: Perl-5.004_03 contained a buggy 'h2ph' application.\nYou should examine line 100 of perl's 'h2ph' script and be sure that it\n
produces correct syntax (it's missing a close-parenthesis)\n";
print "\nsleeping for 5 seconds. press control-c to abort.\n\n";
sleep 5;
}
if ($LARCH =~ /64/) {
if ($Config{'cc'} =~ /cc/) {
$REDUCE_SYMBOL_SCOPE = 1;
}
else {
print "\n\nWARNING: Because of symbol name collisions (both -- perl and arapi -- use the xdr-functions),\n" .
" it is necessary to reduce the symbol scope to symbols declared within the DSO.\n" .
" ARSPerl wasn't tested on '$Config{'cc'}', if you run into trouble during 'make test'\n" .
" please contact the developer/maintainer!\n\n";
}
}
push(@extras, CAPI => 'TRUE') if ($] >= 5.005 &&
$^O eq 'MSWin32' &&
(($Config{archname} =~ /-object\b/i) ||
($Config{archname} =~ /-multi-thread\b/i))
Makefile.PL view on Meta::CPAN
$ARS_LDPATH = qq{-L"$ARSAPI/lib"};
$INCLUDES = qq{-I"$ARSAPI/include"};
}else{
$ARS_LDPATH = "-L$ARSAPI/lib";
$INCLUDES = "-I$ARSAPI/include";
}
GenerateSupportDotH("support-h.template", $INCLUDES);
print "Generating serverTypeInfoHints.h ..\n";
die "whoops. no file at ".$Config{'perlpath'} unless ( -f $Config{'perlpath'} );
$cmd = qq("$Config{'perlpath'}" infra/exsi.pl < "${ARSAPI}/include/ar.h" > serverTypeInfoHints.h);
$rv = system($cmd);
die "something went wrong when i ran \"$cmd\" (rv = $rv, expected 0)" unless ($rv == 0);
print "Converting C header files to perl modules ..\n";
foreach ("ar", "arerrno") {
my $headerFile = "${ARSAPI}/include/${_}.h";
# # arsystem >= 5.0 doesnt have nt libs/hdrs anymore
# if( ($ARSVERSION >= 5.0) && /^nt/ ) {
# open(FD, "> ARS/${_}-h.pm") || die "open: $!";
# print FD "\# as of ARSystem 5.0, the NT (notifier) routines
## are retired. so this file is just stubbed.
#1;\n";
# close(FD);
# open (FD, "> ARS/artypes.ph") || die "open: $!";
# print FD "\# hackaround for artypes.h. do not remove.\n1;\n";
# close(FD);
# next;
# }
# arsystem <= 6.0.3 doesnt have artypes.h
next if ( ($ARAPIVERSION < ARS_VERSION_63) && /^artypes$/ );
die "couldn't find $headerFile" if (! -e $headerFile);
Makefile.PL view on Meta::CPAN
# # directory incase you never ran h2ph before (as root)
if ($_ eq "artypes") {
$rv = system("$Config{'perlpath'} infra/h2ph -d ./ARS < $headerFile > ARS/${_}.ph");
} else {
$rv = system("$Config{'perlpath'} infra/h2ph -d ./ARS < $headerFile > ARS/${_}-h.pm");
}
# unlink ('ARS/_h2ph_pre.ph');
# open (FD, "> ARS/_h2ph_pre.ph") || die "open: $!";
# print FD "1;\n";
# close(FD);
if((! -e "ARS/${_}-h.pm") || (-z "ARS/${_}-h.pm")) {
open (FD, "> ARS/${_}-h.pm") || die "open: $!";
print FD "\# your perl installation was either missing the 'h2ph'
\# utility or it was not in your path with you ran 'perl Makefile.PL'
1;\n";
close (FD);
}
}
print "Configuring with options:\n";
print "\tARSAPI = $ARSAPI\n";
print "\tARSVERSION = $ARSVERSION\n";
print "\tARAPIVERSION = $ARAPIVERSION\n";
print "\tAUTODEFINES = $AUTODEFINES\n";
die "FATAL: couldn't detect a supported api version!" if ($ARAPIVERSION eq "");
#$PM->{'ARS/_h2ph_pre.ph'} = '$(INST_LIBDIR)/ARS/_h2ph_pre.ph';
WriteMakefile(
'NAME' => 'ARS',
'VERSION_FROM' => 'ARS.pm',
'DISTNAME' => 'ARSperl',
'LICENSE' => 'artistic_1',
'META_MERGE' => {
Makefile.PL view on Meta::CPAN
# don't fiddle with this
'realclean' => {
'FILES' => 'support.h ARS/ar-h.pm ARS/arerrno-h.pm ARS/_h2ph_pre.ph t/config.cache serverTypeInfoHints.h *~ .purify '
}
);
makeTestConfig();
print "
Type 'make' (windows: 'nmake') to build ARSperl.
Type 'make test' to test ARSperl before installing.
Type 'make install' to install ARSperl.
";
exit 0;
# ROUTINE
# GenerateSupportDotH(template-file, includes-dir)
Makefile.PL view on Meta::CPAN
# us translate from code numbers to readable text.
sub GenerateSupportDotH {
my ($tmpl, $incdir) = (shift, shift);
my (@arh);
$incdir =~ s/^-I//g;
$incdir =~ s/^"//;
$incdir =~ s/"$//;
print "Generating support.h file..\n";
die "not a directory ($incdir): $!" if(! -d $incdir);
open(ARH, $incdir."/ar.h") || die "can't open $incdir/ar.h : $!";
@arh = <ARH>;
close(ARH);
open(FD, "> support.h") || die "can't open temporary file: $!";
open(TMPL, $tmpl) || die "can't open template ($tmpl): $!";
print FD "/* THIS FILE WAS AUTOMATICALLY GENERATED BY Makefile.PL */\n";
print FD "/* DO NOT EDIT */\n";
print FD "\n\n";
while(<TMPL>) {
if(/CHARMENUREFRESHCODETYPEMAP/) {
print "\tProcessing AR_MENU_REFRESH codes..\n";
my($line, $code);
foreach $line (grep (/^\#define\s+AR_MENU_REFRESH.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_MENU_REFRESH_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/CHARMENUDDTYPEMAP/) {
print "\tProcessing AR_CHAR_MENU_DD type codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_CHAR_MENU_DD_.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_CHAR_MENU_(\w+)/;
last if ($1 eq "DD_DB_NAME");
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/CHARMENUDDNAMEMAP/) {
print "\tProcessing AR_CHAR_MENU_DD name codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_CHAR_MENU_DD_.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_CHAR_MENU_(\w+)/;
next if ($1 eq "DD_NONE");
next if ($1 eq "DD_FORM");
next if ($1 eq "DD_FIELD");
last if ($1 eq "DD_FORMAT_NONE");
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/CHARMENUDDVALUEMAP/) {
print "\tProcessing AR_CHAR_MENU_DD value format..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_CHAR_MENU_DD_FORMAT_.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_CHAR_MENU_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/CHARMENUTYPEMAP/) {
print "\tProcessing AR_CHAR_MENU codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_CHAR_MENU.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_CHAR_MENU_(\w+)/;
next if ($1 =~ m/^DD_/);
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/STATUSRETURNTYPEMAP/) {
print "\tProcessing AR_RETURN codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_RETURN.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_RETURN_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/SERVERSTATTYPEMAP/) {
print "\tProcessing AR_SERVER_STAT codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_SERVER_STAT.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_SERVER_STAT_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/SCHEMAPERMISSIONTYPEMAP/) {
print "\tProcessing AR_PERMISSIONS (Schema) codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_PERMISSIONS.*/, @arh)) {
$code = (split(/\s/, $line))[1];
# _view & _change are field permissions
# it would be nice if AR_PERM.. differentiated between
# schema and field.
if($code !~ /_VIEW|_CHANGE/) {
print "\t\t$code\n" if $debug;
$code =~ /^AR_PERMISSIONS_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
}
elsif(/FIELDPERMISSIONTYPEMAP/) {
print "\tProcessing AR_PERMISSIONS (Field) codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_PERMISSIONS.*/, @arh)) {
$code = (split(/\s/, $line))[1];
# _visible & _hidden are schema permissions
if($code !~ /_VISIBLE|_HIDDEN/) {
print "\t\t$code\n" if $debug;
$code =~ /^AR_PERMISSIONS_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
}
elsif(/DATATYPEMAP/) {
print "\tProcessing AR_DATA_TYPE codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_DATA_TYPE.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_DATA_TYPE_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/SCHEMATYPEMAP/) {
print "\tProcessing AR_SCHEMA codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_SCHEMA.*/, @arh)) {
# another instance of poor naming conventions
next if $line =~ /_DELETE/;
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_SCHEMA_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/STRUCTITEMTYPEMAP/) {
print "\tProcessing AR_STRUCT_ITEM codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_STRUCT_ITEM.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_STRUCT_ITEM_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/BYTELISTTYPEMAP/) {
print "\tProcessing AR_BYTE_LIST codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_BYTE_LIST.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_BYTE_LIST_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/NOMATCHOPTIONMAP/) {
print "\tProcessing AR_NO_MATCH codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_NO_MATCH.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_NO_MATCH_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/MULTIMATCHOPTIONMAP/) {
print "\tProcessing AR_MULTI_MATCH codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_MULTI_MATCH.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_MULTI_MATCH_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/FUNCTIONMAP/) {
print "\tProcessing AR_FUNCTION codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_FUNCTION.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_FUNCTION_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/CONTAINERTYPEMAP/) {
print "\tProcessing ARCON codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+ARCON.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^ARCON_(\w+)/;
last if ($1 eq "LAST_RESERVED");
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/CONTAINEROWNERMAP/) {
print "\tProcessing ARCONOWNER codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+ARCONOWNER.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^ARCONOWNER_(\w+)/;
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/REFERENCETYPEMAP/) {
print "\tProcessing ARREF codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+ARREF.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^ARREF_(\w+)/;
next if ($1 eq "LAST_SERVER_OBJ");
last if ($1 eq "LAST_RESERVED");
print FD " { $code, \t\t\"\L$1\E\" },\n";
}
}
elsif(/KEYWORDMAP/) {
print "\tProcessing AR_KEYWORD codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_KEYWORD.*/, @arh)) {
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_KEYWORD_(\w+)/;
printf(FD " { %s, \t\t\"\\0\L%s\E\\0\", \t\t%d },\n",
$code, $1, length($1)+2);
}
}
elsif(/SERVERINFOMAP/) {
print "\tProcessing AR_SERVER_INFO codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_SERVER_INFO.*/, @arh)) {
$code = (split(/\s+/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_SERVER_INFO_(\w+)/;
next if ($1 eq "MIN_AUDIT_LOG_FILE_SIZE");
print FD " { $code, \t\"$1\" },\n";
}
}
elsif(/DDEACTIONMAP/) {
print "\tProcessing AR_DDE codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_DDE.*/, @arh))
{
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_DDE_(\w+)/;
print FD " { $code, \t\"\L$1\E\" },\n";
}
}
elsif(/ACTIVELINKACTIONTYPEMAP/) {
print "\tProcessing AR_ACTIVE_LINK_ACTION codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_ACTIVE_LINK_ACTION.*/, @arh))
{
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_ACTIVE_LINK_ACTION_(\w+)/;
last if ($1 eq "OPEN_DLG");
print FD " { $code, \t\"\L$1\E\" },\n";
}
}
elsif(/OPENWINDOWMODEMAP/) {
print "\tProcessing AR_ACTIVE_LINK_ACTION_OPEN codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_ACTIVE_LINK_ACTION_OPEN_.*/, @arh))
{
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_ACTIVE_LINK_ACTION_(\w+)/;
print FD " { $code, \t\"\L$1\E\" },\n";
}
}
elsif(/COMPARMTYPEMAP/) {
print "\tProcessing AR_COM_PARM codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_COM_PARM.*/, @arh))
{
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_COM_PARM_(\w+)/;
print FD " { $code, \t\"\L$1\E\" },\n";
}
}
elsif(/COMMETHODTYPEMAP/) {
print "\tProcessing AR_COM_METHOD codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_COM_METHOD.*/, @arh))
{
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_COM_METHOD_(\w+)/;
print FD " { $code, \t\"\L$1\E\" },\n";
}
}
elsif(/FILTERACTIONTYPEMAP/) {
print "\tProcessing AR_FILTER_ACTION codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_FILTER_ACTION.*/, @arh))
{
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_FILTER_ACTION_(\w+)/;
print FD " { $code, \t\"\L$1\E\" },\n";
}
}
elsif(/SIGNALTYPEMAP/) {
print "\tProcessing AR_SIGNAL codes..\n";
my($code, $line);
foreach $line (grep (/^\#define\s+AR_SIGNAL.*/, @arh))
{
$code = (split(/\s/, $line))[1];
print "\t\t$code\n" if $debug;
$code =~ /^AR_SIGNAL_(\w+)/;
print FD " { $code, \t\"\L$1\E\" },\n";
}
} else {
print FD $_;
}
}
close(TMPL);
close(FD);
print "\n";
}
sub makeTestConfig {
my ($SERVER, $USERNAME, $PASSWORD, $TCPPORT);
my ($S, $U, $P, $T) = ("", "", "", 0);
if(-e "./t/config.cache") {
do './t/config.cache';
$S = &CCACHE::SERVER;
$U = &CCACHE::USERNAME;
$P = &CCACHE::PASSWORD;
$T = &CCACHE::TCPPORT;
}
print "=== ARSperl 'make test' configuration. ===
Please enter the following information. This information will be
recorded in ./t/config.cache
If you want to skip the 'make test' step, just hit ENTER
three times. You can configure it later by either re-running
'perl Makefile.PL' or by editting ./t/config.cache
Fair warning: you probably don't want to run 'make test' against a
production ARSystem server.
";
( $SERVER, $USERNAME, $PASSWORD ) = ( '', '', '' );
print "Server Name [$S]: ";
chomp($SERVER = $ARSPERLTEST_SERVER || <STDIN>);
if($SERVER eq "") {
$SERVER = $S if ($S ne "");
}
print "Admin Username [$U]: ";
chomp($USERNAME = $ARSPERLTEST_USERNAME || <STDIN>);
if($USERNAME eq "") {
$USERNAME = $U if ($U ne "");
}
print "Admin Password [$P]: ";
chomp($PASSWORD = defined($ARSPERLTEST_PASSWORD) ? $ARSPERLTEST_PASSWORD : <STDIN>);
if($PASSWORD eq "") {
$PASSWORD = $P if ($P ne "");
}
print "TCP Port [$T]: ";
chomp($TCPPORT = defined($ARSPERLTEST_TCPPORT) ? $ARSPERLTEST_TCPPORT : <STDIN>);
if($TCPPORT eq "") {
$TCPPORT = $T if ($T ne "");
}
$TCPPORT = 0 if ! $TCPPORT;
#print "Storing $SERVER / $USERNAME / $PASSWORD ..\n";
open (FD, "> ./t/config.cache") || die "open failed: $!";
print FD "package CCACHE;\n";
print FD "\# enter your server, admin username and password below.\n\n";
print FD "sub SERVER { \"$SERVER\" ; }\n";
print FD "sub USERNAME { \"$USERNAME\" ; }\n";
print FD "sub PASSWORD { \"$PASSWORD\" ; }\n";
print FD "sub TCPPORT { $TCPPORT ; }\n";
print FD "1;\n";
close(FD);
}
#
# given a path to the Api directory, go find ar.h and parse the value
# of the AR_CURRENT_API_VERSION #define and return it.
# if the path to ar.h is, e.g.,
StructDef.pl view on Meta::CPAN
# _type => 'int',
# _data => 'p->dataType',
# },
#},
);
# perl C:\usr\perl_install\5.8.8\ARSperl\TS\printStructTemplate.pl AR...
#
# x => {
# _type => '',
# _data => '',
# },
# s/.*/$& => {\n\t_type => '',\n\t_data => 'p->u.',\n},/
%TEMPLATES = (
StructDef.pl view on Meta::CPAN
'AR\w+\*' => '%L = perl_%B( ctrl, %R )',
'(int|long|unsigned\s+int|unsigned\s+long)' => '%L = newSViv( %R )',
'(float|double)' => '%L = newSVnv( %R )',
'char\s*\*' => '%L = newSVpv( %R, 0 )',
'char\[.+]' => '%L = newSVpv( %R, 0 )',
],
);
#print evalTemplate( 'COPY', 'char[10]', 'p->charVal', 'buffer' ), "\n";
#print evalTemplate( 'COPY', 'unsigned char', 'p->unique', 'buffer' ), "\n";
#ARIntegerLimitsStruct intLimits;
#ARRealLimitsStruct realLimits;
#ARCharLimitsStruct charLimits;
#ARDiaryLimitsStruct diaryLimits;
#AREnumLimitsStruct enumLimits;
#AREnumLimitsStruct maskLimits;
#ARAttachLimitsStruct attachLimits;
#ARTableLimitsStruct tableLimits;
changes.dat view on Meta::CPAN
ars_GetCharMenu()
</blockquote>
released=11/13/2002 version=1.74
GDF added ars_GetMultipleEntries, ars_GetListEntryWithFields
GDF remove unused num_entries parameter from ARGetListEntry
JCM added ARTermination calls to ars_Login
released=11/13/2001 version=1.73
JCM fixed windows cpp error in support.c
JCM fixed a leftover fprintf warning in support.c that was causing
compilation warnings on windows
JCM disabled t/11entry.t
JCM minor Makefile.PL tweak
JCM bug fix in perl_ARStatusStruct that caused segv with api >= 4.0
released=10/24/2001 version=1.72
JCM modified Makefile.PL to handle changes to _SERVER_INFO definitions
in 4.5.x
JCM memory leak fixes
JCM duplicate free badness in ars_Login() fixed
changes.dat view on Meta::CPAN
JCM added $VERSION to the perl module file.
JCM added "log to file" action to GetFilter action hash
(requested by {D.J.Adams at soton.ac.uk})
JCM added updated doc tree to main distribution (contributed by
{D.J.Adams at soton.ac.uk})
JCM new functions and doc on new functions and new examples for some
of these new functions.
!JCM altered return value of perl_ARStatusStruct so that it
returns a hash of the various StatusStruct members so that
reversing the operation is simpler. scripts that, for example,
retrieve active link definitions and print them out that previous
expected the {message} key to point to a string will need to
be updated.
JCM added valueType to the assign structure to assist in
reversing the operation (converting perl to C API assign
structure).
JCM added displayTag as an optional parameter to ars_LoadQualifier()
so that you can build queries against customized views (that
are stored on the server).
JCM altered ARError() so that return codes of OK or WARNING don't
signal an error. For example, GetListEntries would return
example/AddUsersToGroup.pl view on Meta::CPAN
# Fetch the values for this record:
( my %groupvalues = ars_GetEntry( $ctrl, "Group", $groupentry[0] ) )
|| die "ars_GetEntry(Group): $ars_errstr";
# We are only interested in the field marked Group ID:
my $group_id = $groupvalues{ $groupfields{'Group ID'} };
# This loop will process all users one by one, see if they are already a member of the group specified,
# if neccesary we add them to the group by changing the Group List and writing it back.
foreach (@users) {
print "Adding $_ to $group .. \n";
# Create a qualifier to retrieve the Entry ID for this user
( my $userqualifier =
ars_LoadQualifier( $ctrl, "User", "'Login Name' = \"$_\"" ) )
|| die "ars_LoadQualifier: $ars_errstr";
# Fetch the EID for this user; if there is no such user, say so and continue with next user
# ars_GetListEntry provides a list with Entry-Id, Short description pairs
# In this case only one pair. That means $userentry[0] will contain the actual Entry ID.
my @userentry = ars_GetListEntry( $ctrl, "User", $userqualifier, 0, 0, );
# If there is no record for this user, say so and conitue with the next one
if ( !@userentry ) { print "No user $_\n"; next; }
# Get the value of the Group List field. Syntax = ars_GetEntry(ctrl, schema, eid [field ID...n])
# so in this case we only get the value returned for one field ID, the Group List
# If you do not specify field ID's, you will get all values for the whole entry.
my %uservalues =
ars_GetEntry( $ctrl, "User", $userentry[0], $userfields{'Group List'} );
# Get the field values for this entry
# set $currentgrouplist to the contents of the Group List field
my $currentgrouplist = $uservalues{ $userfields{'Group List'} };
#if the Group List already contains the group, say so and continue with next user
if (
(
( $currentgrouplist =~ /^$group_id;/ )
|| ( $currentgrouplist =~ /;$group_id;/ )
)
)
{
print "\talready a member of $group\n";
next;
}
# add the new group to the group list, or if the group list is empty just let the new list contain only the new group.
my $newgrouplist;
if ($currentgrouplist) {
print "\tcurrent group list: $currentgrouplist\n";
$newgrouplist = $currentgrouplist . "$group_id;";
}
else {
print "\tno groups were assigned to this user.\n";
$newgrouplist = "$group_id;";
}
print "\tnew group list : $newgrouplist\n";
# write the entry back using SetEntry
ars_SetEntry( $ctrl, "User", $userentry[0], 0, $userfields{'Group List'},
$newgrouplist )
|| die "ars_SetEntry(User): $ars_errstr";
}
# and of course log off nicely.
ars_Logoff($ctrl);
example/ChangePassword.pl view on Meta::CPAN
|| die "ars_LoadQualifier(User): $ars_errstr";
# fetch the Entry ID for this user by using GetListEntry with the qualifier we
# just specified, otherwise die.
my @userentry = ars_GetListEntry( $ctrl, "User", $userqualifier, 0, 0 );
die "No such user $user? ($ars_errstr)\n" if ( $#userentry == -1 );
# Change the password for this user by setting field 102 (the password field) with the new value
ars_SetEntry( $ctrl, "User", $userentry[0], 0, 102, $newpassword )
|| die "Error updating password: $ars_errstr";
print "Password changed for user $user on server $server\n";
example/DelUsersFromGroup.pl view on Meta::CPAN
($q = ars_LoadQualifier($c, "Group", "'Group name' = \"$group\"")) ||
die "ars_LoadQualifier(Group): $ars_errstr";
@e = ars_GetListEntry($c, "Group", $q, 0);
die "No such group \"$group\"? ($ars_errstr)\n" if ($#e == -1);
(%v = ars_GetEntry($c, "Group", $e[0])) ||
die "ars_GetEntry(Group): $ars_errstr";
$group_id = $v{$gf{'Group id'}};
foreach (@users) {
print "Adding $_ to $group .. \n";
($q = ars_LoadQualifier($c, "User", "'Login name' = \"$_\"")) ||
die "ars_LoadQualifier: $ars_errstr";
@e = ars_GetListEntry($c, "User", $q, 0);
die "No User record for $_? ($ars_errstr)\n" if ($#e == -1);
(%v = ars_GetEntry($c, "User", $e[0])) ||
die "ars_GetEntry: $ars_errstr";
$cg = $v{$uf{'Group list'}};
if(($cg =~ /^$group_id;/) || ($cg =~ /\s$group_id;/)) {
print "\tcurrent group list: $cg\n";
if($cg =~ /^$group_id;/) {
$cg =~ s/^$group_id;//g;
}
elsif($cg =~ /\s$group_id/) {
$cg =~ s/\s$group_id;//g;
}
print "\tnew group list : $cg\n";
ars_SetEntry($c, "User", $e[0], 0, $uf{'Group list'}, $cg) ||
die "ars_SetEntry(User): $ars_errstr";
} else {
print "\tnot a member of $group\n";
next;
}
}
ars_Logoff($c);
exit 0;
example/Dump_Setup.pl view on Meta::CPAN
if (! -d "$path") {
mkdir "$path", $perm || die "can't create directory $path";
mkdir "$path/RCS", $perm || die "can't create directory $path/RCS";
}
foreach $name (@$names) {
$val = ars_Export($c,"",$type,$name);
$val =~ s/^#.*/#/gm; # get rid of comments with export date
$name = name_to_path($name);
open DUMP, "> $path/$name" || die "can't write file $path/$name";
print DUMP $val;
close DUMP;
$name =~ s/'/'\\''/;
system("$ci -l -q '$path/$name'");
}
}
dump_type("$path/schema", "Schema", \@schema);
dump_type("$path/active", "Active_Link", \@active);
dump_type("$path/filter", "Filter", \@filter);
dump_type("$path/escalation", "Escalation", \@escal);
example/Dump_Users.pl view on Meta::CPAN
use ARS;
use strict;
my $SCHEMA = "User";
# Parse command line parameters
my ( $server, $username, $password ) = @ARGV;
if ( !defined($password) ) {
print "usage: $0 [server] [username] [password]\n";
exit 1;
}
# Log onto the ars server specified
( my $ctrl = ars_Login( $server, $username, $password ) )
|| die "can't login to the server: $ars_errstr";
# Load the qualifier structure with a dummy qualifier.
example/Dump_Users.pl view on Meta::CPAN
&ARS::AR_SORT_ASCENDING );
die "No entries found in User schema? [$ars_errstr]"
if $#entries == -1;
( my $fullname_fid = ars_GetFieldByName( $ctrl, $SCHEMA, "Full Name" ) )
|| die "no such field in this schema: 'Full Name'";
# Loop over all of the entries (in ascending order)
printf( "%-30s %-45s\n", "Login name", "Full name" );
for ( my $i = 0 ; $i <= $#entries ; $i += 2 ) {
#foreach $entry_id (sort keys %entries) {
# Retrieve the (fieldid, value) pairs for this entry
my %e_vals = ars_GetEntry( $ctrl, $SCHEMA, $entries[$i] );
# Print out the Login name and Full name for each record
printf( "%-30s %-45s\n", $e_vals{$loginname_fid}, $e_vals{$fullname_fid} );
}
# Log out of the server.
ars_Logoff($ctrl);
example/Dump_Users_OO.pl view on Meta::CPAN
use strict;
use ARS;
require Carp;
sub mycatch {
my $type = shift;
my $msg = shift;
my $trace = shift;
print "i caught an exception:\ntype=$type msg=$msg\ntraceback:\n$trace\n";
exit;
}
my $LoginNameField = "Login name"; # earlier versions of ars used "Login Name"
my $connection = new ARS (-server => shift,
-username => shift,
-password => shift,
-catch => { ARS::AR_RETURN_ERROR => "main::mycatch" },
-ctrl => undef,
-debug => undef);
print "Opening \"User\" form ..\n";
my ($u) = $connection->openForm(-form => "User");
$u->setSort($LoginNameField, &ARS::AR_SORT_ASCENDING);
my @entries = $u->query(); # empty query means "get everything"
printf("%-30s %-45s\n", $LoginNameField, "Full name");
foreach my $id (@entries) {
my($fullname, $loginname) = $u->get($id, ['Full Name', $LoginNameField] );
printf("%-30s %-45s\n", $loginname, $fullname);
}
exit 0;
example/GetCharMenu.pl view on Meta::CPAN
#
# $Header: /cvsroot/arsperl/ARSperl/example/GetCharMenu.pl,v 1.8 2003/03/28 05:51:56 jcmurphy Exp $
#
# NAME
# GetCharMenu.pl
#
# USAGE
# GetCharMenu.pl [server] [username] [password] [menuname]
#
# DESCRIPTION
# Retrieve and print information about the named menu.
#
# AUTHOR
# Jeff Murphy
# jcmurphy@acsu.buffalo.edu
#
# $Log: GetCharMenu.pl,v $
# Revision 1.8 2003/03/28 05:51:56 jcmurphy
# more 5.x edits
#
# Revision 1.7 2001/10/24 14:21:27 jcmurphy
example/GetCharMenu.pl view on Meta::CPAN
# Revision 1.6 2000/05/24 18:05:26 jcmurphy
# primary ars4.5 integration in this checkpoint.
#
# Revision 1.5 1998/10/14 13:55:34 jcmurphy
# fixed syntax error
#
# Revision 1.4 1998/09/16 14:38:31 jcmurphy
# updated changeDiary code
#
# Revision 1.3 1998/02/25 19:21:32 jcmurphy
# updated to printout query if query style menu
#
# Revision 1.2 1997/11/10 23:36:52 jcmurphy
# added refreshCode to the output
#
# Revision 1.1 1996/11/21 20:13:51 jcmurphy
# Initial revision
#
#
use ARS;
require 'ars_QualDecode.pl';
# SUBROUTINE
# printl
#
# DESCRIPTION
# prints the string after printing X number of tabs
sub printl {
my $t = shift;
my @s = @_;
if(defined($t)) {
for( ; $t > 0 ; $t--) {
print "\t";
}
print @s;
}
}
($server, $username, $password, $name) = @ARGV;
if(!defined($name)) {
print "Usage: $0 [server] [username] [password] [menuname]\n";
exit 0;
}
$ctrl = ars_Login($server, $username, $password);
print "Calling ars_GetCharMenu($ctrl, $name)..\n";
($finfo = ars_GetCharMenu($ctrl, $name)) ||
die "error in GetCharMenu: $ars_errstr";
# 10005
print "Calling ars_GetCharMenuItems($ctrl, $name)..\n";
my ($menuItems) = ars_GetCharMenuItems($ctrl, $name);
die "$ars_errstr\n" unless defined($menuItems);
print "menuItems=<<$menuItems>> (should be an array ref)\n";
die "hmm. that wasnt an array ref." unless ref ($menuItems) eq "ARRAY";
print "** Menu Info:\n";
print "Name : \"".$finfo->{"name"}."\"\n";
print "helpText : ".$finfo->{"helpText"}."\n";
print "timestamp : ".localtime($finfo->{"timestamp"})."\n";
print "owner : ".$finfo->{"owner"}."\n";
print "lastChanged : ".$finfo->{"lastChanged"}."\n";
print "changeDiary : ".$finfo->{"changeDiary"}."\n";
foreach (@{$finfo->{"changeDiary"}}) {
print "\tTIME: ".localtime($_->{"timestamp"})."\n";
print "\tUSER: $_->{'user'}\n";
print "\tWHAT: $_->{'value'}\n";
}
print "refreshCode : ".$finfo->{"refreshCode"}."\n";
print "menuType : ".$finfo->{"menuType"}."\n";
if($finfo->{menuType} eq "query") {
ARS::insertValueForCurrentTransaction($ctrl,
$finfo->{'menuQuery'}{'schema'},
$finfo->{'menuQuery'}{'qualifier'});
print "menuQuery definitions:\n";
print "\tschema : ".$finfo->{menuQuery}{schema}."\n";
print "\tserver : ".$finfo->{menuQuery}{server}."\n";
print "\tlabelField : ".$finfo->{menuQuery}{labelField}."\n";
print "\tvalueField : ".$finfo->{menuQuery}{valueField}."\n";
print "\tsortOnLabel : ".$finfo->{menuQuery}{sortOnLabel}."\n";
print "\tquery : ".$finfo->{menuQuery}{qualifier}."\n";
$dq = ars_perl_qualifier($ctrl, $finfo->{menuQuery}{qualifier});
$qualtext = ars_Decode_QualHash($ctrl,
$finfo->{menuQuery}{schema},
$dq);
print "\t$qualtext\n";
}
elsif($finfo->{menuType} eq "file") {
print "menuFile definitions:\n";
print "\tfileLocation : ".("", "Server", "Client")[$finfo->{menuFile}{fileLocation}]."\n";
print "\tfilename : ".$finfo->{menuFile}{filename}."\n";
}
elsif($finfo->{menuType} eq "sql") {
print "menuSQL definitions:\n";
print "\tserver : ".$finfo->{menuSQL}{server}."\n";
print "\tsqlCommand : ".$finfo->{menuSQL}{sqlCommand}."\n";
print "\tlabelIndex : ".$finfo->{menuSQL}{labelIndex}."\n";
print "\tvalueIndex : ".$finfo->{menuSQL}{valueIndex}."\n";
}
print "Menu Items :\n";
printMenuItems(1, $menuItems);
print "Simple Menu : (with 'prepend' = false)\n";
print "\t", join("\n\t", ars_simpleMenu($menuItems, 0)), "\n";
print "Simple Menu : (with 'prepend' = true)\n";
print "\t", join("\n\t", ars_simpleMenu($menuItems, 1)), "\n";
ars_Logoff($ctrl);
exit 0;
sub printMenuItems {
my ($l, $m) = (shift, shift);
my ($i) = 0;
for ($i = 0 ; $i <= $#$m ; $i += 2) {
printl($l, $m->[$i]);
if(ref($m->[$i+1]) eq "ARRAY") {
print "\n";
printMenuItems($l+1, $m->[$i+1]);
} else {
print " -> ".$m->[$i+1]."\n";
}
}
}
example/GetField.pl view on Meta::CPAN
# 02/19/97
#
# $Log: GetField.pl,v $
# Revision 1.5 2009/03/31 13:34:32 mbeijen
# Verified and updated examples.
# Removed ars_GetFullTextInfo.pl because ars_GetFullTextInfo is obsolete since ARS > 6.01
#
# Revision 1.4 1998/09/11 14:46:18 jcmurphy
# altered script logic so that it figures out whether it
# should decode a hash or array on the fly.
# fixed typo that was causing arrays not to be printed.
#
# Revision 1.3 1997/11/26 20:05:54 jcmurphy
# nada
#
# Revision 1.2 1997/05/07 15:38:19 jcmurphy
# fixed incorrect hash usage
#
# Revision 1.1 1997/02/19 22:41:16 jcmurphy
# Initial revision
#
#
#
use ARS;
use strict;
# Parse command line parameters
my ( $server, $username, $password, $schema, $fieldname ) = @ARGV;
if ( !defined($fieldname) ) {
print "usage: $0 [server] [username] [password] [schema] [fieldname]\n";
exit 1;
}
# Log onto the ars server specified
print "Logging in ..\n";
( my $ctrl = ars_Login( $server, $username, $password ) )
|| die "can't login to the server";
# Fetch all of the fieldnames/ids for the specified schema
print "Fetching field table ..\n";
( my %fids = ars_GetFieldTable( $ctrl, $schema ) )
|| die "GetFieldTable: $ars_errstr";
# See if the specified field exists.
if ( !defined( $fids{$fieldname} ) ) {
print "ERROR: I couldn't find a field called \"$fieldname\" in the
Default Admin View of schema \"$schema\"\n";
exit 0;
}
# Get the field info
print "Fetching field information ..\n";
( my $fieldInfo = ars_GetField( $ctrl, $schema, $fids{$fieldname} ) )
|| die "GetField: $ars_errstr";
print "Here are some of the field attributes. More are available.
fieldId: $fieldInfo->{fieldId}
createMode: $fieldInfo->{createMode}
dataType: $fieldInfo->{dataType}
defaultVal: $fieldInfo->{defaultVal}
owner: $fieldInfo->{owner}
";
dumpKV( $fieldInfo, 0 );
ars_Logoff($ctrl);
exit 0;
sub dumpKV {
my $hr = shift;
my $i = shift;
foreach my $k ( keys %$hr ) {
print "\t" x $i . "key=<$k> val=<$hr->{$k}>\n";
if ( ref( $hr->{$k} ) eq "HASH" ) {
dumpKV( $hr->{$k}, $i + 1 );
}
elsif ( ref( $hr->{$k} ) eq "ARRAY" ) {
dumpAV( $hr->{$k}, $i + 1 );
}
}
}
sub dumpAV {
my $ar = shift;
my $i = shift;
my $a = 0;
foreach (@$ar) {
print "\t" x $i . "index=<$a> val=<$_>\n";
if ( ref($_) eq "HASH" ) {
dumpKV( $_, $i + 1 );
}
elsif ( ref($_) eq "ARRAY" ) {
dumpAV( $_, $i + 1 );
}
$a++;
}
example/GetFilter.pl view on Meta::CPAN
#
# $Header: /cvsroot/arsperl/ARSperl/example/GetFilter.pl,v 1.9 2003/04/02 01:43:35 jcmurphy Exp $
#
# NAME
# GetFilter.pl
#
# USAGE
# GetFilter.pl [server] [username] [password] [filtername]
#
# DESCRIPTION
# Retrieve and print information about the named filter.
#
# AUTHOR
# Jeff Murphy
# jcmurphy@acsu.buffalo.edu
#
# $Log: GetFilter.pl,v $
# Revision 1.9 2003/04/02 01:43:35 jcmurphy
# mem mgmt cleanup
#
# Revision 1.8 2000/06/01 16:54:03 jcmurphy
example/GetFilter.pl view on Meta::CPAN
use ARS;
@MessageTypes = ( "Note", "Warn", "Error" );
$debug = 0;
require 'ars_QualDecode.pl';
# SUBROUTINE
# printl
#
# DESCRIPTION
# prints the string after printing X number of tabs
sub printl {
my $t = shift;
my @s = @_;
if(defined($t)) {
for( ; $t > 0 ; $t--) {
print "\t";
}
print @s;
}
}
($server, $username, $password, $filtername) = @ARGV;
if(!defined($filtername)) {
print "Usage: $0 [server] [username] [password] [filtername]\n";
exit 0;
}
$AR_OPERATION_GET = 1;
$AR_OPERATION_SET = 2;
$AR_OPERATION_CREATE = 4;
$AR_OPERATION_DELETE = 8;
$AR_OPERATION_MERGE = 16;
%ars_opSet = (
example/GetFilter.pl view on Meta::CPAN
$AR_OPERATION_SET, "Modify",
$AR_OPERATION_CREATE, "Create",
$AR_OPERATION_DELETE, "Delete",
$AR_OPERATION_MERGE, "Merge"
);
$ctrl = ars_Login($server, $username, $password);
($finfo = ars_GetFilter($ctrl, $filtername)) ||
die "error in GetFilter: $ars_errstr";
print "\n\nerrstr contains \"$ars_errstr\"\n\n" if ($ars_errstr ne "");
print "** Filter Info:\n";
print "Name : \"".$finfo->{"name"}."\"\n";
print "Order : ".$finfo->{"order"}."\n";
if(defined($finfo->{'schema'})) {
print "Schema : \"".$finfo->{"schema"}."\"\n";
}
elsif(defined($finfo->{'schemaList'})) {
print "schemaList : ";
foreach my $s (@{$finfo->{'schemaList'}}) {
print "\"$s\" ";
}
print "\n";
}
print "opSet : ".Decode_opSetMask($finfo->{"opSet"})."\n";
print "Enable : ".$finfo->{"enable"}."\n";
if(defined($finfo->{'query'})) {
$dq = ars_perl_qualifier($ctrl, $finfo->{"query"});
$dq = undef if(isempty($dq));
} else {
$dq = undef;
}
if(defined($finfo->{'schema'})) {
if(defined($dq)) {
$qualtext = ars_Decode_QualHash($ctrl, $finfo->{"schema"}, $dq);
print "Query : ".$qualtext."\n";
} else {
print "Query : [none defined]\n";
}
}
elsif(defined($finfo->{'schemaList'})) {
if(defined($dq)) {
foreach my $s (@{$finfo->{'schemaList'}}) {
$qualtext = ars_Decode_QualHash($ctrl, $s, $dq);
print "Query decoded against form \"$s\" : ".$qualtext."\n";
}
} else {
print "Query : [none defined]\n";
}
}
print "actionList : \n";
ProcessActions(@{$finfo->{actionList}});
print "helpText : \"".$finfo->{"helpText"}."\"\n";
print "timestamp : ".localtime($finfo->{"timestamp"})."\n";
print "owner : ".$finfo->{"owner"}."\n";
print "lastChanged : ".$finfo->{"lastChanged"}."\n";
print "changeDiary : ".$finfo->{"changeDiary"}."\n";
foreach (@{$finfo->{"changeDiary"}}) {
print "\tTIME: ".localtime($_->{"timestamp"})."\n";
print "\tUSER: $_->{'user'}\n";
print "\tWHAT: $_->{'value'}\n";
}
ars_Logoff($ctrl);
exit 0;
# Most of these subroutines were taken directly from Show_ALink.pl
# SUBROUTINE
# PrintArith
#
# DESCRIPTION
# Attempt to "pretty print" the arith expression (just for
# the hell of it)
#
# NOTES
# Notic that parenthesis are printed, although they are not
# explicitly part of the node information. They are derived
# from the ordering of the tree, instead. If you want to actually
# *evaluate* the expression, you will have to derive the
# parenthetical encoding from the tree ordering.
#
# Here is an example equation and how it is encoded:
#
# ((10 + 2) / 3)
#
# "/"
example/GetFilter.pl view on Meta::CPAN
#
# THOUGHTS
# I don't know if this routine will work for all cases.. but
# i did some tests and it looked good. Ah.. i just wrote it
# for the fun of it.. so who cares? :)
sub PrintArith {
my $a = shift;
PrintArith_Recurs($a, 0);
print "\n";
}
sub PrintArith_Recurs {
my $a = shift;
my $p = shift;
my $n, $i;
if(defined($a)) {
$n = $a->{left};
if(defined($n)) {
if(defined($n->{arith})) {
PrintArith_Recurs($n->{arith}, $p+1);
} else {
for($i=1;$i<$p;$i++) {
print " ( ";
}
}
print " ( $n->{value} " if defined($n->{value});
print " ( \$$n->{field}->{fieldId}\$ " if defined($n->{field});
print " ( $n->{function} " if defined($n->{function});
}
print " $a->{oper} ";
$n = $a->{right};
if(defined($n)) {
print " $n->{value} ) " if defined($n->{value});
print " \$$n->{field}->{fieldId}\$ ) " if defined($n->{field});
PrintArith_Recurs($n->{arith}) if defined($n->{arith});
print " $n->{function} ) " if defined($n->{function});
}
}
}
# SUBROUTINE
# ProcessArithStruct
#
# DESCRIPTION
# This routine breaks down the arithmetic structure
sub ProcessArithStruct {
my $a = shift;
my $n;
if(defined($a)) {
printl 5, "Operation: $a->{oper}\n";
$n = $a->{left};
if(defined($n)) {
# printl 5, "(Left) ";
printl 5, "Value: \"$n->{value}\"\n" if defined($n->{value});
printl 5, "Field: \$$n->{field}->{fieldId}\$\n" if defined($n->{field});
printl 5, "Process: $n->{process}\n" if defined($n->{process});
ProcessArithStruct($n->{arith}) if defined($n->{arith});
printl 5, "Function: $n->{function}\n" if defined($n->{function});
printl 5, "DDE: DDE not supported in ARSperl\n" if defined($n->{dde});
}
$n = $a->{right};
if(defined($n)) {
# printl 5, "(Right) ";
printl 5, "Value: \"$n->{value}\"\n" if defined($n->{value});
printl 5, "Field: \$$n->{field}->{fieldId}\$\n" if defined($n->{field});
printl 5, "Process: $n->{process}\n" if defined($n->{process});
ProcessArithStruct($n->{arith}) if defined($n->{arith});
printl 5, "Function: $n->{function}\n" if defined($n->{function});
printl 5, "DDE: DDE not supported in ARSperl\n" if defined($n->{dde});
}
}
}
# SUBROUTINE
# ProcessFunctionList
#
# DESCRIPTION
# Parse and dump the function list structure.
sub ProcessFunctionList {
my $t = shift; # how much indentation to use
my @func = @_;
my $i;
printl $t, "Function Name: \"$func[0]\" .. Num of args: $#func\n";
# we need to process all of the arguments listed.
for($i=1;$i<=$#func;$i++) {
printl $t+1, "Value: \"$func[$i]->{value}\"\n" if defined($func[$i]->{value});
printl $t+1, "Field: \$$func[$i]->{field}->{fieldId}\$\n" if defined($func[$i]->{field});
printl $t+1, "Process: $func[$i]->{process}\n" if defined($func[$i]->{process});
PrintArith($func[$i]->{arith}) if defined($func[$i]->{arith});
# if the arg is a pointer to another function, we need to process
# it recursively.
if(defined($func[$i]->{function})) {
ProcessFunctionList($t+1, @{$func[$i]->{function}});
}
printl $t+1, "DDE: DDE not supported in ARSperl\n" if defined($func[$i]->{dde});
}
}
# SUBROUTINE
# ProcessSetFields
#
# DESCRIPTION
# This routine dumps the various forms of the Set Fields
# action in active links.
sub ProcessSetFields {
my $field = shift;
if(defined($field->{sql})) {
printl 3, "SQL:\n";
printl 4, "server: $field->{sql}->{server}\n";
printl 4, "sqlCommand: $field->{sql}->{sqlCommand}\n";
printl 4, "valueIndex: $field->{sql}->{valueIndex}\n";
}
if(defined($field->{valueType})) {
printl 3, "valueType: $field->{valueType}\n";
}
if(defined($field->{none})) {
printl 3, "No set fields instructions found.\n";
}
if(defined($field->{value})) {
printl 3, "Value: \$$field->{value}\$\n";
}
if(defined($field->{field})) {
printl 3, "Field Assign: $field->{field}\n";
foreach (keys %{$field->{field}}) {
if(($_ ne "qualifier") && ($_ ne "schema")) {
printl 4, "$_: $field->{field}->{$_}\n";
}
}
my($dq) = ars_perl_qualifier($ctrl, $field->{field}->{qualifier});
my($qt) = ars_Decode_QualHash($ctrl, $field->{field}->{schema}, $dq);
printl 4, "Qualification:\n";
printl 5, "schema= ".$field->{'field'}->{'schema'}."\n";
printl 5, "query = $qt\n";
}
if(defined($field->{process})) {
printl 3, "Process: $field->{process}\n";
}
if(defined($field->{arith})) {
printl 3, "Arithmetic:\n";
# ProcessArithStruct($field->{arith});
printl 4, "Expression: ";
PrintArith($field->{arith});
}
if(defined($field->{function})) {
printl 3, "Function:\n";
ProcessFunctionList(4, @{$field->{function}});
}
if(defined($field->{dde})) {
printl 3, "DDE not implemented in ARSperl.\n";
}
}
# SUBROUTINE
# ProcessActions
#
# DESCRIPTION
# this routine processes the list of actions for this filter,
# deciding what actions are defined and dumping the appropriate
# information.
#
# AUTHOR
# jeff murphy
sub ProcessActions {
my @actions = @_;
if(defined(@actions)) {
$act_num = 1;
foreach $action (@actions) {
printl 1, "Action $act_num:\n";
if(defined($action->{assign_fields})) {
printl 2, "Set Fields:\n";
foreach $setFields (@{$action->{assign_fields}}) {
printl 3, "fieldId: $setFields->{fieldId}\n";
ProcessSetFields($setFields->{assignment});
}
}
if(defined($action->{message})) {
# message text is formatted as:
#
# Type X Num XXXXX Text [XXXXXX...]
# messageNum messageType messageText
$action->{message} =~
/Type\ ([0-9]+)\ Num\ ([0-9]+)\ Text \[(.*)\]/;
printl 2, "Message: (raw=\"$action->{'message'}\")\n";
#print "keys ", keys %{$action->{'message'}}, "\n";
printl 3, "Type: ",$MessageTypes[$action->{'message'}->{'messageType'}],"\n";
printl 3, "Num: $action->{'message'}->{'messageNum'}\n";
printl 3, "Text: $action->{'message'}->{'messageText'}\n";
}
if(defined($action->{process})) {
printl 2, "Process: ".$action->{process}."\n";
}
if(defined($action->{notify})) {
printl 2, "Notify:\n";
printl 3, "user: $action->{notify}{user}\n";
printl 3, "notifyMechanism: ".
("Notifier", "E-Mail", "User Default", "Cross Ref",
"Other")[$action->{notify}{notifyMechanism}-1]."\n";
printl 3, "notifyMechanismXRef: $action->{notify}{notifyMechanismXRef}\n";
printl 3, "subjectText: $action->{notify}{subjectText}\n";
printl 3, "notifyText: $action->{notify}{notifyText}\n";
printl 3, "fieldIdListType: ".
("None", "List", "Changed", "All")
[$action->{notify}{fieldIdListType}-1]."\n";
printl 3, "Field List: $action->{notify}{fieldList}\n";
foreach $fid (@{$action->{notify}{fieldList}}) {
printl 4, "$fid\n";
}
}
if(defined($action->{none})) {
printl 2, "No actions specified.\n";
}
$act_num++;
}
print "\n";
} else {
print "No actions to process!\n";
}
}
# SUBROUTINE
# Decode_opSetMask (value)
#
# DESCRIPTION
# Takes the numeric opSet field and returns a list (space separated)
# of operation names that this filter will execute on.
#
example/GetServerStatistics.pl view on Meta::CPAN
#
# $Header: /cvsroot/arsperl/ARSperl/example/GetServerStatistics.pl,v 1.2 2003/04/02 01:43:35 jcmurphy Exp $
#
# NAME
# GetServerStatistics.pl
#
# USAGE
# GetServerStatistics.pl [server] [username] [password]
#
# DESCRIPTION
# Retrieve and print statistics on the arserver
#
# AUTHOR
# Jeff Murphy
# jcmurphy@acsu.buffalo.edu
#
# $Log: GetServerStatistics.pl,v $
# Revision 1.2 2003/04/02 01:43:35 jcmurphy
# mem mgmt cleanup
#
# Revision 1.1 1996/11/21 20:13:53 jcmurphy
# Initial revision
#
#
use ARS;
use strict;
my ($server, $username, $password) = @ARGV;
if(!defined($password)) {
print "Usage: $0 [server] [username] [password]\n";
exit 0;
}
my $c = ars_Login($server, $username, $password);
die "login failed: $ars_errstr" unless defined($c);
my @rev_ServerStats;
foreach my $stype (keys %ARServerStats) {
$rev_ServerStats[$ARServerStats{$stype}] = $stype;
}
print "requesting: START_TIME($ARServerStats{'START_TIME'}) CPU($ARServerStats{'CPU'})\n";
my %stats = ars_GetServerStatistics($c,
$ARServerStats{'START_TIME'},
$ARServerStats{'CPU'} );
die "ars_GetServerStatistics: $ars_errstr" unless %stats;
foreach my $stype (keys %stats) {
if($rev_ServerStats[$stype] =~ /TIME/) {
print $rev_ServerStats[$stype]." = <".localtime($stats{$stype})."> (".$stats{$stype}.")\n";
} else {
print $rev_ServerStats[$stype]." = <".$stats{$stype}.">\n";
}
}
ars_Logoff($c);
exit(0);
example/Get_Diary.pl view on Meta::CPAN
#
#
use ARS;
use strict;
# Parse command line parameters
my ( $server, $username, $password, $schema, $qualifier, $diaryfield ) = @ARGV;
if ( !defined($diaryfield) ) {
print "usage: $0 [server] [username] [password] [schema] [qualifier]\n";
print " [diaryfieldname]\n";
exit 1;
}
# Log onto the ars server specified
print "schema=$schema
qualifier=$qualifier
diaryfield=$diaryfield\n";
( my $ctrl = ars_Login( $server, $username, $password ) )
|| die "can't login to the server";
# Load the qualifier structure with a dummy qualifier.
( my $qual = ars_LoadQualifier( $ctrl, $schema, $qualifier ) )
|| die "error in ars_LoadQualifier:\n$ars_errstr";
example/Get_Diary.pl view on Meta::CPAN
my %entries = ars_GetListEntry( $ctrl, $schema, $qual, 0, 0 );
# Retrieve the fieldid for the diary field
( my $diaryfield_fid = ars_GetFieldByName( $ctrl, $schema, $diaryfield ) )
|| die "no such field in this schema: '$diaryfield'";
foreach my $entry_id ( sort keys %entries ) {
print ">>>>> Entry-id: $entry_id <<<<<\n\n";
# Retrieve the (fieldid, value) pairs for this entry
my %e_vals = ars_GetEntry( $ctrl, $schema, $entry_id, $diaryfield_fid );
# Print out the diary entries for this entry-id
foreach my $diary_entry ( @{ $e_vals{$diaryfield_fid} } ) {
print scalar localtime( $diary_entry->{timestamp} );
print " ", $diary_entry->{user}, "\n";
print $diary_entry->{value};
print "\n\n";
}
}
# Log out of the server.
ars_Logoff($ctrl);
example/List_Entries.pl view on Meta::CPAN
#!/usr/local/bin/perl
#
# $Header: /cvsroot/arsperl/ARSperl/example/List_Entries.pl,v 1.2 2009/04/14 12:55:54 mbeijen Exp $
#
# EXAMPLE
# List_Entries.pl
#
# DESCRIPTION
# Log onto the server and printout a listing of Entry IDs and
# Short Description (for each ID) for the given schema.
#
# NOTES
# "Short Description" is *not* (neccessarily) the contents of the
# "short-description" field. It is, in fact, the contents of the
# "Query List Fields" for this schema. Try it on a schema that
# you have some custom "Query List Fields" defined for to see
# what we mean.
#
# AUTHOR
example/List_Entries.pl view on Meta::CPAN
#
#
use ARS;
use strict;
# Parse command line parameters
my ( $server, $username, $password, $schema ) = @ARGV;
if ( !defined($schema) ) {
print "usage: $0 [server] [username] [password] [schema]\n";
exit 1;
}
# Log onto the ars server specified
( my $ctrl = ars_Login( $server, $username, $password ) )
|| die "can't login to the server";
# Load the qualifier structure with a dummy qualifier.
( my $qual = ars_LoadQualifier( $ctrl, $schema, "(1 = 1)" ) )
|| die "error in ars_LoadQualifier";
# Retrieve all of the entry-id's for the schema.
my %entries = ars_GetListEntry( $ctrl, $schema, $qual, 0, 0 );
printf( "%-15s %-60s\n", "Entry-ID", "Short Description" );
foreach my $entry_id ( sort keys %entries ) {
printf( "%-15s %-60s\n", $entry_id, $entries{$entry_id} );
}
# Log out of the server.
ars_Logoff($ctrl);
example/PrintQual.pl view on Meta::CPAN
#!/usr/local/bin/perl
#
# $Header: /cvsroot/arsperl/ARSperl/example/PrintQual.pl,v 1.2 1999/10/03 04:09:08 jcmurphy Exp $
#
# EXAMPLE
# PrintQual.pl
#
# DESCRIPTION
# Using ars_perl_qualifier, decode the QualifierStruct and
# print it in human readable form. This script is really
# only a basis and handles most of the generic cases. Further
# developement would be needed to fully implement a qualifier
# re-builder.
#
# You can include the routine Decode_QualHash() and Decode_FVoAS()
# in your own scripts by requiring 'ars_QualDecode.pl';
#
# TODO
# TR. and DB. references need to be implemented in ARS.xs
# as of now, we don't get that information, so we can't
example/PrintQual.pl view on Meta::CPAN
use ARS;
require 'ars_QualDecode.pl';
$debug = 0;
# Parse command line parameters
($server, $username, $password, $schema, $qual) = @ARGV;
if(!defined($password)) {
print "usage: $0 [server] [username] [password] [schema] [qualification]\n";
exit 1;
}
# Log onto the ars server specified
($ctrl = ars_Login($server, $username, $password)) ||
die "can't login to the server";
# Load the qualifier structure
example/PrintQual.pl view on Meta::CPAN
# Decode the encoded structure
($dq = ars_perl_qualifier($ctrl, $q)) ||
die "ars_perl_qualifier failed: $ars_errstr\n";
# Convert the decoded structure to a readable format
$e = ars_Decode_QualHash($ctrl, $schema, $dq);
print "$e\n";
ars_Logoff($ctrl);
exit 0;
example/Show_ALink.pl view on Meta::CPAN
$debug = 0;
require 'ars_QualDecode.pl';
@MessageTypes = ( "Note", "Warn", "Error" );
# Parse command line parameters
($server, $username, $password, $alink_name) = @ARGV;
if(!defined($alink_name)) {
print "usage: $0 [server] [username] [password] [alink name]\n";
exit 1;
}
$level = 0;
# SUBROUTINE
# printl
#
# DESCRIPTION
# prints the string after printing X number of tabs
sub printl {
my $t = shift;
my @s = @_;
if(defined($t)) {
for( ; $t > 0 ; $t--) {
print "\t";
}
print @s;
}
}
# SUBROUTINE
# DecodeExecMask
#
# DESCRIPTION
# Simple routine to return a string representing (in english)
# the execution mask value(s).
example/Show_ALink.pl view on Meta::CPAN
}
}
}
return($s);
}
# SUBROUTINE
# PrintArith
#
# DESCRIPTION
# Attempt to "pretty print" the arith expression (just for
# the hell of it)
#
# NOTES
# Notic that parenthesis are printed, although they are not
# explicitly part of the node information. They are derived
# from the ordering of the tree, instead. If you want to actually
# *evaluate* the expression, you will have to derive the
# parenthetical encoding from the tree ordering.
#
# Here is an example equation and how it is encoded:
#
# ((10 + 2) / 3)
#
# "/"
example/Show_ALink.pl view on Meta::CPAN
#
# THOUGHTS
# I don't know if this routine will work for all cases.. but
# i did some tests and it looked good. Ah.. i just wrote it
# for the fun of it.. so who cares? :)
sub PrintArith {
my $a = shift;
PrintArith_Recurs($a, 0);
print "\n";
}
sub PrintArith_Recurs {
my $a = shift;
my $p = shift;
my $n, $i;
if(defined($a)) {
$n = $a->{left};
if(defined($n)) {
if(defined($n->{arith})) {
PrintArith_Recurs($n->{arith}, $p+1);
} else {
for($i=1;$i<$p;$i++) {
print " ( ";
}
}
print " ( $n->{value} " if defined($n->{value});
print " ( \$$n->{field}->{fieldId}\$ " if defined($n->{field});
print " ( $n->{function} " if defined($n->{function});
}
print " $a->{oper} ";
$n = $a->{right};
if(defined($n)) {
print " $n->{value} ) " if defined($n->{value});
print " \$$n->{field}->{fieldId}\$ ) " if defined($n->{field});
PrintArith_Recurs($n->{arith}) if defined($n->{arith});
print " $n->{function} ) " if defined($n->{function});
}
}
}
# SUBROUTINE
# ProcessArithStruct
#
# DESCRIPTION
# This routine breaks down the arithmetic structure
sub ProcessArithStruct {
my $a = shift;
my $n;
if(defined($a)) {
printl 5, "Operation: $a->{oper}\n";
$n = $a->{left};
if(defined($n)) {
# printl 5, "(Left) ";
printl 5, "Value: \"$n->{value}\"\n" if defined($n->{value});
printl 5, "Field: \$$n->{field}->{fieldId}\$\n" if defined($n->{field});
printl 5, "Process: $n->{process}\n" if defined($n->{process});
ProcessArithStruct($n->{arith}) if defined($n->{arith});
printl 5, "Function: $n->{function}\n" if defined($n->{function});
printl 5, "DDE: DDE not supported in ARSperl\n" if defined($n->{dde});
}
$n = $a->{right};
if(defined($n)) {
# printl 5, "(Right) ";
printl 5, "Value: \"$n->{value}\"\n" if defined($n->{value});
printl 5, "Field: \$$n->{field}->{fieldId}\$\n" if defined($n->{field});
printl 5, "Process: $n->{process}\n" if defined($n->{process});
ProcessArithStruct($n->{arith}) if defined($n->{arith});
printl 5, "Function: $n->{function}\n" if defined($n->{function});
printl 5, "DDE: DDE not supported in ARSperl\n" if defined($n->{dde});
}
}
}
# SUBROUTINE
# ProcessFunctionList
#
# DESCRIPTION
# Parse and dump the function list structure.
sub ProcessFunctionList {
my $t = shift; # how much indentation to use
my @func = @_;
my $i;
printl $t, "Function Name: \"$func[0]\" .. Num of args: $#func\n";
# we need to process all of the arguments listed.
for($i=1;$i<=$#func;$i++) {
printl $t+1, "Value: \"$func[$i]->{value}\"\n" if defined($func[$i]->{value});
printl $t+1, "Field: \$$func[$i]->{field}->{fieldId}\$\n" if defined($func[$i]->{field});
printl $t+1, "Process: $func[$i]->{process}\n" if defined($func[$i]->{process});
PrintArith($func[$i]->{arith}) if defined($func[$i]->{arith});
# if the arg is a pointer to another function, we need to process
# it recursively.
if(defined($func[$i]->{function})) {
ProcessFunctionList($t+1, @{$func[$i]->{function}});
}
printl $t+1, "DDE: DDE not supported in ARSperl\n" if defined($func[$i]->{dde});
}
}
# SUBROUTINE
# ProcessSetFields
#
# DESCRIPTION
# This routine dumps the various forms of the Set Fields
# action in active links.
sub ProcessSetFields {
my $field = shift;
if(defined($field->{none})) {
printl 3, "No set fields instructions found.\n";
}
if(defined($field->{value})) {
printl 3, "Value: \$$field->{value}\$\n";
}
if(defined($field->{field})) {
printl 3, "Field: $field->{field}\n";
}
if(defined($field->{process})) {
printl 3, "Process: $field->{process}\n";
}
if(defined($field->{arith})) {
printl 3, "Arithmetic:\n";
# ProcessArithStruct($field->{arith});
printl 4, "Expression: ";
PrintArith($field->{arith});
}
if(defined($field->{function})) {
printl 3, "Function:\n";
ProcessFunctionList(4, @{$field->{function}});
}
if(defined($field->{dde})) {
printl 3, "DDE not implemented in ARSperl.\n";
}
}
# SUBROUTINE
# ProcessMacroStruct
#
# DESCRIPTION
# This routine breaks down the macro structure and
# dumps the information contained in it.
sub ProcessMacroStruct {
my $t = shift; # how much indentation to use
my $m = shift; # the macro struct
my $i, @p;
if(defined($m)) {
printl $t, "Macro Name : \"$m->{macroName}\"\n";
printl $t, "Macro Params: $m->{macroParms}\n";
foreach (keys %{$m->{macroParms}}) {
printl $t+1, "$_ = $m->{macroParms}{$_}\n";
}
printl $t, "Macro Text :\n**START**\n$m->{macroText}\n**END**\n";
}
}
# SUBROUTINE
# ProcessActions
#
# DESCRIPTION
# this routine processes the list of actions for this active link,
# deciding what actions are defined and dumping the appropriate
# information.
sub ProcessActions {
my @actions = @_;
if(defined(@actions)) {
$act_num = 1;
foreach $action (@actions) {
printl 1, "Action $act_num:\n";
if(defined($action->{macro})) {
printl 2, "Macro:\n";
ProcessMacroStruct(3, $action->{macro});
}
if(defined($action->{assign_fields})) {
printl 2, "Set Fields:\n";
foreach $setFields (@{$action->{assign_fields}}) {
printl 3, "fieldId: $setFields->{fieldId}\n";
ProcessSetFields($setFields->{assignment});
}
}
if(defined($action->{message})) {
printl 2, "Message: \n";
foreach my $k (keys %{$action->{message}}) {
printl 3, "$k: $action->{'message'}->{$k}\n";
}
}
if(defined($action->{process})) {
printl 2, "Process: ".$action->{process}."\n";
}
if(defined($action->{characteristics})) {
printl 2, "Change Field: ".$action->{characteristics}."\n";
}
if(defined($action->{dde})) {
printl 2, "DDE is not implemented in ARSperl.\n";
}
if(defined($action->{none})) {
printl 2, "No actions specified.\n";
}
$act_num++;
}
print "\n";
} else {
print "No actions to process!\n";
}
}
# Log onto the ars server specified
($ctrl = ars_Login($server, $username, $password)) ||
die "can't login to the server";
# Retrieve info about active link.
($a = ars_GetActiveLink($ctrl, $alink_name)) ||
die "can't fetch info about that active link";
print "Active Link Attributes:\n\n";
print "Name: ".$a->{name}."\n";
print "Execution Order: ".$a->{order}."\n";
if(defined($a->{'schema'})) {
print "Schema Name: ".$a->{schema}."\n";
} elsif(defined($a->{'schemaList'})) {
print "schemaList : ";
foreach my $s (@{$a->{'schemaList'}}) {
print "\"$s\" ";
}
print "\n";
}
print "Group Perms: ";
foreach $group (@{$a->{groupList}}) {
print "$group; ";
}
print "\n";
# XXX - decode
print "Execute On: ".DecodeExecMask($a->{executeMask})."\n";
print "Field: ".$a->{field}."\n"; # XXX - display only when needed (execmask)
print "Display List:\n";
foreach $display (@{$a->{displayList}}) {
printl 1, "Display Name: ".$display->{displayTag}."\n";
printl 2, "x corrd: ".$display->{x}."\n";
printl 2, "y coord: ".$display->{y}."\n";
printl 2, "Visible?: ".$display->{option}."\n";
printl 2, "Button Label: ".$display->{label}."\n";
printl 2, "Type: ".$display->{type}."\n";
}
print "\n";
#print "Qualification: ".$a->{query}."\n";
$dq = ars_perl_qualifier($ctrl, $a->{query});
$dq = undef if(isempty($dq));
if(defined($dq)) {
if(defined($a->{'schema'})) {
$dq_text = ars_Decode_QualHash($ctrl, $a->{schema}, $dq);
print " Qual Text: $dq_text\n";
}
elsif(defined($a->{'schemaList'})) {
foreach my $s (@{$a->{'schemaList'}}) {
$dq_text = ars_Decode_QualHash($ctrl, $s, $dq);
print " Qual Text (decoded against \"$s\": $dq_text\n";
}
}
} else {
print " Qual Text: [none defined]\n";
}
print "Actions:\n";
ProcessActions(@{$a->{actionList}});
print "Help Text: ".$a->{helpText}."\n";
print "Owner: ".$a->{owner}."\n";
print "Last changed by: ".$a->{lastChanged}."\n";
print "Last Modified: ".localtime($a->{timestamp})."\n";
print "Change Diary: $a->{changeDiary}\n";
foreach (@{$a->{changeDiary}}) {
print "\tTIME: ".localtime($_->{timestamp})."\n";
print "\tUSER: $_->{user}\n";
print "\tWHAT: $_->{value}\n";
}
# Log out of the server.
ars_Logoff($ctrl);
exit 0;
sub isempty {
my $r = shift;
example/Show_Menu.pl view on Meta::CPAN
# Initial revision
#
#
use ARS;
# Parse command line parameters
($server, $username, $password, $menu_name) = @ARGV;
if(!defined($menu_name)) {
print "usage: $0 [server] [username] [password] [menu name]\n";
exit 1;
}
# Log onto the ars server specified
($ctrl = ars_Login($server, $username, $password)) ||
die "can't login to the server";
# SUBROUTINE
# IndPrint(indentation, string)
#
# DESCRIP
# This subroutine will print a string with [indentation] number
# of preceding TABS.
sub IndPrint {
my $ind = shift;
my $s = shift;
my $i;
if(defined($s)) {
for($i = 0; $i < $ind; $i++) {
print "\t";
}
print $s;
}
}
# SUBROUTINE
# DumpMenu(arraypointer, indentation count)
#
# DESCRIP
# Recursive subroutine to dump menu and sub menu items
sub DumpMenu {
my $m = shift;
example/WhoUsesIt.pl view on Meta::CPAN
$pname =~ s/.*\///g;
Getopts('s:a:f:m:e:p:M:Dhv');
$debug = $opt_D;
($server, $username, $password) = @ARGV;
$SCHEMA = defined($opt_s)?$opt_s:".*";
if($debug) {
print STDERR "a: ".(defined($opt_a)?"$opt_a":"undef")."\n";
print STDERR "f: ".(defined($opt_f)?"$opt_f":"undef")."\n";
print STDERR "m: ".(defined($opt_m)?"$opt_m":"undef")."\n";
print STDERR "e: ".(defined($opt_e)?"$opt_e":"undef")."\n";
print STDERR "p: ".(defined($opt_p)?"$opt_p":"undef")."\n";
print STDERR "s: ".(defined($opt_p)?"$opt_s":"undef")."\n";
print STDERR "M: ".(defined($opt_M)?"$opt_M":"undef")."\n";
print STDERR "d: ".(defined($opt_d)?"defined":"undef")."\n";
print STDERR "v: ".(defined($opt_v)?"defined":"undef")."\n";
print STDERR "h: ".(defined($opt_h)?"defined":"undef")."\n";
}
if((!defined($opt_a) &&
!defined($opt_f) &&
!defined($opt_m) &&
!defined($opt_p) &&
!defined($opt_M) &&
!defined($opt_e)) ||
defined($opt_h)) {
Usage();
exit 0;
}
if($username eq "") {
print "Username: ";
chomp($username = <STDIN>);
if($username eq "") {
print "Goodbye.\n";
exit 0;
}
}
if($password eq "") {
print "Password: ";
system 'stty', '-echo';
chomp($password = <STDIN>);
system 'stty', 'echo';
print "\n";
}
($ctrl = ars_Login($server, $username, $password)) ||
die "couldn't allocate control structure";
(@schemas = ars_GetListSchema($ctrl)) ||
die "can't read schema list: $ars_errstr";
if($opt_M) {
# fine any menu that uses this file as it's
# source of menu items.
print "Menus that use the file \"$opt_M\"... (this may take a minute or so to do)\n";
@menus = ars_GetListCharMenu($ctrl, 0);
if($#menus != -1) {
foreach $menu (@menus) {
print "Searching: $menu\n" if $debug;
($menuDef = ars_GetCharMenu($ctrl, $menu)) ||
die "ars_GetCharMenu: $ars_errstr";
#next unless ($menu eq "PT-Assignees");
#use Data::Dumper; print Dumper($menuDef); exit 0;
# 3 is legacy.
if( ($menuDef->{menuType} == 3) || ($menuDef->{menuType} =~ /format_quotes/i) ) {
print "\tIs type File (points to ".qq{"$menuDef->{menuFile}{filename}"}.")\n" if $debug;
if ($menuDef->{menuFile}{filename} =~ /$opt_M/) {
$users{$menu} = $1;
}
}
}
foreach (sort keys %users) {
print "\t$_\n";
}
} else {
print "No menu's available!\n$ars_errstr\n";
}
} elsif($opt_a) {
# find any schema that uses this active link.
print "Searching for Active Link \"$opt_a\" in Schema \"$SCHEMA\"...\n";
foreach $schema (@schemas) {
if($schema =~ /$SCHEMA/) {
print "Searching schema $schema..\n" if $debug;
@alinks = ars_GetListActiveLink($ctrl, $schema);
foreach $link (@alinks) {
if($link =~ /$opt_a/) {
$users{$schema} .= "$link,";
}
}
}
}
foreach $schema (sort keys %users) {
print "\t$schema\n";
foreach $link (split(/,/, substr($users{$schema}, 0, length($users{$schema})-1))) {
print "\t\t$link\n";
}
}
} elsif($opt_f) {
# find any schema that uses this filter.
print "Searching for Filter \"$opt_f\" in Schema \"$SCHEMA\" ...\n";
foreach $schema (@schemas) {
if($schema =~ /$SCHEMA/) {
@filters = ars_GetListFilter($ctrl, $schema);
foreach $filter (@filters) {
if($filter =~ /^$opt_f$/) {
$users{$schema} .= "$filter,";
}
}
}
}
foreach $schema (sort keys %users) {
print "\t$schema\n";
foreach $filter (split(/,/, substr($users{$schema}, 0, length($users{$schema})-1))) {
print "\t\t$filter\n";
}
}
} elsif($opt_m) {
# find any schema that uses this menu.
# this particular routine will take longer, because we
# need to open each schema, and then retrieve all field
# definitions and finally flip thru each field and see
# what menus (if any) are attached.
print "Searching for Menu \"$opt_m\" in schema \"$opt_s\"...\n";
print "(this may take some time)\n";
foreach $schema (@schemas) {
if($schema =~ /$SCHEMA/) {
print "Searching schema: $opt_s\n" if $debug;
@fields = ars_GetListField($ctrl, $schema);
foreach $field (@fields) {
$finfo = ars_GetField($ctrl, $schema, $field);
if(($finfo->{dataType} eq "char") &&
defined($finfo->{limit})) {
if(($finfo->{limit}{charMenu} ne "") &&
($finfo->{limit}{charMenu} =~ /$opt_m/)) {
$users{$schema} .= "$finfo->{limit}{charMenu},";
}
}
}
}
}
foreach $schema (sort keys %users) {
print "\t$schema\n";
foreach $menu (split(/,/, substr($users{$schema}, 0, length($users{$schema})-1))) {
print "\t\t$menu\n";
}
}
} elsif($opt_e) {
# find any schema that uses this escalation.
print "Searching for Escalation \"$opt_e\"...\n";
foreach $schema (@schemas) {
@escalations = ars_GetListEscalation($ctrl, $schema);
if(grep(/^$opt_e$/, @escalations)) {
$users{$schema} = 1;
}
}
foreach (sort keys %users) {
print "\t$_\n";
}
} elsif($opt_p) {
# find any *filters* that call the named process
print "Searching for filters that call \"$opt_p\"...\n";
@filters = ars_GetListFilter($ctrl);
if($#filters != -1) {
foreach $filter (@filters) {
$finfo = ars_GetFilter($ctrl, $filter);
foreach $action (@{$finfo->{actionList}}) {
if(defined($action->{process})) {
print "filter $filter process ".$action->{process}."\n" if $debug;
if($action->{process} =~ /$opt_p/) {
$users{$filter} = $action->{process};
}
}
}
}
foreach $f (sort keys %users) {
if(!$opt_v) {
print "\t$f\n";
} else {
print "\t$f\n\t\t$users{$f}\n";
}
}
}
} else {
print "nothing to do!\n";
}
ars_Logoff($ctrl);
exit 0;
# ROUTINE
# Usage()
#
# DESCRIPTION
# Dump usage information.
#
# AUTHOR
# jeff murphy
sub Usage {
print "Usage: $pname [-v] [-h] [-s schema] [-a | -f | -m | -e | -p [name]]\n";
print " [username] [password]\n"
}
example/ars_DateToJulianDate.pl view on Meta::CPAN
die "usage: $0 server username password year month day\n"
unless ( $#ARGV >= 5 );
my ( $server, $user, $password, $year, $month, $day, ) =
( shift, shift, shift, shift, shift, shift, );
#Logging in to the server
( my $ctrl = ars_Login( $server, $user, $password ) )
|| die "ars_Login: $ars_errstr";
print "Converting year $year month $month day $day to Julian...\n";
( my $juliandate = ars_DateToJulianDate( $ctrl, $year, $month, $day ) )
|| die "ERR: $ars_errstr\n";
ars_Logoff($ctrl);
print "The JulianDate value is $juliandate\n";
example/ars_ExecuteProcess.pl view on Meta::CPAN
die "usage: ars_ExecuteProcess.pl server username \"string to execute\"\n"
if ( $#ARGV < 3 );
my ( $server, $user, $pass, $command ) = ( shift, shift, shift, shift );
#Logging in to the server
( my $ctrl = ars_Login( $server, $user, $pass ) )
|| die "ars_Login: $ars_errstr";
( my ( $num, $str ) = ars_ExecuteProcess( $ctrl, $command ) )
|| print "ERR: $ars_errstr\n";
print "gotit: $ars_errstr\n";
print "returnCode=<$num> returnString=<$str>\n";
ars_Logoff($ctrl);
example/ars_GetControlStructFields.pl view on Meta::CPAN
#
use ARS;
($c = ars_Login(shift, shift, shift))
|| die "login: $ars_errstr";
($cacheId, $operationTime, $user, $password, $lang,
$server) = ars_GetControlStructFields($c);
print "Control Struct Fields:
cacheId = $cacheId
operationTime = $operationTime
username = $user
password = $password
language = $lang
server = $server
";
ars_Logoff($c);
( run in 1.279 second using v1.01-cache-2.11-cpan-de7293f3b23 )