ARSperl
view release on metacpan or search on metacpan
sub TIESCALAR {
bless {};
}
sub FETCH {
my($s, $i) = (undef, undef);
my(%mTypes) = ( 0 => "OK", 1 => "WARNING", 2 => "ERROR", 3 => "FATAL",
4 => "INTERNAL ERROR",
-1 => "TRACEBACK");
for($i = 0; $i < $ARS::ars_errhash{numItems}; $i++) {
# If debugging is not enabled, don't show traceback messages
if($ARS::DEBUGGING == 1) {
$s .= sprintf("[%s] %s (ARERR \#%d)",
$mTypes{@{$ARS::ars_errhash{messageType}}[$i]},
@{$ARS::ars_errhash{messageText}}[$i],
@{$ARS::ars_errhash{messageNum}}[$i]);
$s .= "\n" if($i < $ARS::ars_errhash{numItems}-1);
} else {
if(@{$ARS::ars_errhash{messageType}}[$i] != -1) {
$s .= sprintf("[%s] %s (ARERR \#%d)",
ARS/CodeTemplate.pm view on Meta::CPAN
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;
}
ARS/CodeTemplate.pm view on Meta::CPAN
$line =~ s/\\/\\\\/g;
$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;
}
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 = '-';
}
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();
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
# 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
$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,
"[1] unable to translate enumeration value for field '$f'");
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;
if(!defined($this->{'fieldEnumValues'}->{$f}) ||
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/OOsup.pm view on Meta::CPAN
# 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));
$self->initCatch();
# what error handlers should be called automatically by the OO layer?
# if a handler is 'undef' then the OO layer will ignore that type of
# exception (warning, error or fatal). it is then upto the user to
# check ->hasErrors(), etc.
# this should be a hash ref.
if(defined($catch) && ref($catch) ne "HASH") {
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;
(BM) fixed a couple of small typos, including one in a elliptical
declaration (...) which didn't have a comma separator.
(BM) Changed the logic of CVLD in one place that was attempting to free()
null pointers.
Released: 03/31/98 Version: 1.56
(JCM) fixed a problem caused by some debugging code that
was left in 1.55 accidentally.
Released: 03/30/98 Version: 1.55
(JCM) added ars_GetListEntry.pl example to show how to use
custom query-list fields.
(JCM) numerous documentation updates by {D.J.Adams at soton.ac.uk}
(JCM) added ars_GetControlStructFields()
Released: 10/20/97 Version: 1.5203
(JCM) beginnings of a WinNT port (not completed yet)
(JCM) added "timestamp" to the return hash of GetEscalation()
(JCM) added some extra malloc/free debugging stuff
Released: 10/13/97 Version: 1.5202
(JCM) removed a superfluous debugging statement
Released: 10/09/97 Version: 1.5201
(JCM) fixed problem in GetEscalation
Released: 10/08/97 Version: 1.52
html/manual/ars_GetListFilter.html
html/manual/ars_GetClientCharSet.html
html/manual/ars_GetListActiveLink.html
html/manual/ars_GetListUser.html
html/manual/ds_prop_hash.html
html/manual/ars_decodeStatusHistory.html
html/manual/ars_DeleteCharMenu.html
html/manual/ars_Import.html
html/manual/ars_RegisterForAlerts.html
html/changes.html
html/debug.html
html/DumpSetup.html
Makefile
t/33setcontainer.t
t/40createcharmenu.t
t/01import.t
t/20merge.t
t/31createschema.t
t/35setactlink.t
t/aptest.def
t/10getescalation.t
Makefile.PL view on Meta::CPAN
#
# run with "perl Makefile.PL" then type "make"
#
require 5.005;
use ExtUtils::MakeMaker;
use Config;
use Cwd;
$debug = 0;
###### There are FOUR (4) steps to complete. Complete all of them. ######
# STEP 1 -> Set the path to your ARS API directory
$ARSAPI = "C:/Replication/Remedy/7.6.4";
# STEP 2 -> Choose architecture dependent suffix for library names, if necessary
$ARCHITECTURE = "";
Makefile.PL view on Meta::CPAN
$AUTODEFINES = " -g ";
$AUTODEFINES = " -D_WIN32 " if($WINDOWS);
$AUTODEFINES .= " -Wno-unused-variable -Wuninitialized " if $Config{'cc'} eq "gcc";
$AUTODEFINES .= " -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_WARNINGS " if $WINDOWS && $ENV{ARSPERLTEST_PARAM};
$AUTODEFINES .= " -DARSPERL_UNDEF_MALLOC " if $ADVANCED_CONFIG{UNDEF_PERL_MALLOC};
$AUTODEFINES .= " -DGETLISTGROUP_OLD_STYLE " if $ADVANCED_CONFIG{GETLISTGROUP_OLD_STYLE};
$AUTODEFINES .= " -DARSPERL_DEBUG " if $debug;
$ARS_STATIC_LIB = "";
$PM = { 'ARS.pm' => '$(INST_LIBDIR)/ARS.pm' };
foreach my $pm2install (qw{arerrno-h.pm ar-h.pm nparm.pm OOform.pm OOmsgs.pm OOsup.pm}) {
$PM->{'ARS/'.$pm2install} = '$(INST_LIBDIR)/ARS/'.$pm2install;
}
$LARCH = $ARCHITECTURE ? "_".$ARCHITECTURE : "";
Makefile.PL view on Meta::CPAN
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);
changes.dat view on Meta::CPAN
including ARSDoc-1.11 (with small patch submitted to list) now
run, and produce the right results.
BM Removed all references to ZEROMEM in favor of perl's Zero, which
is guaranteed to work everywhere, and doesn't need additional logic.
BM fixed a couple of small typos, including one in a elliptical
declaration (...) which didn't have a comma separator.
BM Changed the logic of CVLD in one place that was attempting to free()
null pointers.
released=03/31/98 version=1.56
JCM fixed a problem caused by some debugging code that
was left in 1.55 accidentally.
released=03/30/98 version=1.55
JCM added ars_GetListEntry.pl example to show how to use
custom query-list fields.
JCM numerous documentation updates by {D.J.Adams at soton.ac.uk}
JCM fixed bug in macroParm decoding. {D.J.Adams at soton.ac.uk}
JCM fixed bug when decoding results of GetFilter/GetActiveLink
in regards to set fields actions: values assigned to
diary fields were not being interpretted correctly.
changes.dat view on Meta::CPAN
released=11/04/97 version=1.5205
JCM updated the groupList value returned by GetSchema()
so that it contains the correct key words.
released=10/29/97 version=1.5204
JCM added ars_GetControlStructFields()
released=10/20/97 version=1.5203
JCM beginnings of a WinNT port (not completed yet)
JCM added "timestamp" to the return hash of GetEscalation()
JCM added some extra malloc/free debugging stuff
released=10/13/97 version=1.5202
JCM removed a superfluous debugging statement
released=10/09/97 version=1.5201
JCM fixed problem in GetEscalation
released=10/08/97 version=1.52
JCM fixed core dump problem due to uninitialized variable(s)
released=10/07/97 version=1.51
JCM fixed some typos/symbol errors. added a missing routine.
example/DelUsersFromGroup.pl view on Meta::CPAN
# DelUsersFromGroup group user1 [user2] ...
#
# DESCRIPTION
# add given users to specified group
#
# AUTHOR
# jeff murphy
#
# $Log: DelUsersFromGroup.pl,v $
# Revision 1.2 1998/09/14 20:50:08 jcmurphy
# removed some debugging statements
#
# Revision 1.1 1998/09/14 20:49:13 jcmurphy
# Initial revision
#
#
use ARS;
die "usage: DelUserFromGroup server username password group user1 [user2] ...\n" unless ($#ARGV >= 4);
example/Dump_Users_OO.pl view on Meta::CPAN
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");
example/GetFilter.pl view on Meta::CPAN
#
# Revision 1.1 1996/11/21 20:13:52 jcmurphy
# Initial revision
#
#
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 {
example/PrintQual.pl view on Meta::CPAN
# Revision 1.1 1997/02/20 19:33:02 jcmurphy
# Initial revision
#
#
#
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
example/Show_ALink.pl view on Meta::CPAN
#
# 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";
example/WhoUsesIt.pl view on Meta::CPAN
#
use ARS;
require 'getopts.pl'; # a standard perl module
$pname = $0;
$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";
example/WhoUsesIt.pl view on Meta::CPAN
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) {
example/WhoUsesIt.pl view on Meta::CPAN
# 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},";
}
}
example/WhoUsesIt.pl view on Meta::CPAN
# 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 {
example/ars_QualDecode.pl view on Meta::CPAN
# 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"))) {
print "ars_Decode_QualHash: ctrl is not an ARControlStructPtr\n";
return undef;
}
if(!(defined($s) && ($s ne ""))) {
print "ars_Decode_QualHash: schema is not a SCALAR\n";
return undef;
}
example/ars_QualDecode.pl view on Meta::CPAN
$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}
oper = $h->{oper}
right = $h->{right}
not = $h->{not}
rel_op = $h->{rel_op}\n\n" if $debug;
if($h->{oper} eq "and") {
print "handling AND\n" if $debug;
$e .= "(".ars_DQH($h->{left}, $fids)." AND ".ars_DQH($h->{right}, $fids).")";
}
elsif($h->{oper} eq "or") {
$e .= "(".ars_DQH($h->{left}, $fids)." OR ".ars_DQH($h->{right}, $fids).")";
}
elsif($h->{oper} eq "not") {
$e .= "( NOT (".ars_DQH($h->{not}, $fids).") )";
}
elsif($h->{oper} eq "rel_op") {
$e .= "(".ars_DQH($h->{rel_op}, $fids).")";
example/ars_QualDecode.pl view on Meta::CPAN
# my $f;
# print "keys:\n";
# foreach $f (keys %$h) {
# print "$f <".$h->{$f}.">\n";
# }
# print "\n";
# a field is referenced
if(defined($h->{fieldId})) {
print "\tfieldId: $h->{fieldId}\n" if $debug;
if($fids{$h->{fieldId}} ne "") {
$e = "'".$fids{$h->{fieldId}}."'";
} else {
$e = "'".$h->{fieldId}."'";
}
}
# a transaction field reference
elsif(defined($h->{TR_fieldId})) {
print "\tTR_fieldId: $h->{TR_fieldId}\n" if $debug;
$e = "'TR.".$fids{$h->{TR_fieldId}}."'";
}
# a database value field reference
elsif(defined($h->{DB_fieldId})) {
print "\tDB_fieldId: $h->{DB_fieldId}\n" if $debug;
$e = "'DB.".$fids{$h->{DB_fieldId}}."'";
}
# a value
elsif(exists($h->{value})) {
if(! defined($h->{value})) {
# this is a NULL
$e = NULL;
}
html/changes.html view on Meta::CPAN
BGCOLOR='black'>
<TR>
<TD width='100%'>
<TABLE CELLSPACING='0' CELLPADDING='3' WIDTH='100%' BORDER='0'
BGCOLOR='lightblue'>
<tr><td colspan='2'>
<table width='100%' border='0'><tr>
<td width='50%'>Released: <B>03/31/98</B></td>
<td width='50%'>Version: <B>1.56
</B></td>
</tr></table></td>
</tr><tr bgcolor='#eeeeee'><td width='10%'>(JCM)</td><td width='90%'><font color='black'>fixed a problem caused by some debugging code that
was left in 1.55 accidentally. </table></td></tr></table>
<P>
<TABLE CELLSPACING='0'
CELLPADDING='2'
WIDTH='100%'
BORDER='0'
BGCOLOR='black'>
html/changes.html view on Meta::CPAN
BGCOLOR='lightblue'>
<tr><td colspan='2'>
<table width='100%' border='0'><tr>
<td width='50%'>Released: <B>10/20/97</B></td>
<td width='50%'>Version: <B>1.5203
</B></td>
</tr></table></td>
</tr><tr bgcolor='#eeeeee'><td width='10%'>(JCM)</td><td width='90%'><font color='black'>beginnings of a WinNT port (not completed yet)
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(JCM)</td><td width='90%'><font color='black'>added "timestamp" to the return hash of GetEscalation()
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(JCM)</td><td width='90%'><font color='black'>added some extra malloc/free debugging stuff
</table></td></tr></table>
<P>
<TABLE CELLSPACING='0'
CELLPADDING='2'
WIDTH='100%'
BORDER='0'
BGCOLOR='black'>
<TR>
<TD width='100%'>
<TABLE CELLSPACING='0' CELLPADDING='3' WIDTH='100%' BORDER='0'
BGCOLOR='lightblue'>
<tr><td colspan='2'>
<table width='100%' border='0'><tr>
<td width='50%'>Released: <B>10/13/97</B></td>
<td width='50%'>Version: <B>1.5202
</B></td>
</tr></table></td>
</tr><tr bgcolor='#eeeeee'><td width='10%'>(JCM)</td><td width='90%'><font color='black'>removed a superfluous debugging statement
</table></td></tr></table>
<P>
<TABLE CELLSPACING='0'
CELLPADDING='2'
WIDTH='100%'
BORDER='0'
BGCOLOR='black'>
html/debug.html view on Meta::CPAN
<html>
<HEAD>
<TITLE>ARSperl: How to debug ARSperl</TITLE>
</HEAD>
<BODY BGCOLOR="#FFFFFF">
<H1> How to debug ARSperl </H1>
Because the ARS extension gets loaded into perl dynamically, there
are a few extra steps needed to debug it. You will need to build a separate
perl installation compiled with debugging turned on.
<H3> Steps </H3>
<OL>
<FONT SIZE="+1"> <LI> Configure perl </FONT> <P>
When perl's Configure script prompts you : <BR>
<I> What optimizer/debugger flag should be used? </I><BR>
you should specify -g instead of the default -O. <BR>
It is also usually a good idea to use perl's built in malloc.
The will prevent ARSperl from crashing due to malloc/free bugs. <P>
<FONT SIZE="+1"> <LI> Install perl/Install ARSperl </FONT> <P>
If you're perl install went correctly, ARSperl should automatically
get compiled with the -g switch.<P>
<FONT SIZE="+1"> <LI> Try it out <BR> </FONT> <P>
I use gdb (the gnu debugger) for debugging, but others (like dbx)
will probably work. Debugging ARS involves switching between
gdb and the perl debugger. When I'm in the perl debugger, I use
control-c to send a SIGINT and return to gdb. The function
names for ARSperl calls will be a little wierd. You can look in
ARS.c to see what they are. Make sure you keep ARS.c in
place so the debugger can find it! <P>
Here is an example debugging session:
<PRE>
152 cnu(11:13:13)~/ARSperl/ARSperl/example> gdb /usr/local/bin/perl
GDB is free software and you are welcome to distribute copies of it
under certain conditions; type "show copying" to see the conditions.
There is absolutely no warranty for GDB; type "show warranty" for details.
GDB 4.16 (sparc-sun-solaris2.3),
Copyright 1996 Free Software Foundation, Inc...
(gdb) set args -d GetField.pl remedyserver jmurphy mypass User 1
(gdb) run
Starting program: /usr/local/bin/perl -d GetField.pl remedyserver jmurphy mypass User 1
html/manual/OO/connection.html view on Meta::CPAN
<DL>
<DT><A NAME="new"><B>constructor</B></A> <DD>
<PRE>
$c = new ARS(-server => scalar,
-username => scalar,
-password => scalar,
-catch => hash reference,
-ctrl => control record reference,
-debug => true or false)
</PRE>
<DT><A NAME="DESTROY"><B>destructor</B></A><DD>
If the constructor called ars_Login() itself, then the destructor
will call ars_Logoff(). If, however, you are "sharing" a control
structer and called ars_Login() yourself (and then passed the
control structer into the ARS constructor via the
<code>-ctrl</code> parameter) then the destructor will not call
ars_Logoff(). Since you called ars_Login(), the OO layer assumes
you will see the slightly more helpful
[ some error condition ] at filename.ph line nnn
However, the B<.ph> files almost double in size when built using B<-h>.
=item -D
Include the code from the B<.h> file as a comment in the B<.ph> file.
This is primarily used for debugging I<h2ph>.
=item -Q
``Quiet'' mode; don't print out the names of the files being converted.
=back
=head1 ENVIRONMENT
No environment variables are used.
support-h.template view on Meta::CPAN
EXTERN unsigned int lookUpServerInfoTypeHint(unsigned int itn);
EXTERN unsigned int caseLookUpTypeNumber(TypeMapStruct *t, char *s);
/* typedef SV* (*ARS_fn)(void *); */
typedef void *(*ARS_fn)(ARControlStruct *ctrl, void *b);
EXTERN FILE* get_logging_file_ptr();
EXTERN void set_logging_file_ptr( FILE* );
EXTERN void *mallocnn(int s);
EXTERN void *debug_mallocnn(int s, char *file, char *func, int line);
EXTERN void debug_free(void *p, char *file, char *func, int line);
EXTERN unsigned int strsrch(register char *s, register char c);
EXTERN char *strappend(char *b, char *a);
EXTERN int ARError_reset();
EXTERN int ARError_add( int type, long num, char *text);
EXTERN int ARError( int returncode, ARStatusList status);
#if AR_EXPORT_VERSION < 6
EXTERN int NTError( int returncode, NTStatusList status);
#endif
support-h.template view on Meta::CPAN
#endif
int compmem(MEMCAST *m1, MEMCAST *m2, int size);
int copymem(MEMCAST *m1, MEMCAST *m2, int size);
void arsperl_FreeARTextString(char* buf);
#ifndef ARSPERL_MALLOCDEBUG
# define AMALLOCNN(DST,SIZE,TYPE) { DST = (TYPE *)mallocnn(SIZE * sizeof(TYPE)); }
# define MALLOCNN(X) mallocnn(X)
#else /* we want to debug memory allocations */
# define AMALLOCNN(DST,SIZE,TYPE) { DST = (TYPE *)debug_mallocnn(SIZE * sizeof(TYPE), __FILE__, __FUNCTION__, __LINE__); }
# define MALLOCNN(X) debug_mallocnn(X, __FILE__, __FUNCTION__, __LINE__)
#endif /* malloc debugging */
#ifndef ARSPERL_FREEDEBUG
// *** <JLS17_win32_free> ***
// I don't get why we need to use a different free-function on win32, but on the same time the MALLOCNN macro above is the same on all platforms?
// Normally I'd expect if we use a different free-function then we'll be using a different malloc-function as well, but that's not the case here!
// So I'm going to disable the following lines for now and stick to the normal free function until I understand the reason.
//# ifdef _WIN32
//# define AP_FREE(X) win32_free(X)
//# else
# define AP_FREE(X) free(X)
//# endif
// *** </JLS17_win32_free> ***
#else
# define AP_FREE(X) debug_free(X, __FILE__, __FUNCTION__, __LINE__)
#endif /* free debugging */
#define CPNULL (char *)NULL
/* some useful macros: CharVaLiD and IntVaLiD ..
* for checking validity of paramters
* VNAME() for all of those perl functions that want a string and
* it's length as the next parameter.
*/
#define CVLD(X) (X && *X)
if (!m)
croak("can't malloc");
memset(m, 0, s ? s : 1);
return m;
}
void *
debug_mallocnn(int s, char *file, char *func, int line)
{
printf("mallocnn(%d) called from %s::%s(), line %d\n", s,
file ? file : "UNKNOWN",
func ? func : "UNKNOWN",
line);
return mallocnn(s);
}
void
debug_free(void *p, char *file, char *func, int line)
{
printf("free(0x%X) called from %s::%s(), line %d\n", (unsigned long) p,
file ? file : "UNKNOWN",
func ? func : "UNKNOWN",
line);
free(p);
}
FILE *tmp__log_file_ptr = NULL;
SV **numItems, **messageType, **messageNum, **messageText;
AV *a;
SV *t2;
HV *err_hash = (HV *) NULL;
unsigned int ni, ret = 0;
#ifdef ARSPERL_DEBUG
printf("ARError_add(%d, %d, %s)\n", type, num, text ? text : "NULL");
#endif
/* this is used to insert 'traceback' (debugging) messages into the
* error hash. these can be filtered out by modifying the FETCH clause
* of the ARSERRSTR package in ARS.pm
*/
switch (type) {
case ARSPERL_TRACEBACK:
case AR_RETURN_OK:
case AR_RETURN_WARNING:
ret = 0;
break;
t/00connect.t view on Meta::CPAN
&CCACHE::USERNAME,
&CCACHE::PASSWORD, "", "", &CCACHE::TCPPORT);
if (!defined($c2)) {
print "not ok [2 $ars_errstr]\n";
} else {
print "ok [2]\n";
}
}
# if built with debugging, we should see $c2 be
# DESTROYed at this point
# make an OO connection. note that we disable exception
# catching so we can detect the errors manually.
# test 3 -> constructor
my $c = new ARS(-server => &CCACHE::SERVER,
-username => &CCACHE::USERNAME,
-password => &CCACHE::PASSWORD,
-tcpport => &CCACHE::TCPPORT,
-catch => { ARS::AR_RETURN_ERROR => undef,
ARS::AR_RETURN_WARNING => undef,
ARS::AR_RETURN_FATAL => undef
},
-debug => undef);
if($c->hasErrors() || $c->hasFatals() || $c->hasWarnings()) {
print "not ok [3 $ars_errstr]\n";
# print "messages: ", $c->messages(), "\n";
} else {
print "ok [3]\n";
}
# exitting will cause $c to destruct, calling ars_Logoff() in the
# process.
t/10entry.t view on Meta::CPAN
}
my $c = new ARS(-server => &CCACHE::SERVER,
-username => &CCACHE::USERNAME,
-password => &CCACHE::PASSWORD,
-tcpport => &CCACHE::TCPPORT,
-catch => { ARS::AR_RETURN_ERROR => "main::mycatch",
ARS::AR_RETURN_WARNING => "main::mycatch",
ARS::AR_RETURN_FATAL => "main::mycatch"
},
-debug => undef);
print "ok [1 cnx]\n";
my $s = $c->openForm(-form => "ARSperl Test");
print "ok [2 openform]\n";
# test 1: create an entry
my $id = $s->create("-values" => { 'Submitter' => &CCACHE::USERNAME,
'Status' => 'Assigned',
'Short Description' => 'A test submission',
t/11entry.t view on Meta::CPAN
}
my $c = new ARS(-server => &CCACHE::SERVER,
-username => &CCACHE::USERNAME,
-password => &CCACHE::PASSWORD,
-tcpport => &CCACHE::TCPPORT,
-catch => { ARS::AR_RETURN_ERROR => "main::mycatch",
ARS::AR_RETURN_WARNING => "main::mycatch",
ARS::AR_RETURN_FATAL => "main::mycatch"
},
-debug => undef);
print "ok [1]\n";
my $s = $c->openForm(-form => "ARSperl Test");
print "ok [2]\n";
# test 1: create many
my %eids;
for(my $loop = 0; $loop < 10000 ; $loop++) {
t/20merge.t view on Meta::CPAN
print "ok [4]\n";
# now do it again, but via the OO layer
my $ooc = new ARS(-ctrl => $c,
-catch => { ARS::AR_RETURN_ERROR => undef,
ARS::AR_RETURN_WARNING => undef,
ARS::AR_RETURN_FATAL => undef
},
-debug => undef
);
my $oof = $ooc->openForm(-form => 'ARSperl Test');
$eid2 = $oof->merge(-type => &ARS::AR_MERGE_ENTRY_DUP_MERGE,
-values => {
'Request ID' => $eid,
'Submitter' => 'xyz',
'Short Description' => 'oo-foobar',
( run in 1.837 second using v1.01-cache-2.11-cpan-49f99fa48dc )