ARSperl

 view release on metacpan or  search on metacpan

CHANGES  view on Meta::CPAN

 (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

MANIFEST  view on Meta::CPAN

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, "&gt;/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="&lt;--" 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";

t/13join.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++,"] 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.771 second using v1.01-cache-2.11-cpan-4d50c553e7e )