#!/usr/local/bin/perl
#
# $Header: /cvsroot/arsperl/ARSperl/example/Show_ALink.pl,v 1.6 2000/06/01 16:54:03 jcmurphy Exp $
#
# EXAMPLE
# Show_ALink.pl
#
# DESCRIPTION
# Use ars_GetActiveLink to obtain information about an active link.
#
# NOTES
# This is a fairly large and involved example, however it illustrates
# many points about how to decode the more complex information that
# can be passed back from the API.
#
# All structures demonstrated herein are documented in the usage.html
# documentation.
#
# This example file parse most (but not all) of the active links
# fields.
#
# AUTHOR
# jeff murphy
#
# 01/12/96
#
# $Log: Show_ALink.pl,v $
# Revision 1.6 2000/06/01 16:54:03 jcmurphy
# *** empty log message ***
#
# Revision 1.5 1998/09/14 17:41:05 jcmurphy
# added ChangeDiary decoding lines
#
# Revision 1.4 1998/09/11 17:49:47 jcmurphy
# updated EXECUTE_ON definitions
#
# Revision 1.3 1998/09/11 17:22:13 jcmurphy
# changed macroParms from array to hash since it is
# a hashref.
#
# Revision 1.2 1997/11/11 15:04:47 jcmurphy
# added qual decoding
#
# Revision 1.1 1996/11/21 20:13:55 jcmurphy
# Initial revision
#
#
use ARS;
$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).
$AR_EXECUTE_ON_NONE = 0;
$AR_EXECUTE_ON_BUTTON = 1;
$AR_EXECUTE_ON_RETURN = 2;
$AR_EXECUTE_ON_SUBMIT = 4;
$AR_EXECUTE_ON_MODIFY = 8;
$AR_EXECUTE_ON_DISPLAY = 16;
$AR_EXECUTE_ON_MODIFY_ALL = 32;
$AR_EXECUTE_ON_MENU = 64;
$AR_EXECUTE_ON_MENU_CHOICE = 128;
$AR_EXECUTE_ON_LOOSE_FOCUS = 256;
$AR_EXECUTE_ON_SET_DEFAULT = 512;
$AR_EXECUTE_ON_QUERY = 1024;
$AR_EXECUTE_ON_AFTER_MODIFY = 2048; # Added in 3.2
$AR_EXECUTE_ON_AFTER_SUBMIT = 4096;
$AR_EXECUTE_ON_GAIN_FOCUS = 8192;
$AR_EXECUTE_ON_WINDOW_OPEN = 16384;
$AR_EXECUTE_ON_WINDOW_CLOSE = 32768;
%ars_ExecuteOn = ($AR_EXECUTE_ON_BUTTON, "Button",
$AR_EXECUTE_ON_RETURN, "Return",
$AR_EXECUTE_ON_SUBMIT, "Submit",
$AR_EXECUTE_ON_MODIFY, "Modify",
$AR_EXECUTE_ON_DISPLAY, "Display",
$AR_EXECUTE_ON_MENU, "Menu",
$AR_EXECUTE_ON_MENU_CHOICE, "Menu_Choice",
$AR_EXECUTE_ON_LOOSE_FOCUS, "Loose_Focus",
$AR_EXECUTE_ON_SET_DEFAULT, "Set_Default",
$AR_EXECUTE_ON_QUERY, "Query",
$AR_EXECUTE_ON_AFTER_MODIFY, "After_Modify",
$AR_EXECUTE_ON_AFTER_SUBMIT, "After_Submit",
$AR_EXECUTE_ON_GAIN_FOCUS, "Gain_Focus",
$AR_EXECUTE_ON_WINDOW_OPEN, "Window_Open",
$AR_EXECUTE_ON_WINDOW_CLOSE, "Window_Close"
);
sub DecodeExecMask {
my $m = shift;
my $s, $v;
if(defined($m)) {
foreach $v (sort keys %ars_ExecuteOn) {
if($v & $m) {
$s = $s." ".$ars_ExecuteOn{$v};
}
}
}
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)
#
# "/"
# / \
# "+" 3
# / \
# 10 2
#
# ARS apparently sorts the operations for you (based on their
# mathematical precedence) so you should evaluate the tree from
# the bottom up.
#
# ars_web.cgi has an evaluation routine for computing the value
# of a arith structure. we will probably break it out into a
# perl module.
#
# 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;
return 1 if !defined($r);
if(ref($r) eq "ARRAY") {
return ($#{$r} == -1) ? 1 : 0;
}
if(ref($r) eq "HASH") {
my @k = keys %{$r};
return ($#k == -1) ? 1 : 0;
}
return 1 if($r eq "");
return 0;
}