ARSperl
view release on metacpan or search on metacpan
(TS) added ars_BeginBulkEntryTransaction, ars_EndBulkEntryTransaction
(TS) added AR_FIELD_OFFSET handling in perl_ARFieldValueOrArithStruct (support.c)
(TS) added ars_SetSessionConfiguration
(TS) completed sv_to_ARCurrencyStruct (support.c)
(TS) ARS.pm: set $ARS::logging_file_ptr = 0 to avoid "uninitialized" warning
(TS) changed t/01import.t to import form "ARSperl Test3"
(TS) added ars_CreateContainer, ars_SetContainer
(TS) added ars_CreateFilter, ars_SetFilter, ars_CreateEscalation, ars_SetEscalation,
ars_SetActiveLink
(TS) added declaration of boolcpyHVal(...) to supportrev.h
(TS) added declaration of revTypeName(...) to supportrev.h
example/ars_GetListEntry.pl
example/getAttachment-OO.pl
example/00-ReadMe
example/ars_GetListContainer.pl
example/Show_ALink.pl
example/ars_GetListEntryWithMultiSchemaFields.pl
example/GetFilter.pl
example/Show_Menu.pl
example/Dump_Setup.pl
example/ars_GetListGroup.pl
example/attachTest.pl
example/ars_GetControlStructFields.pl
example/ars_decodeStatusHistory.pl
example/ars_GetListSQL.pl
example/ars_DateToJulianDate.pl
example/ars_SetServerInfo.pl
example/AddUsersToGroup.pl
example/WhoUsesIt.pl
example/List_Entries.pl
example/GetField.pl
example/del_all.pl
Makefile.PL view on Meta::CPAN
#
# 'LD' => "/usr/ccs/bin/ld",
# don't fiddle with this
'realclean' => {
'FILES' => 'support.h ARS/ar-h.pm ARS/arerrno-h.pm ARS/_h2ph_pre.ph t/config.cache serverTypeInfoHints.h *~ .purify '
}
);
makeTestConfig();
print "
Type 'make' (windows: 'nmake') to build ARSperl.
Type 'make test' to test ARSperl before installing.
Type 'make install' to install ARSperl.
";
exit 0;
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;
}
changes.dat view on Meta::CPAN
TS bugfix in ars_GetCharMenu (incorrect array length for "labelFields", "labelIndex")
TS added ars_SetImpersonatedUser
TS bugfix in ARError (support.c, memory violation if appendedText == NULL)
TS ars_SetLogging: changed declaration "int len" to "STRLEN len" because of
compilation problems on Solaris
TS added ars_BeginBulkEntryTransaction, ars_EndBulkEntryTransaction
TS added AR_FIELD_OFFSET handling in perl_ARFieldValueOrArithStruct (support.c)
TS added ars_SetSessionConfiguration
TS completed sv_to_ARCurrencyStruct (support.c)
TS ARS.pm: set $ARS::logging_file_ptr = 0 to avoid "uninitialized" warning
TS changed t/01import.t to import form "ARSperl Test3"
TS added ars_CreateContainer, ars_SetContainer
TS added ars_CreateFilter, ars_SetFilter, ars_CreateEscalation, ars_SetEscalation,
ars_SetActiveLink
TS added declaration of boolcpyHVal(...) to supportrev.h
TS added declaration of revTypeName(...) to supportrev.h
TS added "rev_ARReferenceStruct" to supportrev.c
TS changed perl_ARReferenceStruct (added "value_dataType" key, necessary for
ars_CreateContainer)
TS changed ars_CreateActiveLink to read "schemaList" from alDef struct
TS bugfix in rev_ARMessageStruct
example/ars_GetListEntry.pl view on Meta::CPAN
( my %fids = ars_GetFieldTable( $ctrl, $schema ) )
|| die "ars_GetFieldTable: $ars_errstr";
( my $qual = ars_LoadQualifier( $ctrl, $schema, "(1 = 1)" ) )
|| die "ars_LoadQualifier: $ars_errstr";
# basic format: allow the server to provide sorting order
# and query list fields.
print "Testing: basic format.\n";
( my @entries = ars_GetListEntry( $ctrl, $schema, $qual, 0, 0 ) )
|| die "ars_GetListEntry: $ars_errstr";
for ( my $i = 0 ; $i < $#entries ; $i += 2 ) {
printf( "%s %s\n", $entries[$i], $entries[ $i + 1 ] );
}
# another format: specify a sorting order.
# sort by license type, ascending.
print "Testing: basic + sorting format.\n";
( my @sorted_entries =
ars_GetListEntry( $ctrl, $schema, $qual, 0, 0, $fids{$login_name}, 1 ) )
|| # sort on Login Name, ascending
die "ars_GetListEntry: $ars_errstr";
for ( my $i = 0 ; $i < $#sorted_entries ; $i += 2 ) {
printf( "%s %s\n", $sorted_entries[$i], $sorted_entries[ $i + 1 ] );
}
# another format: specify a custom query list field-list.
print "Testing: basic + sorting + custom field-list format.\n";
if ( !defined( $fids{$login_name} ) || !defined( $fids{$full_name} ) ) {
print
"Sorry. Either i can't find the field-id for \"$login_name\" or \"$full_name\"\n on your \"$schema\" form. I'm skipping this test.\n";
}
else {
(
my @basic_sorted_entries = ars_GetListEntry(
$ctrl, $schema, $qual, 0, 0,
[
example/attachTest.pl view on Meta::CPAN
#!/oratest/perl/bin/perl
use ARS;
$c = ars_Login(shift, shift, shift);
%f = ars_GetFieldTable($c, "ARSperl Test");
foreach (keys %f) {
$r{$f{$_}} = $_;
}
print "Creating new entry with an attachment..\n";
($id = ars_CreateEntry($c, "ARSperl Test",
$f{'Attachment Field'}, { file => "/tmp/test", size => 0 },
#$f{'Attachment Field'}, { buffer => "/tmp/test", size => 9 },
$f{'Submitter'}, "jeff",
$f{'Status'}, 1,
$f{'Short Description'}, "none")) ||
die "CreateEntry: $ars_errstr";
print "Created entry $id\n";
print "Fetching the entry we just made..\n";
%v = ars_GetEntry($c, "ARSperl Test", $id);
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;
example/attachTest.pl view on Meta::CPAN
sub ra {
my $fid = shift;
print "\t[Retrieving attachment.]\n";
# file: $a = 0 || 1
# buff: $a = undef || attachment
ars_GetEntryBLOB($c, "ARSperl Test", $id,
$fid,
ARS::AR_LOC_FILENAME,
"/tmp/attachtest") ||
die ("GetEntryBLOB: $ars_errstr");
my $a = ars_GetEntryBLOB($c, "ARSperl Test", $id,,
$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);
}
example/getAttachment-OO.pl view on Meta::CPAN
#!/oratest/perl/bin/perl
use ARS;
$c = new ARS(shift, shift, shift);
$s = $c->openForm("ARSperl Test");
%v = $s->getAsHash(-entry => "000000000000002");
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";
}
html/changes.html view on Meta::CPAN
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added ars_BeginBulkEntryTransaction, ars_EndBulkEntryTransaction
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added AR_FIELD_OFFSET handling in perl_ARFieldValueOrArithStruct (support.c)
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added ars_SetSessionConfiguration
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>completed sv_to_ARCurrencyStruct (support.c)
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>ARS.pm: set $ARS::logging_file_ptr = 0 to avoid "uninitialized" warning
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>changed t/01import.t to import form "ARSperl Test3"
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added ars_CreateContainer, ars_SetContainer
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added ars_CreateFilter, ars_SetFilter, ars_CreateEscalation, ars_SetEscalation,
ars_SetActiveLink </font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added declaration of boolcpyHVal(...) to supportrev.h
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added declaration of revTypeName(...) to supportrev.h
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>added "rev_ARReferenceStruct" to supportrev.c
html/manual/ars_GetEntryBLOB.html view on Meta::CPAN
<DT><B>On success</B><DD>
returns 1 if locType == AR_LOC_FILENAME <BR>
returns a scalar buffer if locType == AR_LOC_BUFFER <BR>
<DT><B>On failure</B><DD>
Returns <CODE>undef</CODE>.
</DL>
<P>Example:
<PRE>
ars_GetEntryBLOB($c, "00-Test", "000000000000001",
$fid,
ARS::AR_LOC_FILENAME,
"/tmp/attachtest") ||
die ("GetEntryBLOB: $ars_errstr");
my $a = ars_GetEntryBLOB($c, "00-Test", "000000000000001",
$fid,
ARS::AR_LOC_BUFFER);
die "GetEntryBLOB: $ars_errstr" if(!defined($a));
print "blob size = ".length($a)."\n";
open(FD, ">/tmp/attachtest2") || die "open: $!";
print FD $a;
close(FD);
</PRE>
html/manual/ars_SetImpersonatedUser.html view on Meta::CPAN
<DL>
<DT><B>On success</B><DD>
Returns 1
<DT><B>On failure</B><DD>
Returns 0
</DL>
<P>Example:
<PRE>
ars_SetImpersonatedUser($ctrl,"TestUser") || die "$ars_errstr";
</PRE>
<P>
<I>ars_SetImpersonatedUser was introduced in version 1.90 of ARSperl</I>
<P>
<HR WIDTH="30%">
<P>
<A HREF="toc.html"><IMG ALT="<--" SRC="arrow.gif" ALIGN=CENTER> Table of Contents </A>
<p>
html/manual/ars_SetLogging.html view on Meta::CPAN
<P>Example:
<PRE>
# start filter and sql logging
# (the logfile gets opened for appending)
ars_SetLogging( $c, ARS::AR_DEBUG_SERVER_FILTER | ARS::AR_DEBUG_SERVER_SQL,
"/var/log/filter_sql.log" ) ||
die ("SetLogging (start): $ars_errstr");
# call any ARS API function
my $id = ars_CreateEntry( $c, "User", 101 => "TestUser", 109 => 1 );
# stop logging (specify logTypeMask = 0 and no file)
# (the logfile gets closed)
ars_SetLogging( $c, 0 ) ||
die ("SetLogging (end): $ars_errstr");
</PRE>
<P>If SQL and Filter logging do appear as not working, it may be because the
the user is not a member of the "client-side logging group."
t/01import.t view on Meta::CPAN
if(ars_APIVersion() >= 6) {
$d = "aptest51.def";
}elsif(ars_APIVersion() >= 4) {
$d = "aptest50.def";
}
# delete the schema (assuming it already exists). if it doesnt,
# we ignore the error.
ars_DeleteSchema($ctrl, "ARSperl Test", ARS::AR_SCHEMA_FORCE_DELETE);
ars_DeleteSchema($ctrl, "ARSperl Test2", ARS::AR_SCHEMA_FORCE_DELETE);
ars_DeleteSchema($ctrl, "ARSperl Test-join", ARS::AR_SCHEMA_FORCE_DELETE);
ars_DeleteSchema($ctrl, "ARSperl Test3", ARS::AR_SCHEMA_FORCE_DELETE);
ars_DeleteFilter($ctrl, "ARSperl Test-Filter1");
ars_DeleteActiveLink($ctrl, "ARSperl Test-alink1");
ars_DeleteEscalation($ctrl, "ARSperl Test-escalation1");
ars_DeleteCharMenu($ctrl, "ARSperl Test-menu-search1");
ars_DeleteContainer($ctrl,"ARSperl Test-FilterGuide1");
# read in the schema definition
my $buf = "";
open(FD, "./t/".$d) || die "not ok (open $!)\n";
while(<FD>) {
$buf .= $_;
}
close(FD);
# import it
my $rv = ars_Import($ctrl,
&ARS::AR_IMPORT_OPT_CREATE,
$buf,
"Schema", "ARSperl Test",
"Schema", "ARSperl Test2",
"Schema", "ARSperl Test-join",
"Schema", "ARSperl Test3",
"Filter", "ARSperl Test-Filter1",
"Active_Link", "ARSperl Test-alink1",
"Escalation", "ARSperl Test-escalation1",
"Char_Menu", "ARSperl Test-menu-search1",
"Container", "ARSperl Test-FilterGuide1",
);
if(defined($rv) && ($rv == 1)) {
print "ok\n";
} else {
print "not ok [$ars_errstr]\n";
}
ars_Logoff($ctrl);
t/02export.t view on Meta::CPAN
my $d = "aptest.def";
if(ars_APIVersion() >= 4) {
$d = "aptest50.def";
}
my $def = "";
my $c = 1;
my @objects = (
"schema", "ARSperl Test",
"schema", "ARSperl Test2",
"schema", "ARSperl Test-join",
"filter", "ARSperl Test-Filter1",
"active_link", "ARSperl Test-alink1",
"escalation", "ARSperl Test-escalation1",
"char_menu", "ARSperl Test-menu-search1",
"container", "ARSperl Test-FilterGuide1",
);
my $junk = ars_Export($ctrl, "", 0, "schema", "blarg292394");
if (defined($junk)) {
print "not ok [$c]\n";
} else {
print "ok [$c]\n";
}
$c++;
t/09qualifier.t view on Meta::CPAN
my($ctrl) = ars_Login(&CCACHE::SERVER,
&CCACHE::USERNAME,
&CCACHE::PASSWORD, "","", &CCACHE::TCPPORT);
if(!defined($ctrl)) {
print "not ok [1]\n";
} else {
print "ok [1]\n";
}
my $q1 = ars_LoadQualifier($ctrl, "ARSperl Test",
qq{'Status' = "New"}
);
if (defined($q1)) {
print "ok [2]\n";
} else {
print "not ok [2] ($ars_errstr)\n";
}
print "expect DESTROY..\n";
undef $q1; # should result in a call to DESTROY
print "did you get it? (ARSPDEBUG must be defined)\n";
{
my $q2 = ars_LoadQualifier($ctrl, "ARSperl Test", "'Submitter' = \"jcmurphy\"");
if (defined($q2)) {
print "ok [3]\n";
} else {
print "not ok [3] ($ars_errstr)\n";
}
}
# implicit call to DESTROY for q2
my $q3 = ars_LoadQualifier($ctrl, "ARSperl Test", "'Create Date' > \"1/1/2000 01:02:03\"");
if (defined($q3)) {
print "ok [4]\n";
} else {
print "not ok [4] ($ars_errstr)\n";
}
exit 0; #implicit call to DESTROY for q3
t/10alink.t view on Meta::CPAN
&CCACHE::USERNAME,
&CCACHE::PASSWORD, "","", &CCACHE::TCPPORT);
if (defined($c)) {
print "ok [1] (login)\n";
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
my $a = ars_GetActiveLink($c, "ARSperl Test-alink1");
if (defined($a)) {
print "ok [2] (GAL) \n";
} else {
print "not ok [2] (GAL $ars_errstr)\n";
exit(0);
}
# the active link should have a schemaList key
t/10entry.t view on Meta::CPAN
-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',
'Diary Field' => 'A diary entry'
}
);
t/10getescalation.t view on Meta::CPAN
&CCACHE::USERNAME,
&CCACHE::PASSWORD, "","", &CCACHE::TCPPORT);
if (defined($c)) {
print "ok [1] (login)\n";
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
my $a = ars_GetEscalation($c, "ARSperl Test-escalation1");
if (defined($a)) {
print "ok [2] (GESC) \n";
} else {
print "not ok [2] (GESC $ars_errstr)\n";
exit(0);
}
# the escalation should have a schemaList key
t/10getlist.t view on Meta::CPAN
#!perl
use ARS;
use strict;
require './t/config.cache';
use Test::More tests => 9;
my $c = ars_Login(&CCACHE::SERVER,
&CCACHE::USERNAME,
&CCACHE::PASSWORD, "","", &CCACHE::TCPPORT);
ok(defined($c), "login") || diag "login: $ars_errstr";
SKIP: {
skip 8, "login failed" unless defined($c);
my @a = ars_GetListEscalation($c, "ARSperl Test");
ok($#a == 0, "GetListEscalation") ||
diag "GetListEscalation ($#a) $ars_errstr";
@a = ars_GetListField($c, "ARSperl Test", 0, 1);
ok($#a == 110, "GetListField") ||
diag "GetListField ($#a) $ars_errstr";
@a = ars_GetListFilter($c, "ARSperl Test");
ok($#a == 0, "GetListFilter") ||
diag "GetListFilter ($#a) $ars_errstr";
@a = ars_GetListGroup($c);
ok(@a, "GetListGroup") ||
diag "GetListGroup $ars_errstr";
@a = ars_GetListSchema($c, 0, 0 + 1024);
ok(@a, "GetListSchema") ||
diag "GetListSchema $ars_errstr";
t/10getlist.t view on Meta::CPAN
# this test might fail if the sql is bad or this
# isnt an admin account we are running with
@a = ars_GetListSQL($c, "select name, schemaid, nextid from arschema");
ok(@a, "GetListSQL") ||
diag("GetListSQL ($ars_errstr) - it's OK if this fails");
@a = ars_GetListUser($c);
ok (@a, "GetListUser") ||
diag("GetListUser ($ars_errstr)");
@a = ars_GetListVUI($c, "ARSperl Test");
ok (@a, "GetListVUI") ||
diag("GetListVUI ($ars_errstr)");
}
ars_Logoff($c);
exit(0);
t/11entry.t view on Meta::CPAN
-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++) {
my $id = $s->create("-values" => { 'Submitter' => &CCACHE::USERNAME,
'Status' => 'Assigned',
'Short Description' => $loop
t/12lotsoffields.t view on Meta::CPAN
if(!defined($ctrl)) {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "]\n";
}
exit(0);
} else {
print "ok [", $TN++,"]\n";
}
my %ft = ars_GetFieldTable($ctrl, "ARSperl Test");
if (%ft) {
print "ok [", $TN++, "]\n";
} else {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "]\n";
}
exit(0);
}
t/12lotsoffields.t view on Meta::CPAN
my @vals;
my @intFids;
foreach my $fn (keys %ft) {
next if $fn !~ /^Integer/;
push @vals, $ft{$fn};
push @vals, $ft{$fn};
push @intFids, $ft{$fn};
}
my $rv = ars_CreateEntry($ctrl, "ARSperl Test",
$ft{'Submitter'}, 'jcmurphy',
$ft{'Status'}, 1,
$ft{'Short Description'}, 'short desc',
@vals);
if (!defined($rv)) {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "]\n";
}
exit(0);
}
print "ok [", $TN++, "]\n";
# retrieve the record (all values)
my %recvals = ars_GetEntry($ctrl, "ARSperl Test",
$rv);
if (! %recvals) {
print "not ok [", $TN++, "] ($ars_errstr)\n";
} else {
my @foo = keys %recvals;
print "ok [", $TN++, "] (got ", $#foo, " values)\n";
}
# retrieve the record (only the integer fields)
for (my $loop = 0 ; $loop < $GETLOOPS ; $loop++) {
my %intvals = ars_GetEntry($ctrl, "ARSperl Test",
$rv, @intFids);
if (!%recvals) {
print "not ok [", $TN++, "] ($ars_errstr)\n";
} else {
my @foo = keys %intvals;
if($#foo == $#intFids) {
print "ok [", $TN++, "] (got $#foo values)\n";
} else {
print "not ok [", $TN++, "] (got $#foo values, expected $#intFids)\n";
if(!defined($ctrl)) {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "]\n";
}
exit(0);
} else {
print "ok [", $TN++,"] login\n";
}
# submit some records into "ARSperl Test2"
my %ft = ars_GetFieldTable($ctrl, "ARSperl Test2");
if (%ft) {
print "ok [", $TN++, "] GFT\n";
} else {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "]\n";
}
exit(0);
}
#print join("\n", keys %ft), "\n";
# add a record
my $ok = 0;
for (my $loop = 0 ; $loop < 5 ; $loop++) {
my $rv = ars_CreateEntry($ctrl, "ARSperl Test2",
$ft{'Submitter-AT2'}, 'jcmurphy',
$ft{'Status-AT2'}, 1,
$ft{'SD-AT2'}, 'short desc'
);
$ok++ if defined $rv;
}
if ($ok != 5) {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "] ($ars_errstr)\n";
}
exit(0);
}
print "ok [", $TN++, "] CE\n";
# get the fields from the join form
my %jft = ars_GetFieldTable($ctrl, "ARSperl Test-join");
if( %jft ) {
print "ok [", $TN++, "] GFT\n";
} else {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "] ($ars_errstr)\n";
}
exit(0);
}
# fetch a list of records
my $q = ars_LoadQualifier($ctrl, "ARSperl Test-join", "(1 = 1)");
if(defined($q)) {
print "ok [", $TN++, "] LQ\n";
} else {
print "not ok [", $TN++, "]\n";
while($TN <= $NT) {
print "not ok [", $TN++, "] ($ars_errstr)\n";
}
exit(0);
}
my @matches = ars_GetListEntry($ctrl, "ARSperl Test-join", $q, 0, 0);
if ($#matches != -1) {
print "ok [", $TN++, "] GLE (got $#matches matches)\n";
} else {
print "not ok [", $TN++, "] ($ars_errstr)\n";
while($TN <= $NT) {
print "not ok [", $TN++, "]\n";
}
exit(0);
}
print join("\n", @matches), "\n";
# do alot of GetFields on the Join
$ok = 1;
foreach my $fn (keys %jft) {
my $fh1 = ars_GetField($ctrl, "ARSperl Test-join", $jft{$fn});
$ok = 0 if (!defined($fh1));
}
if($ok) {
print "ok [", $TN++, "] GF\n";
} else {
print "not ok [", $TN++, "] GF\n";
}
exit 0;
t/20merge.t view on Meta::CPAN
if(!defined($c)) {
for(my $i = 1 ; $i <= $maxtest ; $i++) {
print "not ok [$i] [ctrl]\n";
}
exit 0;
} else {
print "ok [1]\n";
}
my %fids = ars_GetFieldTable($c, "ARSperl Test");
if(!(%fids)) {
for(my $i = 2 ; $i <= $maxtest ; $i++) {
print "not ok [$i] [gft]\n";
}
exit 0;
} else {
print "ok [2]\n";
}
t/20merge.t view on Meta::CPAN
# 1. A non-null value returned means that a new entry was created.
# 2. A null value returned, plus $ars_errstr empty, means that an existing
# entry was replaced.
# 3. A null value returned, plus $ars_errstr non-empty, means there was some
# error.
# merge in a new entry. we should get an entry-id back
my $eid = ars_MergeEntry($c, "ARSperl Test", 2,
$fids{'Submitter'}, 'jcmurphy',
$fids{'Short Description'}, 'foobar',
$fids{'Status'}, 0);
if(!defined($eid)) {
print "not ok [3] [$ars_errstr]\n";
} else {
print "ok [3]\n";
}
# replace the entry with something new. we should get the
# same entry-id back
my $eid2 = ars_MergeEntry($c, "ARSperl Test",
&ARS::AR_MERGE_ENTRY_DUP_MERGE,
1, $eid,
$fids{'Submitter'}, 'jcm',
$fids{'Short Description'}, 'foobar2',
$fids{'Status'}, 1);
if(!defined($eid2)) {
print "not ok [4] ndef eid [$ars_errstr]\n";
}
elsif($eid2 eq "") {
t/20merge.t view on Meta::CPAN
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',
'Status' => 'Rejected'
}
);
t/20merge.t view on Meta::CPAN
} else {
# if $eid2 is "", then the op failed completely
# if $eid2 ne $eid, then the op succeeded, but
# created a new entry - which shouldnt happen
# since we specified DUP_MERGE _unless_ you
# forgot to specify an entry-id in your values
# hash
print "not ok [5] (eid2=$eid2 ; eid=$eid ; err=$ars_errstr)\n";
}
ars_DeleteEntry($c, "ARSperl Test", $eid);
ars_Logoff($c);
exit 0;
t/21setlogging.t view on Meta::CPAN
my $ret = ars_SetLogging( $ctrl,
&ARS::AR_DEBUG_SERVER_SQL | &ARS::AR_DEBUG_SERVER_FILTER | &ARS::AR_DEBUG_SERVER_API );
if( ! $ret ) {
print "not ok [$c] [$ars_errstr]\n";
} else {
print "ok [$c]\n";
}
++$c;
ars_CreateEntry( $ctrl, 'ARSperl Test', 2 => 'Demo', 7 => 1, 8 => 'ShortDescription' );
if( $ars_errstr =~ /<API >.*<FLTR>.*<SQL >/s ){
print "ok [$c]\n";
} else {
print "not ok [$c]\n";
}
++$c;
$ret = ars_SetLogging( $ctrl, 0 );
t/21setlogging.t view on Meta::CPAN
&ARS::AR_DEBUG_SERVER_SQL | &ARS::AR_DEBUG_SERVER_FILTER | &ARS::AR_DEBUG_SERVER_API,
$logfile );
if( ! $ret ) {
print "not ok [$c] [$ars_errstr]\n";
} else {
print "ok [$c]\n";
}
++$c;
ars_CreateEntry( $ctrl, 'ARSperl Test', 2 => 'Demo', 7 => 1, 8 => 'ShortDescription' );
my $fc;
{
local $/ = undef;
open(FD, $logfile) || die "not ok [$c open]\n";
binmode FD;
$fc = <FD>;
close(FD);
}
if( $fc =~ /<API >.*<FLTR>.*<SQL >/s ){
print "ok [$c]\n";
t/31createschema.t view on Meta::CPAN
# 'User',
# 'Alert Events',
# 'Application Pending',
# 'Application Statistics',
# 'Application Statistics Configuration',
# 'AR System Administrator Preference',
#);
#my @forms = sort {lc($a) cmp lc($b)} grep {$_ ge "BPM:MA:"} grep {/^BPM:/} ars_GetListSchema( $ctrl, 0, 1024 ); # all
#my @forms = sort {lc($a) cmp lc($b)} grep {/^BPM:/} ars_GetListSchema( $ctrl, 0, 1024 ); # all
#die "ars_GetListSchema( ALL ): $ars_errstr\n" if $ars_errstr;
#my @forms = ( 'ARSperl Test', 'ARSperl Test2', 'ARSperl Test-join', 'ARSperl Test3' );
my @forms = ( 'ARSperl Test3' );
$| = 1;
foreach my $form ( @forms ){
next if $form =~ / \((copy|renamed)\)$/;
my $formNew = "$form (copy)";
ars_DeleteSchema( $ctrl, $formNew, 1 );
copyForm( $ctrl, $form, $formNew );
t/32createcontainer.t view on Meta::CPAN
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
#my @containers = sort {lc($a) cmp lc($b)} map {$_->{containerName}} ars_GetListContainer( $ctrl, 0, &ARS::AR_HIDDEN_INCREMENT, &ARS::ARCON_ALL );
#die "ars_GetListContainer( ALL ): $ars_errstr\n" if $ars_errstr;
#my @containers = sort {lc($a) cmp lc($b)} map {$_->{containerName}} grep {$_->{containerType} =~ /guide/} ars_GetListContainer( $ctrl, 0, &ARS::AR_HIDDEN_INCREMENT, &ARS::ARCON_ALL );
#die "ars_GetListContainer( ALL ): $ars_errstr\n" if $ars_errstr;
my @containers = ( 'ARSperl Test-FilterGuide1' );
$| = 1;
foreach my $ctnr ( @containers ){
next if $ctnr =~ / \((copy|renamed)\)$/;
my $ctnrNew = "$ctnr (copy)";
ars_DeleteContainer( $ctrl, $ctnrNew );
copyContainer( $ctrl, $ctnr, $ctnrNew );
t/33setcontainer.t view on Meta::CPAN
if (defined($ctrl)) {
print "ok [1] (login)\n";
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
#my @objects = sort {lc($a) cmp lc($b)} grep {/\(copy\)/} map {$_->{containerName}} grep {$_->{containerType} =~ /guide/} ars_GetListContainer( $ctrl, 0, &ARS::AR_HIDDEN_INCREMENT, &ARS::ARCON_ALL );
#die "ars_GetListContainer( ALL ): $ars_errstr\n" if $ars_errstr;
my @objects = ( 'ARSperl Test-FilterGuide1 (copy)' );
$| = 1;
foreach my $obj ( @objects ){
next if $obj !~ / \(copy\)$/;
my $objNew = $obj;
$objNew =~ s/ \(copy\)$/ (renamed)/;
ars_DeleteContainer( $ctrl, $objNew );
t/33setcontainer.t view on Meta::CPAN
push @refList, makeRef(
dataType => 1,
type => 32774,
label => '-------------',
);
if( $ctnrObj->{type} eq 'guide' ){
push @refList, makeRef(
dataType => 0,
type => 5,
name => 'ARSperl Test-alink1',
);
}elsif( $ctnrObj->{type} eq 'filter_guide' ){
push @refList, makeRef(
dataType => 0,
type => 3,
name => 'ARSperl Test-Filter1',
);
}
push @refList, makeRef(
dataType => 1,
type => 32774,
label => '==== END ====',
);
my $ret = 1;
t/34createactlink.t view on Meta::CPAN
if (defined($ctrl)) {
print "ok [1] (login)\n";
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
#my @objects = sort {lc($a) cmp lc($b)} ars_GetListActiveLink( $ctrl );
#die "ars_GetListActiveLink( ALL ): $ars_errstr\n" if $ars_errstr;
my @objects = ( 'ARSperl Test-alink1' );
$| = 1;
foreach my $obj ( @objects ){
next if $obj =~ / \((copy|renamed)\)$/;
my $objNew = "$obj (copy)";
ars_DeleteActiveLink( $ctrl, $objNew );
copyObject( $ctrl, $obj, $objNew );
t/35setactlink.t view on Meta::CPAN
if (defined($ctrl)) {
print "ok [1] (login)\n";
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
#my @objects = sort {lc($a) cmp lc($b)} grep {/\(copy\)/} ars_GetListActiveLink( $ctrl );
#die "ars_GetListActiveLink( ALL ): $ars_errstr\n" if $ars_errstr;
my @objects = ( 'ARSperl Test-alink1 (copy)' );
$| = 1;
foreach my $obj ( @objects ){
next if $obj !~ / \(copy\)$/;
my $objNew = $obj;
$objNew =~ s/ \(copy\)$/ (renamed)/;
ars_DeleteActiveLink( $ctrl, $objNew );
t/36createfilter.t view on Meta::CPAN
if (defined($ctrl)) {
print "ok [1] (login)\n";
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
#my @objects = sort {lc($a) cmp lc($b)} ars_GetListFilter( $ctrl );
#die "ars_GetListFilter( ALL ): $ars_errstr\n" if $ars_errstr;
my @objects = ( 'ARSperl Test-Filter1' );
$| = 1;
foreach my $obj ( @objects ){
next if $obj =~ / \((copy|renamed)\)$/;
my $objNew = "$obj (copy)";
ars_DeleteFilter( $ctrl, $objNew );
copyObject( $ctrl, $obj, $objNew );
t/37setfilter.t view on Meta::CPAN
if (defined($ctrl)) {
print "ok [1] (login)\n";
} else {
print "not ok [1] (login $ars_errstr)\n";
exit(0);
}
#my @objects = sort {lc($a) cmp lc($b)} grep {/\(copy\)/} ars_GetListFilter( $ctrl );
#die "ars_GetListFilter( ALL ): $ars_errstr\n" if $ars_errstr;
my @objects = ( 'ARSperl Test-Filter1 (copy)' );
$| = 1;
foreach my $obj ( @objects ){
next if $obj !~ / \(copy\)$/;
my $objNew = $obj;
$objNew =~ s/ \(copy\)$/ (renamed)/;
ars_DeleteFilter( $ctrl, $objNew );
( run in 0.509 second using v1.01-cache-2.11-cpan-4d50c553e7e )