Thread: [Arsperl-devel] ARSperl/t 31createschema.t, NONE, 1.1 32createcontainer.t, NONE, 1.1 33setcontainer

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/arsperl/ARSperl/t
In directory sc8-pr-cvs11.sourceforge.net:/tmp/cvs-serv14198/t

Modified Files:
	01import.t 02export.t 
Added Files:
	31createschema.t 32createcontainer.t 33setcontainer.t 
	34createactlink.t 35setactlink.t 36createfilter.t 
	37setfilter.t 38createescalation.t 39setescalation.t 
	aptest51.def 
Log Message:
arsystem 7.0 port, new ars_Create/Set functions

--- NEW FILE: aptest51.def ---
#
#  File exported Tue Apr  1 15:27:05 2003
#
begin schema
   name           : ARSperl Test
   core-version   : 2
   upgrade-version: 0
   num-fields     : 112
   timestamp      : 1049205535
   owner          : jcmurphy
   last-changed   : jcmurphy
   default-vui    : Default Administrator View
   num-vuis       : 1
   export-version : 6
   schema-type    : 1
   next-field-id  : 536870915
vui  {
   id             : 536870912
   name           : Default Administrator View
[...5628 lines suppressed...]
   object         : ARSperl Test-Filter1
}
reference {
   type           : 32774
   datatype       : 1
   label          : LABEL 1
   value          : 0\
}
reference {
   type           : 3
   datatype       : 0
   object         : ARSperl Test-Filter1
}
reference {
   type           : 32774
   datatype       : 1
   label          : LABEL 2
   value          : 0\
}
end

--- NEW FILE: 37setfilter.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/37setfilter.t 

use strict;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
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 ){
	modifyObject( $ctrl, $obj );
}


sub modifyObject {
	my( $ctrl, $obj ) = @_;
	print '-' x 60, "\n";
#	print "GET FILTER $obj\n";
	my $wfObj = ars_GetFilter( $ctrl, $obj );
	die "ars_GetFilter( $obj ): $ars_errstr\n" if $ars_errstr;

	my( $name, $newName );
	$newName = $name = $wfObj->{name};
	$newName .= '_TEST';


	my $ret = 1;
	print "SET FILTER $name\n";
	$ret = ars_SetFilter( $ctrl, $wfObj->{name}, {name => $newName, enable => 0, order => 327} );
	die "ars_SetFilter( $name ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 2, 'set filter' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}

sub makeRef {
	my( %args ) = @_;
	$args{label} = ''       if !exists $args{label};
	$args{description} = '' if !exists $args{description};
	if( $args{dataType} == 1 ){
		$args{permittedGroups} = [] if !exists $args{permittedGroups};
		$args{value}          = undef  if !exists $args{value};
		$args{value_dataType} = 'null' if !exists $args{value_dataType};
	}
	return \%args;	
}


#ars_Logoff($ctrl);
exit(0);


--- NEW FILE: 38createescalation.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/38createescalation.t 

use strict;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
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_GetListEscalation( $ctrl );
#die "ars_GetListEscalation( ALL ): $ars_errstr\n" if $ars_errstr;
#my @objects = ( 'ARSperl Test-escalation1', 'MSR:SRJ:Zuweisung_Wartend' );
#my @objects = ( 'zTEST:TimeInterval', 'zTEST:TimeDate' );
my @objects = ( 'ARSperl Test-escalation1' );


$| = 1;


foreach my $obj ( @objects ){
	my $objNew = "$obj (copy)";
	ars_DeleteEscalation( $ctrl, $objNew );
	copyObject( $ctrl, $obj, $objNew );
}


sub copyObject {
	my( $ctrl, $obj, $objNew ) = @_;
	print '-' x 60, "\n";
#	print "GET ESCALATION $ctnr\n";
	my $wfObj = ars_GetEscalation( $ctrl, $obj );
	die "ars_GetEscalation( $obj ): $ars_errstr\n" if $ars_errstr;

#use Data::Dumper;
#$Data::Dumper::Sortkeys = 1;
#my $data = $ctnrObj;
#my $file = '-';
#local *FILE;
#open( FILE, "> $file" ) or die qq{Cannot open \"$file\" for writing: $!\n};
#print FILE Data::Dumper->Dump( [$data], ['ctnrObj'] );
#close FILE;

	$wfObj->{name} = $objNew;

	@{$wfObj->{objPropList}} = grep {$_->{prop} < 90000} @{$wfObj->{objPropList}};
#	foreach my $prop ( @{$ctnrObj->{objPropList}} ){
#		$prop->{value} .= 'xCopy' if $prop->{prop} == 60020 && $prop->{value} ne '';
#	}
	$wfObj->{changeDiary} = "Init";

	my $ret = 1;
	print "CREATE ESCALATION $objNew\n";
	$ret = ars_CreateEscalation( $ctrl, $wfObj );
	if( $ars_errstr ){
		if( $ars_errstr =~ /\[ERROR\]/ ){
			die "ars_CreateEscalation( $objNew ): $ars_errstr\n";
		}else{
			warn "ars_CreateEscalation( $objNew ): $ars_errstr\n";
		}
	}
	printStatus( $ret, 2, 'create escalation' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}


#ars_Logoff($ctrl);
sleep 5;
exit(0);


--- NEW FILE: 39setescalation.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/39setescalation.t 

use strict;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
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_GetListEscalation( $ctrl );
#die "ars_GetListEscalation( ALL ): $ars_errstr\n" if $ars_errstr;
my @objects = ( 'ARSperl Test-escalation1 (copy)' );


$| = 1;


foreach my $obj ( @objects ){
	modifyObject( $ctrl, $obj );
}


sub modifyObject {
	my( $ctrl, $obj ) = @_;
	print '-' x 60, "\n";
#	print "GET ESCALATION $obj\n";
	my $wfObj = ars_GetEscalation( $ctrl, $obj );
	die "ars_GetEscalation( $obj ): $ars_errstr\n" if $ars_errstr;

	my( $name, $newName );
	$newName = $name = $wfObj->{name};
	$newName =~ s/\(copy\)/(renamed)/;


	my $ret = 1;
	print "SET ESCALATION $name\n";
	$ret = ars_SetEscalation( $ctrl, $wfObj->{name}, {name => $newName} );
	die "ars_SetEscalation( $name ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 2, 'set escalation' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}

sub makeRef {
	my( %args ) = @_;
	$args{label} = ''       if !exists $args{label};
	$args{description} = '' if !exists $args{description};
	if( $args{dataType} == 1 ){
		$args{permittedGroups} = [] if !exists $args{permittedGroups};
		$args{value}          = undef  if !exists $args{value};
		$args{value_dataType} = 'null' if !exists $args{value_dataType};
	}
	return \%args;	
}


#ars_Logoff($ctrl);
exit(0);


Index: 01import.t
===================================================================
RCS file: /cvsroot/arsperl/ARSperl/t/01import.t,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** 01import.t	2 Apr 2003 05:56:18 -0000	1.7
--- 01import.t	3 Feb 2007 02:33:11 -0000	1.8
***************
*** 21,25 ****
  # with an attachment field so we can test that out.
  
! if(ars_APIVersion() >= 4) {
    $d = "aptest50.def";
  }
--- 21,27 ----
  # with an attachment field so we can test that out.
  
! if(ars_APIVersion() >= 7) {
!   $d = "aptest51.def";
! }elsif(ars_APIVersion() >= 4) {
    $d = "aptest50.def";
  }
***************
*** 32,35 ****
--- 34,39 ----
  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_DeleteSchema($ctrl, "ARSperl Test3 (copy)", ARS::AR_SCHEMA_FORCE_DELETE); 
  ars_DeleteFilter($ctrl, "ARSperl Test-Filter1"); 
  ars_DeleteActiveLink($ctrl, "ARSperl Test-alink1");
***************
*** 54,61 ****
  		    "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"
  	);
  
--- 58,67 ----
  		    "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",
  	);
  
***************
*** 69,72 ****
--- 75,79 ----
  ars_Logoff($ctrl);
  
+ sleep 5;
  exit 0;
  

--- NEW FILE: 35setactlink.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/35setactlink.t 

use strict;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
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 ){
	modifyObject( $ctrl, $obj );
}


sub modifyObject {
	my( $ctrl, $obj ) = @_;
	print '-' x 60, "\n";
#	print "GET ACTIVE LINK $obj\n";
	my $wfObj = ars_GetActiveLink( $ctrl, $obj );
	die "ars_GetActiveLink( $obj ): $ars_errstr\n" if $ars_errstr;

	my( $name, $newName );
	$newName = $name = $wfObj->{name};
	$newName =~ s/\(copy\)/(renamed)/;


	my $ret = 1;
	print "SET ACTIVE LINK $name\n";
	$ret = ars_SetActiveLink( $ctrl, $name, {enable => 0, order => 327} );
	die "ars_SetActiveLink( $name ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 2, 'set active link' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}

sub makeRef {
	my( %args ) = @_;
	$args{label} = ''       if !exists $args{label};
	$args{description} = '' if !exists $args{description};
	if( $args{dataType} == 1 ){
		$args{permittedGroups} = [] if !exists $args{permittedGroups};
		$args{value}          = undef  if !exists $args{value};
		$args{value_dataType} = 'null' if !exists $args{value_dataType};
	}
	return \%args;	
}


#ars_Logoff($ctrl);
exit(0);


--- NEW FILE: 33setcontainer.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/33setcontainer.t 

use strict;
use warnings;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
if (defined($ctrl)) {
	print "ok [1] (login)\n";
} else {
	print "not ok [1] (login $ars_errstr)\n";
	exit(0);
}


#my @containers = sort {lc($a) cmp lc($b)} grep {/\(copy\)/} map {$_->{containerName}} grep {$_->{type} =~ /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 (copy)' );


$| = 1;


foreach my $ctnr ( @containers ){
	addReferences( $ctrl, $ctnr );
}


sub addReferences {
	my( $ctrl, $ctnr ) = @_;
	print '-' x 60, "\n";
#	print "GET CONTAINER $ctnr\n";
	my $ctnrObj = ars_GetContainer( $ctrl, $ctnr );
	die "ars_GetContainer( $ctnr ): $ars_errstr\n" if $ars_errstr;
#	my $ctnrType = $ctnrObj->{containerType};

	my( $name, $newName );
	$newName = $name = $ctnrObj->{name};
	$newName =~ s/\(copy\)/(renamed)/;
	my @refList = @{$ctnrObj->{referenceList}}; 

	unshift @refList, makeRef(
		dataType => 1,
		type     => 32774,
		label    => '=== BEGIN ===', 
	);

	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;
	print "SET CONTAINER $name\n";
	$ret = ars_SetContainer( $ctrl, $ctnrObj->{name}, {name => $newName, referenceList => \@refList} );
	die "ars_SetContainer( $name ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 2, 'set container' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}

sub makeRef {
	my( %args ) = @_;
	$args{label} = ''       if !exists $args{label};
	$args{description} = '' if !exists $args{description};
	if( $args{dataType} == 1 ){
		$args{permittedGroups} = [] if !exists $args{permittedGroups};
		$args{value}          = undef  if !exists $args{value};
		$args{value_dataType} = 'null' if !exists $args{value_dataType};
	}
	return \%args;	
}


#ars_Logoff($ctrl);
exit(0);


--- NEW FILE: 34createactlink.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/34createactlink.t 

use strict;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
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 ){
	my $objNew = "$obj (copy)";
	ars_DeleteActiveLink( $ctrl, $objNew );
	copyObject( $ctrl, $obj, $objNew );
}


sub copyObject {
	my( $ctrl, $obj, $objNew ) = @_;
	print '-' x 60, "\n";
#	print "GET ACTIVE LINK $ctnr\n";
	my $wfObj = ars_GetActiveLink( $ctrl, $obj );
	die "ars_GetActiveLink( $obj ): $ars_errstr\n" if $ars_errstr;

#use Data::Dumper;
#$Data::Dumper::Sortkeys = 1;
#my $data = $ctnrObj;
#my $file = '-';
#local *FILE;
#open( FILE, "> $file" ) or die qq{Cannot open \"$file\" for writing: $!\n};
#print FILE Data::Dumper->Dump( [$data], ['ctnrObj'] );
#close FILE;

	$wfObj->{name} = $objNew;

	@{$wfObj->{objPropList}} = grep {$_->{prop} < 90000} @{$wfObj->{objPropList}};
#	foreach my $prop ( @{$ctnrObj->{objPropList}} ){
#		$prop->{value} .= 'xCopy' if $prop->{prop} == 60020 && $prop->{value} ne '';
#	}
	$wfObj->{changeDiary} = "Init";

	my $ret = 1;
	print "CREATE ACTIVE LINK $objNew\n";
	$ret = ars_CreateActiveLink( $ctrl, $wfObj );
	if( $ars_errstr ){
		if( $ars_errstr =~ /\[ERROR\]/ ){
			die "ars_CreateActiveLink( $objNew ): $ars_errstr\n";
		}else{
			warn "ars_CreateActiveLink( $objNew ): $ars_errstr\n";
		}
	}
	printStatus( $ret, 2, 'create active link' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}


#ars_Logoff($ctrl);
sleep 5;
exit(0);


--- NEW FILE: 32createcontainer.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/32createcontainer.t 

use strict;
use warnings;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
if (defined($ctrl)) {
	print "ok [1] (login)\n";
} 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 {$_->{type} =~ /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 ){
	my $ctnrNew = "$ctnr (copy)";
	ars_DeleteContainer( $ctrl, $ctnrNew );
	copyContainer( $ctrl, $ctnr, $ctnrNew );
}


sub copyContainer {
	my( $ctrl, $ctnr, $ctnrNew ) = @_;
	print '-' x 60, "\n";
#	print "GET CONTAINER $ctnr\n";
	my $ctnrObj = ars_GetContainer( $ctrl, $ctnr );
	die "ars_GetContainer( $ctnr ): $ars_errstr\n" if $ars_errstr;
#	my $ctnrType = $ctnrObj->{containerType};

#	use Data::Dumper;
#	$Data::Dumper::Sortkeys = 1;
#	print Data::Dumper->Dump( [$ctnrObj], ['ctnrObj'] );

	@{$ctnrObj->{objPropList}} = grep {$_->{prop} < 90000} @{$ctnrObj->{objPropList}};
	foreach my $prop ( @{$ctnrObj->{objPropList}} ){
		$prop->{value} .= 'xCopy' if $prop->{prop} == 60020 && $prop->{value} ne '';
	}
	$ctnrObj->{changeDiary} = "Init";

	my $ret = 1;
	print "CREATE CONTAINER $ctnrNew\n";
	$ret = ars_CreateContainer( $ctrl, $ctnrNew, $ctnrObj );
	die "ars_CreateContainer( $ctnrNew ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 2, 'create container' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}


#ars_Logoff($ctrl);
sleep 5;
exit(0);


--- NEW FILE: 31createschema.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/31createschema.t 

use strict;
use ARS;
require './t/config.cache';

print "1..6\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
if (defined($ctrl)) {
	print "ok [1] (login)\n";
} else {
	print "not ok [1] (login $ars_errstr)\n";
	exit(0);
}


#my %excl = map {$_ => 1} (
#	'Group',
#	'User', 
#	'Alert Events', 
#	'Application Pending', 
#	'Application Statistics', 
#	'Application Statistics Configuration',
#	'AR System Administrator Preference',
#);
#my @forms = ( 'ARSperl Test', 'ARSperl Test2', 'ARSperl Test-join', 'ARSperl Test3' );
#my @forms = sort {lc($a) cmp lc($b)} grep {/^BPM:/} ars_GetListSchema( $ctrl, 0, 1024 );			# all
#my @forms = sort {lc($a) cmp lc($b)} grep {$_ ge "BPM:MA:"} grep {/^BPM:/} ars_GetListSchema( $ctrl, 0, 1024 );			# all
#die "ars_GetListSchema( ALL ): $ars_errstr\n" if $ars_errstr;
my @forms = ( 'ARSperl Test3' );

$| = 1;


foreach my $form ( @forms ){
	my $formNew = "$form (copy)";
	ars_DeleteSchema( $ctrl, $formNew, 1 );
	copyForm( $ctrl, $form, $formNew );
}


sub copyForm {
	my( $ctrl, $form, $formNew ) = @_;
	print '-' x 60, "\n";
#	print "GET SCHEMA $form\n";
	my $formObj = ars_GetSchema( $ctrl, $form );
	die "ars_GetSchema( $form ): $ars_errstr\n" if $ars_errstr;
	my $formType = $formObj->{schema}{schemaType};
	$formObj->{changeDiary} = "Init";

	my( $aGetListFields, $aIndexList, $aSortList, $hArchiveInfo, $hAuditInfo );
	$aGetListFields = delete $formObj->{getListFields} if exists($formObj->{getListFields});
	$aIndexList     = delete $formObj->{indexList}     if exists($formObj->{indexList});
	$aSortList      = delete $formObj->{sortList}      if exists($formObj->{sortList});
	$hArchiveInfo   = delete $formObj->{archiveInfo}   if exists($formObj->{archiveInfo});
	$hAuditInfo     = delete $formObj->{auditInfo}     if exists($formObj->{auditInfo});
	$hArchiveInfo->{formName} .= ' (copy)' if $hArchiveInfo;

	foreach my $hProp ( @{$formObj->{objPropList}} ){
		$hProp->{value} .= 'copy' if $hProp->{prop} == 60018 && $hProp->{value};
	}

	my( $ret, $rv ) = ( 1, 0 );
	print "CREATE SCHEMA $formNew\n";
	$ret = ars_CreateSchema( $ctrl, $formNew, $formObj );
	die "ars_CreateSchema( $formNew ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 2, 'create schema' );
	sleep 5;

#	ars_DeleteVUI( $ctrl, $formNew, 536870912 );
#	die "ars_DeleteVUI( $formNew, 536870912 ): $ars_errstr\n" if $ars_errstr;

	my @views = ars_GetListVUI( $ctrl, $form, 0 );
	die "ars_GetListVUI( $form ): $ars_errstr\n" if $ars_errstr;

	my( $vuiId_New ) = ars_GetListVUI( $ctrl, $formNew, 0 );
	die "ars_GetListVUI( $formNew ): $ars_errstr\n" if $ars_errstr;


	my $vuiSt = ars_GetVUI( $ctrl, $formNew, $vuiId_New );
	die "ars_GetVUI( $formNew, $vuiId_New ): $ars_errstr\n" if $ars_errstr;
	foreach my $prop ( @{$vuiSt->{props}} ){
		$prop->{value} .= " $vuiId_New" if $prop->{prop} == 20;
	}
	$vuiSt->{vuiName} .= " $vuiId_New";
	print "SET VUI $vuiId_New\n";
	$ret = ars_SetVUI( $ctrl, $formNew, $vuiSt );
	die "ars_SetVUI( $formNew, $vuiId_New ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 3, 'set vui' );


	( $ret, $rv ) = ( 1, 0 );
	foreach my $vuiId ( @views ){
		$vuiSt = ars_GetVUI( $ctrl, $form, $vuiId );
		die "ars_GetVUI( $form, $vuiId ): $ars_errstr\n" if $ars_errstr;

		if( $vuiId == $vuiId_New ){ 
			print "SET VUI $vuiId\n";
			$rv = ars_SetVUI( $ctrl, $formNew, $vuiSt );
			die "ars_SetVUI( $formNew, $vuiId ): $ars_errstr\n" if $ars_errstr;
		}else{
			print "CREATE VUI $vuiId\n";
			$rv = ars_CreateVUI( $ctrl, $formNew, $vuiSt );
			die "ars_CreateVUI( $formNew, $vuiId ): $ars_errstr\n" if $ars_errstr;
		}
		$ret &&= $rv;
	}
	printStatus( $ret, 4, 'create vui' );

	my @fieldIds = sort {$a <=> $b} ars_GetListField( $ctrl, $form, 0,  0b00010000 );  # page_holder
	die "ars_GetListField( $form ): $ars_errstr\n" if $ars_errstr;
	push @fieldIds, sort {$a <=> $b} ars_GetListField( $ctrl, $form, 0, 0b00001000 );  # page
	die "ars_GetListField( $form ): $ars_errstr\n" if $ars_errstr;
	push @fieldIds, sort {$a <=> $b} ars_GetListField( $ctrl, $form, 0, 0b11110000111 );   # other
	die "ars_GetListField( $form ): $ars_errstr\n" if $ars_errstr;
	push @fieldIds, sort {$a <=> $b} ars_GetListField( $ctrl, $form, 0, 0b00100000 );  # table
	die "ars_GetListField( $form ): $ars_errstr\n" if $ars_errstr;
	push @fieldIds, sort {$a <=> $b} ars_GetListField( $ctrl, $form, 0, 0b01000000 );  # column
	die "ars_GetListField( $form ): $ars_errstr\n" if $ars_errstr;

	my %tableLimit;

	( $ret, $rv ) = ( 1, 0 );
	foreach my $fieldId ( @fieldIds ){
		my $fieldSt = ars_GetField( $ctrl, $form, $fieldId );
		die "ars_GetField( $form, $fieldId ): $ars_errstr\n" if $ars_errstr; 


#		test_DisplayInstanceList( $ctrl, $form, $fieldSt );
#		next;


		$fieldSt->{changeDiary} = "COPY";

		if( ($formType ne 'join' && $fieldId <= 8) || $fieldId == 1 ){
			print "SET FIELD $fieldId $fieldSt->{dataType}\n";
			$rv = ars_SetField( $ctrl, $formNew, {
				fieldId   => $fieldId,
				fieldName => $fieldSt->{fieldName},
				limit     => $fieldSt->{limit},
				displayInstanceList => $fieldSt->{displayInstanceList},
			} );
			warn "ars_SetField( $formNew, $fieldId ): $ars_errstr\n" if $ars_errstr;
		}elsif( ($formType eq 'join' && $fieldId > 1 && $fieldId != 15) || $fieldId > 15 ){
			print "CREATE FIELD $fieldId $fieldSt->{dataType}";
			if( $fieldSt->{dataType} eq 'table' ){
				$tableLimit{$fieldId} = { %{$fieldSt->{limit}} };
				$tableLimit{$fieldId}{qualifier} = $fieldSt->{limit}{qualifier};
				$fieldSt->{limit}{qualifier} = {};
			}

			$rv = ars_CreateField( $ctrl, $formNew, $fieldSt, 1 );
			if( $ars_errstr ){
				my $errTxt = $ars_errstr;
				$errTxt =~ s/\[WARNING\].*?\(ARERR #50\)/  (admin only)/;
				$errTxt =~ s/\[WARNING\].*?\(ARERR #8985\)/  (roles removed)/;
				$errTxt =~ s/\[WARNING\] rev_ARQualifierStruct: hv_fetch \(hval\) returned null \(ARERR #80020\)//;
				if( $errTxt =~ /ARERR/ ){
					print "  ars_CreateField( $formNew, $fieldId ): $ars_errstr\n";
				}else{
					print $errTxt;
				}
			}
			print "\n";
		}
		$ret &&= $rv;
	}
	sleep 5;
	foreach my $fieldId ( keys %tableLimit ){
		print "SET TABLE LIMIT $fieldId\n";
		$rv = ars_SetField( $ctrl, $formNew, {
			fieldId  => int($fieldId),   # necessary for uintcpyHVal (SvIOK)
			option   => 4,               # necessary to avoid ARERR 118
			limit    => $tableLimit{$fieldId},
		} );
		warn "ars_SetField( $formNew, $fieldId ): $ars_errstr\n" if $ars_errstr;
		$ret &&= $rv;
	}

	printStatus( $ret, 5, 'create/set field' );

	my %schemaInfo;
	$schemaInfo{getListFields} = $aGetListFields if $aGetListFields;
	$schemaInfo{indexList}     = $aIndexList     if $aIndexList;
	$schemaInfo{sortList}      = $aSortList      if $aSortList;
#	$schemaInfo{archiveInfo}   = $hArchiveInfo   if $hArchiveInfo;
	$schemaInfo{auditInfo}     = $hAuditInfo     if $hAuditInfo;

	print "SET SCHEMA $formNew\n";
	$ret = ars_SetSchema( $ctrl, $formNew, \%schemaInfo );
	warn "ars_SetSchema( $formNew ): $ars_errstr\n" if $ars_errstr;
	printStatus( $ret, 6, 'set schema' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}


#ars_Logoff($ctrl);
exit(0);


Index: 02export.t
===================================================================
RCS file: /cvsroot/arsperl/ARSperl/t/02export.t,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** 02export.t	2 Sep 2005 22:10:34 -0000	1.3
--- 02export.t	3 Feb 2007 02:33:11 -0000	1.4
***************
*** 4,8 ****
  require './t/config.cache';
  
! print "1..8\n";
  
  my($ctrl) = ars_Login(&CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD);
--- 4,8 ----
  require './t/config.cache';
  
! print "1..9\n";
  
  my($ctrl) = ars_Login(&CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD);
***************
*** 26,30 ****
  		"active_link", "ARSperl Test-alink1",
  		"escalation", "ARSperl Test-escalation1",
! 		"char_menu", "ARSperl Test-menu-search1");
  
  my $junk = ars_Export($ctrl, "", 0, "schema", "blarg292394");
--- 26,32 ----
  		"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");
***************
*** 37,41 ****
  
  for (my $i = 0 ; $i < $#objects ; $i += 2) {
-   print $objects[$i], "><", $objects[$i+1], "\n";
  
    my $d2 = ars_Export($ctrl, "", 0, $objects[$i], $objects[$i+1]);
--- 39,42 ----

--- NEW FILE: 36createfilter.t ---
#!perl

# perl -w -Iblib/lib -Iblib/arch t/36createfilter.t 

use strict;
use ARS;
require './t/config.cache';

print "1..2\n";


my $ctrl = ars_Login( &CCACHE::SERVER, &CCACHE::USERNAME, &CCACHE::PASSWORD );
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 ){
	my $objNew = "$obj (copy)";
	ars_DeleteFilter( $ctrl, $objNew );
	copyObject( $ctrl, $obj, $objNew );
}


sub copyObject {
	my( $ctrl, $obj, $objNew ) = @_;
	print '-' x 60, "\n";
#	print "GET FILTER $ctnr\n";
	my $wfObj = ars_GetFilter( $ctrl, $obj );
	die "ars_GetFilter( $obj ): $ars_errstr\n" if $ars_errstr;

#	use Data::Dumper;
#	$Data::Dumper::Sortkeys = 1;
#	print Data::Dumper->Dump( [$wfObj], ['wfObj'] );

	$wfObj->{name} = $objNew;

	@{$wfObj->{objPropList}} = grep {$_->{prop} < 90000} @{$wfObj->{objPropList}};
#	foreach my $prop ( @{$ctnrObj->{objPropList}} ){
#		$prop->{value} .= 'xCopy' if $prop->{prop} == 60020 && $prop->{value} ne '';
#	}
	$wfObj->{changeDiary} = "Init";

	my $ret = 1;
	print "CREATE FILTER $objNew\n";
	$ret = ars_CreateFilter( $ctrl, $wfObj );
	if( $ars_errstr ){
		if( $ars_errstr =~ /\[ERROR\]/ ){
			die "ars_CreateFilter( $objNew ): $ars_errstr\n";
		}else{
			warn "ars_CreateFilter( $objNew ): $ars_errstr\n";
		}
	}
	printStatus( $ret, 2, 'create filter' );
}

sub printStatus {
	my( $ret, $num, $text, $err ) = @_;
	if( $ret ){
		print "ok [$num] ($text)\n";
	} else {
		print "not ok [$num] ($text $err)\n";
		exit(0);
	}
}


#ars_Logoff($ctrl);
sleep 5;
exit(0);

Thread: [Arsperl-devel] ARSperl/t 31createschema.t, NONE, 1.1 32createcontainer.t, NONE, 1.1 33setcontainer

arsperl-devel