ARSperl
view release on metacpan or search on metacpan
#
# Mailing List (must be subscribed to post):
# arsperl@arsperl.org
#
# Routines for grabbing the current error message "stack"
# by simply referring to the $ars_errstr scalar.
package ARS::ERRORSTR;
sub TIESCALAR {
bless {};
}
sub FETCH {
my($s, $i) = (undef, undef);
my(%mTypes) = ( 0 => "OK", 1 => "WARNING", 2 => "ERROR", 3 => "FATAL",
4 => "INTERNAL ERROR",
-1 => "TRACEBACK");
for($i = 0; $i < $ARS::ars_errhash{numItems}; $i++) {
# If debugging is not enabled, don't show traceback messages
if($ARS::DEBUGGING == 1) {
$s .= sprintf("[%s] %s (ARERR \#%d)",
$ARS::VERSION = '2.00';
$ARS::DEBUGGING = 0;
$ARS::logging_file_ptr = 0;
# definitions required for backwards compatibility
if (!defined &ARS::AR_IMPORT_OPT_CREATE) {
eval 'sub AR_IMPORT_OPT_CREATE { 0; }';
}
if (!defined &ARS::AR_IMPORT_OPT_OVERWRITE) {
eval 'sub AR_IMPORT_OPT_OVERWRITE { 1; }';
}
bootstrap ARS $ARS::VERSION;
tie $ARS::ars_errstr, ARS::ERRORSTR;
# This HASH is used by the ars_GetServerStatistics call.
# Refer to your ARS API Programmer's Manual or the "ar.h"
# file for an explaination of what each of these stats are.
#
# Usage of this hash would be something like:
'FILTER_FIELDS_SQL', 68,
'FILTER_FIELDS_PROCESS', 69,
'FILTER_FIELDS_FLTAPI', 70,
'ESCL_FIELDS_SQL', 71,
'ESCL_FIELDS_PROCESS', 72,
'ESCL_FIELDS_FLTAPI', 73,
'WRITE_RESTRICTED_READ', 74
);
sub new {
require 'ARS/OOform.pm';
require 'ARS/OOmsgs.pm';
require 'ARS/OOsup.pm';
return newObject( @_ );
}
# ROUTINE
# ars_simpleMenu(menuItems, prepend)
#
# DESCRIPTION
# merges all sub-menus into a single level menu. good for web
# interfaces.
#
# RETURNS
# array of menu items.
sub ars_simpleMenu {
my($m) = shift;
my($prepend) = shift;
my(@m) = @$m;
my(@ret, @submenu);
my($name, $val);
while (($name, $val, @m) = @m) {
if (ref($val)) {
@submenu = ars_simpleMenu($val, $name);
@ret = (@ret, @submenu);
# DESCRIPTION
# this routine will left-pad the entry-id with
# zeros out to the appropriate number of place (15 max)
# depending upon if your prefix your entry-id's with
# anything
#
# RETURNS
# a new scalar on success
# undef on error
sub ars_padEntryid {
my($c) = shift;
my($schema) = shift;
my($entry_id) = shift;
my($field);
# entry id field is field id #1
($field = ars_GetField($c, $schema, 1)) ||
return undef;
if( $field->{defaultVal} ){
return $field->{defaultVal}.("0"x($field->{limit}{maxLength}-length($field->{defaultVal})-length($entry_id))).$entry_id;
#
# so if you have a status field that has two states: Open and Closed,
# where Open is enum 0 and Closed is enum 1, this routine will return:
#
# $retval[0]->{USER} = the user to last selected this enum
# $retval[1]->{TIME} = the time that this enum was last selected
#
# You can map from enum values to selection words by using
# arsGetField().
sub ars_decodeStatusHistory {
my ($sval) = shift;
my ($enum) = 0;
my ($pair, $ts, $un);
my (@retval);
foreach $pair (split(/\003/, $sval)) {
if($pair ne "") {
($ts, $un) = split(/\004/, $pair);
$retval[$enum]->{USER} = $un;
$retval[$enum]->{TIME} = $ts;
# DESCRIPTION
# given a list of diary hashs (see ars_GetEntry),
# encode them into an ars-internal diary string. this can
# then be fed into ars_MergeEntry() in order to alter the contents
# of an existing diary entry.
#
# RETURNS
# an encoded diary string (scalar) on success
# undef on failure
sub ars_EncodeDiary {
my ($diary_string) = undef;
my ($entry);
foreach $entry (@_) {
$diary_string .= $entry->{timestamp}.pack("c",4).$entry->{user}.pack("c",4).$entry->{value};
$diary_string .= pack("c",3) if ($diary_string);
}
return $diary_string;
}
sub insertValueForCurrentTransaction {
my ($c, $s, $q) = (shift, shift, shift);
die Carp::longmess("Usage: insertValueForCurrentTransaction(ctrl, schema, qualifier, ...)\n")
if(!defined($q));
die Carp::longmess("Usage: insertValueForCurrentTransaction(ctrl, schema, qualifier, ...)\nEven number of arguments must follow 'qualifier'\n")
if($#_ % 2 == 1);
#foreach (field, value) pair {
# look up field
($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;
}
foreach (keys %$q) {
print "key: ", $_,"\n";
print "val: ", $q->{$_},"\n";
dumpHash ($q->{$_}) if(ref($q->{$_}) eq "HASH");
}
}
}
sub dumpHash {
my $h = shift;
foreach (keys %$h) {
print "key: ", $_,"\n";
print "val: ", $h->{$_},"\n";
dumpHash($h->{$_}) if(ref($h->{$_}) eq "HASH");
}
}
# ars_GetCharMenuItems(ctrl, menuName, qualifier)
# qual is optional.
# if it's specified:
# menuType must be "query"
# qualifier must compile against the form that the menu
# is written for.
sub ars_GetCharMenuItems {
my ($ctrl, $menuName, $qual) = (shift, shift, shift);
if(defined($qual)) {
my $menu = ars_GetCharMenu($ctrl, $menuName);
die "ars_GetCharMenuItems failed: $ARS::ars_errstr"
unless defined($menu);
die "ars_GetCharMenuItems failed: qualifier was specified, but menu is not a 'query' menu"
if($menu->{'menuType'} ne "query");
if(ref($qual) ne "ARQualifierStruct") {
$qual = ars_LoadQualifier($ctrl, $menu->{'menuQuery'}{'schema'}, $qual);
}
return ars_ExpandCharMenu2($ctrl, $menuName, $qual);
}
return ars_ExpandCharMenu2($ctrl, $menuName);
}
sub ars_ExpandCharMenu {
return ars_ExpandCharMenu2(@_);
}
# encodes status history from the same format
# as returned by ars_decodeStatusHistory()
sub ars_encodeStatusHistory {
my @sh = ();
while(my $hr = shift) {
push @sh, $hr->{USER} ? "$hr->{TIME}\cD$hr->{USER}" : "";
}
join "\cC", @sh;
}
sub ars_SetOverlayGroup {
my ($ctrl, $value) = (shift, shift);
ars_SetSessionConfiguration($ctrl, 12, $value);
ars_SetSessionConfiguration($ctrl, 13, $value);
}
sub ars_SwitchToBaseMode {
my $ctrl = shift;
ars_SetOverlayGroup($ctrl, 0);
}
sub ars_SwitchToBestPracticeMode {
my $ctrl = shift;
ars_SetOverlayGroup($ctrl, 1);
}
# As of ARS4.0, these routines (which call ARInitialization and ARTermination)
# need to pass a control struct. this means that we now must move them into
# ars_Login and ars_Logoff in order to have access to that control struct.
# the implications of this are that your script should always call ars_Logoff()
# inorder to ensure that licenses are released (i.e. ARTermination is called)
# as for ARInitialization: this is used for private servers, mostly, and shouldnt
ARS/CodeTemplate.pm view on Meta::CPAN
package ARS::CodeTemplate;
use Exporter;
@ISA = qw( Exporter );
@EXPORT = qw( include modByRegex );
*opt = *main::opt;
#our $LINE_INDENT = '';
sub compile {
my( $input ) = @_;
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*$/ ){
ARS/CodeTemplate.pm view on Meta::CPAN
}
}
return $output;
}
use Getopt::Long;
sub init_template {
%opt = ();
Getopt::Long::Configure( 'no_ignore_case' );
Getopt::Long::GetOptions( \%opt, 'o=s', 'x!', 'debug!', @_ );
}
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";
return undef;
};
my $data = <FILE>;
close FILE;
return $data;
}
sub modByRegex {
package main;
my( $val, @regex ) = @_;
foreach my $regex ( @regex ){
eval "\$val =~ $regex";
warn $@, "\n" if $@;
}
return $val;
}
sub get_header {
my( $of, $tpt ) = @_;
my $HEADER = << "+";
/*******************************************************************************
** **
** Automatically genenerated <OUTFILE> file.
** D O N O T E D I T ! ! ! ! **
** Edit <TEMPLATE> instead.
** **
*******************************************************************************/
ARS/OOform.pm view on Meta::CPAN
#
# Mailing List (must be subscribed to post):
# See URL above.
#
package ARS::form;
require Carp;
# new ARS::form(-form => name, -vui => view, -connection => connection)
sub new {
my ($class, $self) = (shift, {});
my ($b) = bless($self, $class);
my ($form, $vui, $connection) =
ARS::rearrange([FORM,VUI,CONNECTION],@_);
$connection->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: new ARS::form(-form => name, -vui => vui, -connection => connection)\nform and connection parameters are required."
)
ARS/OOform.pm view on Meta::CPAN
$enums{$_} = { map { $_->{itemNumber}, $_->{itemName} } @{$fv->{'limit'}->{'enumLimits'}->{customList}} };
}
}
}
$self->{'fieldtypes'} = \%t;
$self->{'fieldEnumValues'} = \%enums;
return $b;
}
sub DESTROY {
}
# getEnumValues(-field => "fieldname")
sub getEnumValues {
my ($this) = shift;
my ($field) = ARS::rearrange([FIELD], @_);
if(ref($this->{'fieldEnumValues'}->{$field}) eq "ARRAY") {
return @{$this->{'fieldEnumValues'}->{$field}};
}
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81006,
"field $field is not an enumeration field.");
$this->{'connection'}->tryCatch();
return undef;
}
# 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";
}
ARS/OOform.pm view on Meta::CPAN
}
$this->{'matches'} = \@mids;
$this->{'querylist'} = \@mdescs;
return @mids;
}
# getFieldID(-field => name)
sub getFieldID {
my $this = shift;
my ($name) = ARS::rearrange([FIELD], @_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->getFieldID(-field => name)\nname parameter is required.")
unless defined($name);
if(!defined($this->{'fields'}->{$name})) {
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81001,
"field '$name' not in view: ".$this->{'vui'}."\n"
);
}
return $this->{'fields'}->{$name} if(defined($name));
}
# getFieldName(-id => id)
sub getFieldName {
my $this = shift;
my ($id) = ARS::rearrange([ID], @_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->getFieldName(-id => id)\nid parameter required."
)
unless defined($id);
return $this->{'fields_rev'}->{$id} if defined($this->{'fields_rev'}->{$id});
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81002,
"field id '$id' not available on form: ".$this->{'form'}.""
);
}
# getFieldType(-field => name, -id => id)
sub getFieldType {
my $this = shift;
my ($name, $id) = ARS::rearrange([FIELD,ID], @_);
if(!defined($name) && !defined($id)) {
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->getFieldType(-field => name, -id => id)\none of the parameters must be specified.");
}
if(defined($name) && !defined($this->{'fieldtypes'}->{$name})) {
ARS/OOform.pm view on Meta::CPAN
return $this->{'fieldtypes'}->{$n};
}
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81003,
"couldn't determine dataType for field.");
}
# delete(-entry => id)
sub delete {
my $this = shift;
my ($id) = ARS::rearrange([ENTRY],@_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->delete(-entry => id)\nentry parameter is required.")
unless defined($id);
my (@d);
ARS/OOform.pm view on Meta::CPAN
foreach (@d) {
ARS::ars_DeleteEntry($this->{'connection'}->{'ctrl'},
$this->{'form'},
$_);
$this->{'connection'}->tryCatch();
}
}
# merge(-type => mergeType, -values => { field1 => value1, ... })
sub merge {
my ($this) = shift;
my ($type, $vals) =
ARS::rearrange([TYPE,[VALUE,VALUES]],@_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->merge(-type => mergeType, -values => { field1 => value1, ... })\ntype and values parameters are required.")
unless(defined($type) && defined($vals));
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
ARS/OOform.pm view on Meta::CPAN
!$this->{'connection'}->hasErrors()) {
$rv = $realmap{1};
}
}
return $rv;
}
# set(-entry => id, -gettime => tstamp, -values => { field1 => value1, ... })
sub set {
my ($this) = shift;
my ($entry,$gettime,$vals) =
ARS::rearrange([ENTRY,GETTIME,[VALUE,VALUES]],@_);
$gettime = 0 unless defined($gettime);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->set(-entry => id, -gettime => tstamp, -values => { field1 => value1, ... })\nentry and values parameters are required."
)
ARS/OOform.pm view on Meta::CPAN
$gettime,
%realmap);
$this->{'connection'}->tryCatch();
return $rv;
}
# value2internal(-field => name, -value => value)
sub value2internal {
my ($this) = shift;
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);
ARS/OOform.pm view on Meta::CPAN
"[2] unable to translate enumeration value for field '$f'");
}
# we don't need translation..
return $v;
}
# internal2value(-field => name, -id => id, -value => value)
sub internal2value {
my ($this) = shift;
my ($f, $id, $v) = ARS::rearrange([FIELD,ID,VALUE], @_);
$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);
ARS/OOform.pm view on Meta::CPAN
return $this->{'fieldEnumValues'}->{$f}->{$v}
}
# we don't need translation..
return $v;
}
# create(-values => { field1 => value1, ... })
sub create {
my ($this) = shift;
my ($vals) = ARS::rearrange([[VALUES,VALUE]],@_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->create(-values => { field1 => value1, ... })\nvalues parameter is required.")
unless defined($vals);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
ARS/OOform.pm view on Meta::CPAN
%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]],@_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->get(-entry => entryid, -fields => [ field1, field2, ... ])\nentry parameter is required.")
unless defined($eid);
my (@fieldlist) = ();
my ($allfields) = 1;
ARS/OOform.pm view on Meta::CPAN
}
}
return @rv unless ($#rv == 0);
return $rv[0];
}
# getAsHash(-entry => entryid, -fields => [field1, field2, ...])
sub getAsHash {
my $this = shift;
my ($eid, $fields) = ARS::rearrange([ENTRY,[FIELD,FIELDS]],@_);
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: form->getAsHash(-entry => entryid, -fields => [ field1, field2, ... ])\nentry parameter is required.")
unless defined($eid);
my (@fieldlist) = ();
my ($allfields) = 1;
ARS/OOform.pm view on Meta::CPAN
}
$v[$i] = $this->getFieldName(-id => $v[$i]);
}
return @v;
}
# getAttachment(-entry => eid, -field => fieldname, -file => filename)
# if file isnt specified, the attachment is returned "in core"
sub getAttachment {
my $this = shift;
my ($eid, $field, $file) = ARS::rearrange([ENTRY,FIELD,FILE],@_);
if(!defined($eid) && !defined($field)) {
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: getAttachment(-entry => eid, -field => fieldname, -file => filename)\nentry and field parameters are required.");
}
if(defined($file)) {
ARS/OOform.pm view on Meta::CPAN
return ARS::ars_GetEntryBLOB($this->{'connection'}->{'ctrl'},
$this->{'form'},
$eid,
$this->getFieldID($field),
ARS::AR_LOC_BUFFER);
}
#setSort(... )
sub setSort {
my $this = shift;
if(($#_+1) % 2 == 1){
$this->{'connection'}->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: setSort(...)\nMust have an even number of parameters. (nparm = $#_)");
}
my (@t) = @_;
ARS/OOmsgs.pm view on Meta::CPAN
# of ARSperl (or the one that accompanies the source distribution of Perl
# itself) for a full description.
#
# Official Home Page:
# http://www.arsperl.org/
#
# Mailing List (must be subscribed to post):
# See URL above.
#
sub internalDie {
my ($this, $msg, $trace) = (shift, shift, shift);
$msg = "[no message available]" unless (defined($msg) && ($msg ne ""));
$trace = "[no traceback available]"
unless (defined($trace) && ($trace ne ""));
die "$msg\n\nTRACEBACK:\n\n$trace\n";
}
sub internalWarn {
my ($this, $msg, $trace) = (shift, shift, shift);
$msg = "[no message available]" unless (defined($msg) && ($msg ne ""));
$trace = "[no traceback available]"
unless (defined($trace) && ($trace ne ""));
warn "$msg\n\nTRACEBACK:\n\n$trace\n";
}
# 81000 = Usage Errors
# 81001 = Field Name Not In VUI
# 81002 = Invalid Field ID
# 81003 = Unknown Field Data Type
# 81004 = Unable to Xlate Enum Value
# 81005 = misspelled/invalid parameter
# .catch is a hash ref
sub initCatch {
my $this = shift;
$this->setCatch(&ARS::AR_RETURN_WARNING => "internalWarn");
$this->setCatch(&ARS::AR_RETURN_ERROR => "internalDie");
$this->setCatch(&ARS::AR_RETURN_FATAL => "internalDie");
}
sub setCatch {
my $this = shift;
my $type = shift;
my $func = shift;
$this->{'.catch'}->{$type} = $func;
}
# this routine is periodically called to see if any exceptions
# have occurred. if they have, and an exception handler is specified,
# we will call the handler and pass it the exception.
sub tryCatch {
my $this = shift;
if(defined($this->{'.catch'}) && ref($this->{'.catch'}) eq "HASH") {
foreach (&ARS::AR_RETURN_WARNING, &ARS::AR_RETURN_ERROR,
&ARS::AR_RETURN_FATAL) {
if(defined($this->{'.catch'}->{$_}) && $this->hasMessageType($_)) {
my $stackTrace = Carp::longmess("exception generated");
&{$this->{'.catch'}->{$_}}($_, $this->messages(),
$stackTrace);
}
}
}
}
sub pushMessage {
my ($this, $type, $num, $text) = (shift, shift, shift, shift);
$ARS::ars_errhash{numItems}++;
push @{$ARS::ars_errhash{messageType}}, $type;
push @{$ARS::ars_errhash{messageNum}}, $num;
push @{$ARS::ars_errhash{messageText}}, $text;
$this->tryCatch();
}
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;
}
sub errors {
my $this = shift;
return $this->messages(&ARS::AR_RETURN_ERROR);
}
sub warnings {
my $this = shift;
return $this->messages(&ARS::AR_RETURN_WARNING);
}
sub fatals {
my $this = shift;
return $this->messages(&ARS::AR_RETURN_FATAL);
}
sub hasMessageType {
my ($this, $t) = (shift, shift);
return $t if !defined($t);
for(my $i = 0; $i < $ARS::ars_errhash{numItems}; $i++) {
return 1
if(@{$ARS::ars_errhash{'messageType'}}[$i] == $t);
}
return 0;
}
sub hasFatals {
my $this = shift;
return $this->hasMessageType(&ARS::AR_RETURN_FATAL);
}
sub hasErrors {
my $this = shift;
return $this->hasMessageType(&ARS::AR_RETURN_ERROR);
}
sub hasWarnings {
my $this = shift;
return $this->hasMessageType(&ARS::AR_RETURN_WARNING);
}
1;
ARS/OOsup.pm view on Meta::CPAN
# http://www.arsperl.org
#
# Mailing List (must be subscribed to post):
# See URL above.
#
# Object Oriented Hoopla
sub newObject {
my ($class, @p) = (shift, @_);
my ($self) = {};
my ($blessed) = bless($self, $class);
my ($server, $username, $password, $catch, $ctrl, $dbg, $tcpport) =
rearrange([SERVER,USERNAME,PASSWORD,CATCH,CTRL,DEBUG,TCPPORT],@p);
# should the OO layer emit debugging information?
$self->{'.debug'} = 0;
$self->{'.debug'} = 1 if(defined($dbg));
ARS/OOsup.pm view on Meta::CPAN
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);
return ars_GetListSchema($this->{'ctrl'},
$changedSince,
$schemaType, undef,
$name);
}
sub openForm {
my $this = shift;
my($form, $vui) = rearrange([FORM,VUI], @_);
$this->pushMessage(&ARS::AR_RETURN_ERROR,
81000,
"usage: c->openForm(-form => name, -vui => vui)\nform parameter is required.")
if(!defined($form) || ($form eq ""));
$this->tryCatch();
return new ARS::form(-form => $form,
ARS/nparm.pm view on Meta::CPAN
#
# the following two routines
# make_attributes()
# rearrange()
# 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)
# that lists the order we want the params returned in.
#
# param is the actual params, probably as (-key, value) pairs.
sub rearrange {
my($order,@param) = @_;
return () unless @param;
my($param, @possibilities);
foreach (@$order) {
if(ref($_) && (ref($_) eq "ARRAY")) {
foreach my $P (@{$_}) {
push @possibilities, $P;
}
} else {
Makefile.PL view on Meta::CPAN
exit 0;
# ROUTINE
# GenerateSupportDotH(template-file, includes-dir)
#
# DESCRIPTION
# this routine extracts some information from the
# "ar.h" file and generates some "type maps" which help
# 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);
Makefile.PL view on Meta::CPAN
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;
}
Makefile.PL view on Meta::CPAN
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.,
# c:\Program Files\ARSystem6.0.1\Arserver\Api\include\ar.h
# then this method wants an appropriately quoted
# c:\Program Files\ARSystem6.0.1\Arserver\Api
# as its first arg
#
sub findAPIVersion {
my $path_to_api_dir = shift;
my $ar_fname = join('/', $path_to_api_dir, 'include', 'ar.h');
open ($ar_fh, '<'. $ar_fname) or
die "couldn't open ar.h include file from: \"$ar_fname\": $!\n";
my $api_version = undef;
# the line we want to parse looks like:
#
Makefile.PL view on Meta::CPAN
# time we have arsperl will have to change to support the API change.
#
# this whole strategy of deriving the server version from the api version
# presumes that we won't have to distinguish between releases of the
# same api version, which may or may not be correct.
#
# the api version can be the main variable arsperl uses to adjust
# itself however.
#
sub serverReleaseFromAPIVersion {
my $api_version = shift;
# keys are server releases converted to floating point numbers;
# values are the api version that release produced.
# add more values to this table as needed.
my $rh_api_version_table =
{
4.5 => 7,
4.51 => 7,
4.52 => 7,
Makefile.PL view on Meta::CPAN
push @api_list, $server_rel;
}
}
# make sure the values are treated as numbers during the sort
my @sorted = sort { ($a + 0) <=> ($b + 0) }@api_list;
return $sorted[0];
}
sub findArLibs {
my $path_to_api_dir = shift;
my $cwd = getcwd();
my $ar_lib_dir = join('/', $path_to_api_dir, 'lib');
chdir($ar_lib_dir);
# we want all of the files that end in .lib on win32
my @libs = <*.lib>;
chdir($cwd);
return \@libs;
}
sub ARS_VERSION_45 { 7; }
sub ARS_VERSION_50 { 8; }
sub ARS_VERSION_51 { 9; }
sub ARS_VERSION_60 { 10; }
sub ARS_VERSION_63 { 11; }
sub ARS_VERSION_70 { 12; }
sub ARS_VERSION_71 { 13; }
sub ARS_VERSION_75 { 14; }
sub ARS_VERSION_760 { 15; }
sub ARS_VERSION_762 { 16; }
sub ARS_VERSION_763 { 17; }
sub ARS_VERSION_764 { 18; }
sub ARS_VERSION_80 { 19; }
sub ARS_VERSION_81 { 20; }
## @Devs: set the following constant always to the latest version supported by ARSPerl
sub ARS_MAX_API { ARS_VERSION_81; }
sub ARSVersionString {
my $APIVersionID = shift;
my $api2Version = {
&ARS_VERSION_45 => '4.5',
&ARS_VERSION_50 => '5.0',
&ARS_VERSION_51 => '5.1',
&ARS_VERSION_60 => '6.0',
&ARS_VERSION_63 => '6.3',
&ARS_VERSION_70 => '7.0',
&ARS_VERSION_71 => '7.1',
&ARS_VERSION_75 => '7.5',
example/Dump_Setup.pl view on Meta::CPAN
die "login error: $ars_errstr\n" unless defined($c);
@schema = ars_GetListSchema($c, 0, 1024);
@active = ars_GetListActiveLink($c);
@filter = ars_GetListFilter($c);
@escal = ars_GetListEscalation($c);
@menu = ars_GetListCharMenu($c);
@admin_ext = ars_GetListAdminExtension($c);
# Warning! this might make several names map to the same file
sub name_to_path {
my $name = shift;
$name =~ s/ /_/g;
$name =~ s/\//:/g;
return $name;
}
sub dump_type {
my ($path, $type, $names) = @_;
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);
example/Dump_Users_OO.pl view on Meta::CPAN
# minor change to exception handler
#
# Revision 1.1 1999/05/05 19:57:40 rgc
# Initial revision
#
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"
example/GetCharMenu.pl view on Meta::CPAN
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;
}
}
example/GetCharMenu.pl view on Meta::CPAN
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
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" ) {
example/GetFilter.pl view on Meta::CPAN
$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;
}
}
example/GetFilter.pl view on Meta::CPAN
#
# 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 {
example/GetFilter.pl view on Meta::CPAN
}
}
# 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});
example/GetFilter.pl view on Meta::CPAN
}
}
}
# 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});
example/GetFilter.pl view on Meta::CPAN
}
}
# 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";
example/GetFilter.pl view on Meta::CPAN
# 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});
example/GetFilter.pl view on Meta::CPAN
# 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.
#
# AUTHOR
# jeff murphy
sub Decode_opSetMask {
my $m = shift;
my $s, $v;
if(defined($m)) {
foreach $v (sort keys %ars_opSet) {
if($v & $m) {
$s = $s.$ars_opSet{$v}." ";
}
}
}
return($s);
}
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 "");
example/Show_ALink.pl view on Meta::CPAN
}
$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;
}
}
example/Show_ALink.pl view on Meta::CPAN
$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};
}
}
}
example/Show_ALink.pl view on Meta::CPAN
#
# 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 {
example/Show_ALink.pl view on Meta::CPAN
}
}
# 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});
example/Show_ALink.pl view on Meta::CPAN
}
}
}
# 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});
example/Show_ALink.pl view on Meta::CPAN
}
}
# 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";
example/Show_ALink.pl view on Meta::CPAN
}
}
# 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";
example/Show_ALink.pl view on Meta::CPAN
# 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})) {
example/Show_ALink.pl view on Meta::CPAN
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 "");
example/Show_Menu.pl view on Meta::CPAN
($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;
my $i = shift;
my @m = @$m;
my $name, $val;
$i = 0 unless $i;
while (($name, $val, @m) = @m) {
if (ref($val)) {
IndPrint($i, "SubMenu: $name\n");
example/WhoUsesIt.pl view on Meta::CPAN
# 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_GetEntryBLOB.pl view on Meta::CPAN
foreach (keys %v) {
print "$r{$_} = $v{$_}\n";
dh($v{$_}) if $r{$_} =~ /Attachment/;
ra($_) if $r{$_} =~ /Attachment/;
}
ars_Logoff($c);
exit 0;
#sub AR_LOC_FILENAME { 1;}
#sub AR_LOC_BUFFER { 2;}
sub ra {
my $fid = shift;
print "\t[Retrieving attachment.]\n";
# file: $a = 0 || 1
# buff: $a = undef || attachment
unlink('/tmp/attachtest', '/tmp/attachtest2');
example/ars_GetEntryBLOB.pl view on Meta::CPAN
$fid,
ARS::AR_LOC_BUFFER);
die "GetEntryBLOB: $ars_errstr" if(!defined($a));
print "\tattachment size = ".length($a)."\n";
open(FD, ">/tmp/attachtest2") || die "open: $!";
print FD $a;
close(FD);
}
sub dh {
my $h = shift;
foreach (keys %$h) {
print "\t$_ = $h->{$_}\n";
}
}
example/ars_QualDecode.pl view on Meta::CPAN
# We need the ctrl struct and schema name so
# we can reverse map from fieldId's to field names.
#
# RETURNS
# a scalar on success
# undef on failure
#
# AUTHOR
# jeff murphy
sub ars_Decode_QualHash {
my $c = shift;
my $s = shift;
my $q = shift;
my $fids;
my %fids_orig;
my $fieldName;
print "ars_Decode_QualHash(c=$c, s=$s, q=$q)\n" if !$debug;
if(!(defined($c) && (ref($c) eq "ARControlStructPtr"))) {
example/ars_QualDecode.pl view on Meta::CPAN
}
(%fids_orig = ars_GetFieldTable($c, $s)) ||
die "GetFieldTable: $ars_errstr";
foreach $fieldName (keys %fids_orig) {
$fids{$fids_orig{$fieldName}} = $fieldName;
}
return ars_DQH($q, %fids);
}
sub ars_DQH {
my $h = shift;
my $fids = shift;
my $e = undef;
print "ars_DQH(h=$h, fids=$fids)\n" if $debug;
if($h) {
print "\n
left = $h->{left}
example/ars_QualDecode.pl view on Meta::CPAN
else {
$e .= "(".Decode_FVoAS($h->{left}, $fids)." ".$h->{oper}." ".Decode_FVoAS($h->{right}, $fids).")";
}
} else {
print "WARNING: ars_DQH: invalid params\n";
}
return $e;
}
sub Decode_FVoAS {
my $h = shift;
my $fids = shift;
my $e = "";
# my $f;
# print "keys:\n";
# foreach $f (keys %$h) {
# print "$f <".$h->{$f}.">\n";
# }
# print "\n";
example/attachTest.pl view on Meta::CPAN
foreach (keys %v) {
print "$r{$_} = $v{$_}\n";
dh($v{$_}) if $r{$_} eq "Attachment Field";
ra($_) if $r{$_} eq "Attachment Field";
}
ars_Logoff($c);
exit 0;
#sub AR_LOC_FILENAME { 1;}
#sub AR_LOC_BUFFER { 2;}
sub ra {
my $fid = shift;
print "\t[Retrieving attachment.]\n";
# file: $a = 0 || 1
# buff: $a = undef || attachment
ars_GetEntryBLOB($c, "ARSperl Test", $id,
example/attachTest.pl view on Meta::CPAN
$fid,
ARS::AR_LOC_BUFFER);
die "GetEntryBLOB: $ars_errstr" if(!defined($a));
print "\tattachment size = ".length($a)."\n";
open(FD, ">/tmp/attachtest2") || die "open: $!";
print FD $a;
close(FD);
}
sub dh {
my $h = shift;
foreach (keys %$h) {
print "\t$_ = $h->{$_}\n";
}
}
example/getAttachment-OO.pl view on Meta::CPAN
print "field/value dump:\n";
foreach (keys %v) {
print "$_ = $v{$_}\n";
dh($v{$_}) if $s->getFieldType(-field => $_) eq "attach";
ra($_) if $s->getFieldType(-field => $_) eq "attach";
}
exit 0;
sub ra {
my $field = shift;
print "\t[Retrieving attachment.]\n";
# file: $a = 0 || 1
# buff: $a = undef || attachment
$s->getAttachment(-entry => "000000000000002",
-field => $field,
-file => "/tmp/attachtest");
example/getAttachment-OO.pl view on Meta::CPAN
-field => $field);
print "\tattachment size = ".length($a)."\n";
open(FD, ">/tmp/attachtest2") || die "open: $!";
print FD $a;
close(FD);
# if you "cmp" the files, they should be identical.
}
sub dh {
my $h = shift;
foreach (keys %$h) {
print "\t$_ = $h->{$_}\n";
}
}
infra/exsi.pl view on Meta::CPAN
!defined($artype);
print "\t{ $sin,\t".typemap($sit)." }, /* $siv */\n";
}
}
footer();
exit 0;
sub typemap {
my $t = shift;
my %m = ( 'int' => 'AR_DATA_TYPE_INTEGER',
'long' => 'AR_DATA_TYPE_INTEGER',
'real' => 'AR_DATA_TYPE_REAL',
'char' => 'AR_DATA_TYPE_CHAR',
'String' => 'AR_DATA_TYPE_CHAR',
'diary' => 'AR_DATA_TYPE_DIARY',
'enum' => 'AR_DATA_TYPE_ENUM',
'time' => 'AR_DATA_TYPE_TIME',
'bitmask' => 'AR_DATA_TYPE_BITMASK',
'bytes' => 'AR_DATA_TYPE_BYTES'
);
$t =~ s/unsigned\s//g;
return $m{$t} if ( defined($m{$t}) );
return undef;
}
sub header {
print "
/* DO NOT EDIT. this file was automatically generated by
$0 on ".scalar localtime()." */
#ifndef __ServerInfoTypeHints__
#define __ServerInfoTypeHints__
static struct {
unsigned int infoTypeNum;
unsigned int infoTypeType;
} ServerInfoTypeHints[] = {
";
}
sub footer {
print "
{ TYPEMAP_LAST, TYPEMAP_LAST }
};
#endif /* __ServerInfoTypeHints__ */
";
}
}
s/^\s+//;
expr();
$new =~ s/(["\\])/\\$1/g; #"]);
$new = reindent($new);
$args = reindent($args);
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g; #']);
if ($opt_h) {
print OUT $t,
"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
$eval_index++;
} else {
print OUT $t,
"eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
}
} else {
print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
}
%curargs = ();
} else {
s/^\s+//;
expr();
$new = 1 if $new eq '';
$new = reindent($new);
$args = reindent($args);
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g; #']);
if ($opt_h) {
print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
$eval_index++;
} else {
print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
}
} else {
# Shunt around such directives as `#define FOO FOO':
next if " \&$name" eq $new;
print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
}
}
} elsif (/^(include|import)\s*[<"](.*)[>"]/) {
($incl = $2) =~ s/\.h$/.ph/;
# print OUT $t,"require '$incl';\n"; ### TS, don't require artypes.ph
} elsif(/^include_next\s*[<"](.*)[>"]/) {
($incl = $1) =~ s/\.h$/.ph/;
print OUT ($t,
"eval {\n");
$tab += 4;
(my $enum_subs = $3) =~ s/\s//g;
my @enum_subs = split(/,/, $enum_subs);
my $enum_val = -1;
foreach my $enum (@enum_subs) {
my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
$enum_value =~ s/^=//;
$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
if ($opt_h) {
print OUT ($t,
"eval(\"\\n#line $eval_index $outfile\\n",
"sub $enum_name () \{ $enum_val; \}\") ",
"unless defined(\&$enum_name);\n");
++ $eval_index;
} else {
print OUT ($t,
"eval(\"sub $enum_name () \{ $enum_val; \}\") ",
"unless defined(\&$enum_name);\n");
}
}
}
}
print OUT "1;\n";
$Is_converted{$file} = 1;
queue_includes_from($file) if ($opt_a);
}
exit $Exit;
sub reindent($) {
my($text) = shift;
$text =~ s/\n/\n /g;
$text =~ s/ /\t/g;
$text;
}
sub expr {
my $joined_args;
if(keys(%curargs)) {
$joined_args = join('|', keys(%curargs));
}
while ($_ ne '') {
s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
s/^(\s+)// && do {$new .= ' '; next;};
s/^0X([0-9A-F]+)[UL]*//i
&& do {my $hex = $1;
$new .= ' &' . $id;
}
}
next;
};
s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
}
}
sub next_line
{
my $file = shift;
my ($in, $out);
my $pre_sub_tri_graphs = 1;
READ: while (not eof IN) {
$in .= <IN>;
chomp $in;
next unless length $in;
last READ if $out =~ /\S/;
}
return $out;
}
# Handle recursive subdirectories without getting a grotesquely big stack.
# Could this be implemented using File::Find?
sub next_file
{
my $file;
while (@ARGV) {
$file = shift @ARGV;
if ($file eq '-' or -f $file or -l $file) {
return $file;
} elsif (-d $file) {
if ($opt_r) {
} else {
print STDERR "Skipping `$file': not a file or directory\n";
}
}
return undef;
}
# Put all the files in $directory into @ARGV for processing.
sub expand_glob
{
my ($directory) = @_;
$directory =~ s:/$::;
opendir DIR, $directory;
foreach (readdir DIR) {
next if ($_ eq '.' or $_ eq '..');
# expand_glob() is going to be called until $ARGV[0] isn't a
if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
else { unshift @ARGV, "$directory/$_" }
}
closedir DIR;
}
# Given $file, a symbolic link to a directory in the C include directory,
# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
# Otherwise, just duplicate the file or directory.
sub link_if_possible
{
my ($dirlink) = @_;
my $target = eval 'readlink($dirlink)';
if ($target =~ m:^\.\./: or $target =~ m:^/:) {
# The target of a parent or absolute link could leave the $Dest_dir
# hierarchy, so let's put all of the contents of $dirlink (actually,
# the contents of $target) into @ARGV; as a side effect down the
# line, $dirlink will get created as an _actual_ directory.
expand_glob($dirlink);
}
} else {
print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
}
}
}
# Push all #included files in $file onto our stack, except for STDIN
# and files we've already processed.
sub queue_includes_from
{
my ($file) = @_;
my $line;
return if ($file eq "-");
open HEADER, $file or return;
while (defined($line = <HEADER>)) {
while (/\\$/) { # Handle continuation lines
chop $line;
if ($line =~ /^#\s*include\s+<(.*?)>/) {
push(@ARGV, $1) unless $Is_converted{$1};
}
}
close HEADER;
}
# Determine include directories; $Config{usrinc} should be enough for (all
# non-GCC?) C compilers, but gcc uses an additional include directory.
sub inc_dirs
{
my $from_gcc = `$Config{cc} -v 2>&1`;
$from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
}
# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
# version of h2ph.
sub build_preamble_if_necessary
{
# Increment $VERSION every time this function is modified:
my $VERSION = 2;
my $preamble = "$Dest_dir/_h2ph_pre.ph";
# Can we skip building the preamble file?
if (-r $preamble) {
# Extract version number from first line of preamble:
open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
my $line = <PREAMBLE>;
open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
print PREAMBLE "# This file was created by h2ph version $VERSION\n";
foreach (sort keys %define) {
if ($opt_D) {
print PREAMBLE "# $_=$define{$_}\n";
}
if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
print PREAMBLE
"unless (defined &$_) { sub $_() { $1 } }\n\n";
} elsif ($define{$_} =~ /^\w+$/) {
print PREAMBLE
"unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
} else {
print PREAMBLE
"unless (defined &$_) { sub $_() { \"",
quotemeta($define{$_}), "\" } }\n\n";
}
}
close PREAMBLE or die "Cannot close $preamble: $!";
}
# %Config contains information on macros that are pre-defined by the
# system's compiler. We need this information to make the .ph files
# function with perl as the .h files do with cc.
sub _extract_cc_defines
{
my %define;
my $allsymbols = join " ",
@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
# Split compiler pre-definitions into `key=value' pairs:
foreach (split /\s+/, $allsymbols) {
/(.+?)=(.+)/ and $define{$1} = $2;
if ($opt_D) {
infra/mkchanges.pl view on Meta::CPAN
if($html) {
footerHTML();
} else {
footerTXT();
}
exit 0;
sub spewHTML {
my ($f, $rel, $ver) = (shift, shift, shift);
my ($first) = 1;
my ($beenthere) = 0;
my ($count) = 0;
while(<$f>) {
chomp;
s/\r//g;
if(/^$/) {
infra/mkchanges.pl view on Meta::CPAN
print "<font color='black'>";
}
print "$_ \n";
} else {
s/^\s+//g;
print "$_ ";
}
}
}
sub spewTXT {
my ($f, $rel, $ver) = (shift, shift, shift);
my ($bq) = 0;
print "Released: $rel Version: $ver\n\n";
while(<$f>) {
chomp;
s/<[\/]{0,1}U>/_/gi;
$bq = 1 if(/\<BLOCKQUOTE\>/i);
$bq = 0 if(/\<\/BLOCKQUOTE>/i);
infra/mkchanges.pl view on Meta::CPAN
s/^\s+//g;
my $fmt = "%5.5s %s %s\n";
$fmt = "%s %s\t\t%s\n" if $bq;
printf($fmt, ' ', ' ', $_);
}
}
}
sub headerHTML {
print "<html><head><title> ARSperl: Revision History </title></head>\n";
print "
<body bgcolor='white' text='black'><h2>Changes for ARSperl</h2>
<table border='0'>
<tr><td>BM</td><td>=</td><td>Bill Middleton {wjm at metronet.com}</td></tr>
<tr><td>GDF</td><td>=</td><td>G. David Frye {gdf at uiuc.edu}</td></tr>
<tr><td>JCM</td><td>=</td><td>Jeff Murphy {jeffmurphy at sourceforge.net}</td></tr>
<tr><td>JWM</td><td>=</td><td>Joel Murphy {jmurphy at buffalo.edu}</td></tr>
<tr><td>TS</td><td>=</td><td>Thilo Stapff {tstapff at sourceforge.net}</td></tr>
<tr><td>CL</td><td>=</td><td>Chris Leach {Chris.Leach at kaz-group.com}</td></tr>
infra/mkchanges.pl view on Meta::CPAN
The following lists the changes that have been made
for each release of ARSperl.
<P>
Items in <font color='red'>red</font>
denote changes that are incompatible with
previous versions of ARSperl and may require altering of some ARSperl
scripts.<P>
";
}
sub footerHTML {
print "\n<P>\n<PRE>\$Header\$</PRE></body></html>\n";
}
sub headerTXT {
print "CHANGES for ARSperl
Revision history for ARSperl.
BM = Bill Middleton <wjm at metronet.com>
GDF = G. David Frye <gdf at uiuc.edu>
JCM = Jeff Murphy <jcmurphy at buffalo.edu>
JWM = Joel Murphy <jmurphy at buffalo.edu>
TS = Thilo Stapff <tstapff at sourceforge.net>
CL = Chris Leach <Chris.Leach at kaz-group.com>
JL = John Luthgers <jls17 at gmx.net>
Note: items preceeded by a '!' denoted changes that are incompatible with
previous versions of arsperl and may require altering of some arsperl
scripts.\n\n
";
}
sub footerTXT {
print "\n\narsperl\@arsperl.org\n\n\$Header\$\n\n";
}
rev_AR_template.pl view on Meta::CPAN
return -1;
}
return 0;
}
<@ versionEndif($obj) @>
@> }
@> sub perlToStruct {
@> my( $obj, $class, $LINE_INDENT ) = @_;
{
@> if( $obj->{_data} ){
@> my( $type, $data ) = ( $obj->{_type}, $obj->{_data} );
@> if( $obj->{_map} ){
int flag = 0;
@> foreach my $key ( keys %{$obj->{_map}} ){
if( !strcmp(SvPV_nolen(*val),"<@ $obj->{_map}{$key} @>") ){
<@ $obj->{_data} @> = <@ $key @>;
flag = 1;
rev_AR_template.pl view on Meta::CPAN
SV *
perl_<@ $class @>( ARControlStruct *ctrl, <@ $class @> *p ){
SV *ret;
@> structToPerl( $obj, "\t" );
return ret;
}
@> }
@> sub structToPerl {
@> my( $obj, $LINE_INDENT ) = @_;
{
@> if( $obj->{_data} ){
@> my( $type, $data ) = ( $obj->{_type}, $obj->{_data} );
SV *val;
<@ perlCopy($type,'val',$data) @>;
ret = val;
@> }elsif( $obj->{_switch} ){
SV *val;
rev_AR_template.pl view on Meta::CPAN
$ARS::CodeTemplate::DEF_CODE = ARS::CodeTemplate::compile( $ARS::CodeTemplate::TPT_CODE );
ARS::CodeTemplate::procdef( $ARS::CodeTemplate::DEF_CODE );
#use UTAN::Util;
#UTAN::Util::modFileByRegex( 'functions.c', 's/^(\s*)rev_ARQualifierStruct\(.*/$1p->qualifier.operation = AR_OPERATION_NONE;/' );
#--- EDIT HERE ---
sub evalTemplate {
my( $tag, $type, $L, $R ) = @_;
# print STDERR "evalTemplate( $tag, $type, $L, $R )\n"; # _DEBUG_
$tag = lc($tag);
$tag =~ s/^(?=[^_])/_/;
my( $tpDef, $tp ) = ( $TEMPLATES{$tag} );
if( !defined $tpDef ){
die "NO TEMPLATE GROUP\n", "\$tag <$tag> \$type <$type> \$L <$L> \$R <$R>\n"; # _DEBUG_
# exit 1;
}
rev_AR_template.pl view on Meta::CPAN
$baseType =~ s/\*$//;
my %val = ( L => $L, R => $R, T => $type, B => $baseType );
map {$val{$_} = $match[$_]} (1..$#match) if $#match >= 1;
# print "\$rx <", $rx, "> \@match <", join('|',@match), "> \%val <", join('|',%val), ">\n"; # _DEBUG_
$tp =~ s/\%([LRTB0-9])\b/$val{$1}/g;
return $tp;
}
sub typeCopy {
my( $type, $L, $R ) = @_;
$type = $CONVERT{$type}{_typedef} while defined $CONVERT{$type}{_typedef};
my $str = evalTemplate( '_copy', $type, $L, $R );
return $str;
}
sub perlCopy {
my( $type, $L, $R ) = @_;
$type = $CONVERT{$type}{_typedef} while defined $CONVERT{$type}{_typedef};
my $str = evalTemplate( '_perl', $type, $L, $R );
return $str;
}
sub keyFilter {
my( $hRef, @fkey ) = @_;
my @list;
foreach my $fkey ( @fkey ){
foreach my $key ( keys %$hRef ){
push @list, $key if findSubKey($hRef->{$key},$fkey);
}
}
# print STDERR "\@list <", join('|',@list), ">\n"; # _DEBUG_
return @list;
}
sub findSubKey {
my( $hRef, $fkey ) = @_;
my $ret = 0;
if( ref($hRef) eq 'HASH' ){
foreach my $key ( keys %$hRef ){
if( $key eq $fkey ){
$ret = 1;
}else{
$ret = findSubKey( $hRef->{$key}, $fkey );
}
last if $ret == 1;
}
}
return $ret;
}
sub versionIf {
my( $obj ) = @_;
if( $obj->{_min_version} && $obj->{_max_version} ){
return '#if AR_CURRENT_API_VERSION >= '. $CURRENT_API_VERSION{$obj->{_min_version}} .' && AR_CURRENT_API_VERSION <= '. $CURRENT_API_VERSION{$obj->{_max_version}};
}elsif( $obj->{_min_version} ){
return '#if AR_CURRENT_API_VERSION >= ' . $CURRENT_API_VERSION{$obj->{_min_version}};
}elsif( $obj->{_max_version} ){
return '#if AR_CURRENT_API_VERSION <= ' . $CURRENT_API_VERSION{$obj->{_max_version}};
}else{
return '';
}
}
sub versionEndif {
my( $obj ) = @_;
if( $obj->{_min_version} || $obj->{_max_version} ){
return '#endif';
}else{
return '';
}
}
for (i = 0; i < which->u.menuList.numItems; i++) {
string = which->u.menuList.charMenuList[i].menuLabel;
av_push(array, newSVpv(string, strlen(string)));
switch (which->u.menuList.charMenuList[i].menuType) {
case AR_MENU_TYPE_VALUE:
string = which->u.menuList.charMenuList[i].u.menuValue;
av_push(array, newSVpv(string, strlen(string)));
break;
case AR_MENU_TYPE_MENU:
sub = perl_expandARCharMenuStruct(ctrl,
which->u.menuList.charMenuList[i].u.childMenu);
if (!sub) {
FreeARCharMenuStruct(&menu, FALSE);
return &PL_sv_undef;
}
av_push(array, sub);
break;
case AR_MENU_TYPE_NONE:
default:
av_push(array, &PL_sv_undef);
t/10entry.t view on Meta::CPAN
#
# test out creating and deleting an entry
#
use ARS;
require './t/config.cache';
# notice the use of a custom error handler.
sub mycatch {
my ($type, $msg) = (shift, shift);
die "not ok ($msg)\n";
}
if(ars_APIVersion() >= 4) {
print "1..10\n";
} else {
print "1..7\n";
}
t/11entry.t view on Meta::CPAN
# to test for memory leaks. by default, we bypass this test
# because it takes a long time and the user needs to do
# extra work to watch process-size, etc.
use ARS;
require './t/config.cache';
# notice the use of a custom error handler.
sub mycatch {
my ($type, $msg) = (shift, shift);
die "not ok ($msg)\n";
}
print "1..5\n";
if( 1 ) { # BYPASS
for(my $i = 1 ; $i < 6 ; $i++) {
print "ok [$i]\n";
}
t/31createschema.t view on Meta::CPAN
foreach my $form ( @forms ){
next if $form =~ / \((copy|renamed)\)$/;
my $formNew = "$form (copy)";
ars_DeleteSchema( $ctrl, $formNew, 1 );
copyForm( $ctrl, $form, $formNew );
}
my $formType;
sub copyForm {
my( $ctrl, $form, $formNew ) = @_;
print '-' x 60, "\n";
# print "GET SCHEMA $form\n";
my $formObj = ars_GetSchema( $ctrl, $form );
die "ars_GetSchema( $form ): $ars_errstr\n" if $ars_errstr;
my $formType = $formObj->{schema}{schemaType};
$formObj->{name} = $formNew;
$formObj->{changeDiary} = "Init";
my( $aGetListFields, $aIndexList, $aSortList, $hArchiveInfo, $hAuditInfo );
t/31createschema.t view on Meta::CPAN
$schemaInfo{sortList} = $aSortList if $aSortList;
# $schemaInfo{archiveInfo} = $hArchiveInfo if $hArchiveInfo;
$schemaInfo{auditInfo} = $hAuditInfo if $hAuditInfo;
print "SET SCHEMA $formNew\n";
$ret = ars_SetSchema( $ctrl, $formNew, \%schemaInfo );
warn "ars_SetSchema( $formNew ): $ars_errstr\n" if $ars_errstr;
printStatus( $ret, 6, 'set schema' );
}
sub printStatus {
my( $ret, $num, $text, $err ) = @_;
if( $ret ){
print "ok [$num] ($text)\n";
} else {
print "not ok [$num] ($text $err)\n";
exit(0);
}
}
t/32createcontainer.t view on Meta::CPAN
foreach my $ctnr ( @containers ){
next if $ctnr =~ / \((copy|renamed)\)$/;
my $ctnrNew = "$ctnr (copy)";
ars_DeleteContainer( $ctrl, $ctnrNew );
copyContainer( $ctrl, $ctnr, $ctnrNew );
}
sub copyContainer {
my( $ctrl, $ctnr, $ctnrNew ) = @_;
print '-' x 60, "\n";
# print "GET CONTAINER $ctnr\n";
my $ctnrObj = ars_GetContainer( $ctrl, $ctnr );
die "ars_GetContainer( $ctnr ): $ars_errstr\n" if $ars_errstr;
# my $ctnrType = $ctnrObj->{containerType};
# use Data::Dumper;
# $Data::Dumper::Sortkeys = 1;
# print Data::Dumper->Dump( [$ctnrObj], ['ctnrObj'] );
t/32createcontainer.t view on Meta::CPAN
}
$ctnrObj->{changeDiary} = "Init";
my $ret = 1;
print "CREATE CONTAINER $ctnrNew\n";
$ret = ars_CreateContainer( $ctrl, $ctnrObj );
die "ars_CreateContainer( $ctnrNew ): $ars_errstr\n" if $ars_errstr;
printStatus( $ret, 2, 'create container' );
}
sub printStatus {
my( $ret, $num, $text, $err ) = @_;
if( $ret ){
print "ok [$num] ($text)\n";
} else {
print "not ok [$num] ($text $err)\n";
exit(0);
}
}
t/33setcontainer.t view on Meta::CPAN
foreach my $obj ( @objects ){
next if $obj !~ / \(copy\)$/;
my $objNew = $obj;
$objNew =~ s/ \(copy\)$/ (renamed)/;
ars_DeleteContainer( $ctrl, $objNew );
modifyObject( $ctrl, $obj, $objNew );
}
sub modifyObject {
my( $ctrl, $name, $newName ) = @_;
print '-' x 60, "\n";
# print "GET CONTAINER $ctnr\n";
my $ctnrObj = ars_GetContainer( $ctrl, $name );
die "ars_GetContainer( $name ): $ars_errstr\n" if $ars_errstr;
# my $ctnrType = $ctnrObj->{containerType};
my @refList = @{$ctnrObj->{referenceList}};
unshift @refList, makeRef(
t/33setcontainer.t view on Meta::CPAN
label => '==== END ====',
);
my $ret = 1;
print "SET CONTAINER $name\n";
$ret = ars_SetContainer( $ctrl, $name, {name => $newName, referenceList => \@refList} );
die "ars_SetContainer( $name ): $ars_errstr\n" if $ars_errstr;
printStatus( $ret, 2, 'set container' );
}
sub printStatus {
my( $ret, $num, $text, $err ) = @_;
if( $ret ){
print "ok [$num] ($text)\n";
} else {
print "not ok [$num] ($text $err)\n";
exit(0);
}
}
sub makeRef {
my( %args ) = @_;
$args{label} = '' if !exists $args{label};
$args{description} = '' if !exists $args{description};
if( $args{dataType} == 1 ){
$args{permittedGroups} = [] if !exists $args{permittedGroups};
$args{value} = undef if !exists $args{value};
$args{value_dataType} = 'null' if !exists $args{value_dataType};
}
return \%args;
}
t/34createactlink.t view on Meta::CPAN
foreach my $obj ( @objects ){
next if $obj =~ / \((copy|renamed)\)$/;
my $objNew = "$obj (copy)";
ars_DeleteActiveLink( $ctrl, $objNew );
copyObject( $ctrl, $obj, $objNew );
}
sub copyObject {
my( $ctrl, $obj, $objNew ) = @_;
print '-' x 60, "\n";
# print "GET ACTIVE LINK $ctnr\n";
my $wfObj = ars_GetActiveLink( $ctrl, $obj );
die "ars_GetActiveLink( $obj ): $ars_errstr\n" if $ars_errstr;
#use Data::Dumper;
#$Data::Dumper::Sortkeys = 1;
#my $data = $ctnrObj;
#my $file = '-';
t/34createactlink.t view on Meta::CPAN
if( $ars_errstr ){
if( $ars_errstr =~ /\[ERROR\]/ ){
die "ars_CreateActiveLink( $objNew ): $ars_errstr\n";
}else{
warn "ars_CreateActiveLink( $objNew ): $ars_errstr\n";
}
}
printStatus( $ret, 2, 'create active link' );
}
sub printStatus {
my( $ret, $num, $text, $err ) = @_;
if( $ret ){
print "ok [$num] ($text)\n";
} else {
print "not ok [$num] ($text $err)\n";
exit(0);
}
}
( run in 0.509 second using v1.01-cache-2.11-cpan-4d50c553e7e )