Prima

 view release on metacpan or  search on metacpan

Prima/sys/Gencls.pm  view on Meta::CPAN

		my $eptr  = $result =~ /^\*/ ? "*" : "";           # whether result is a pointer
		my ( $lpr, $rpr) = $eptr ? ('(',')') : ('','');
		$result =~ s[^\*][];                               # strip * signs
		my $resSub    = $mapTypes { $result} || $result;   # basic result type ( typecast skip)
		my $nParam    = scalar @parms;
		my $useHandle = !exists( $staticMethods{ $id});
		@defParms     = @{$allMethodsDefaults[$allMethods{$id}]};
		my $firstDP   = undef;
		my $lastDP    = 0;
		my $property  = defined $properties{$id};
		my $ifpropset;
		my $propparms = 1;
		my $propextras;
		$propextras = 1 if $property && $nParam > ( $useHandle ? 3 : 2);

		for ( my $k = 0; $k < scalar @defParms; $k++)
		{
			if ( defined $defParms[$k])
			{
				$firstDP = $k unless defined $firstDP;
				$lastDP++;

Prima/sys/Gencls.pm  view on Meta::CPAN

		print HEADER "	Handle $incSelf;\n" if $useHandle;
		print HEADER "	(void)ax;\n" if !$useHandle && ( $nParam == 0);
		print HEADER "	if ";
		if ( $useHV)
		{
			print HEADER "(( items - $nParam + 1) % 2 != 0)";
		} else {
			if ( $property) {
				my $min = $nParam - $propparms - ( $useHandle ? 1 : 2);
				my $max = $nParam - 1;
				$ifpropset = "items > $min";
				print HEADER "(( items != $min) && ( items != $max))";
			} elsif ( $lastDP) {
				print HEADER "(( items > $nParam) || ( items < ${\($nParam-$lastDP)}))";
			} else {
				print HEADER "( items != $nParam)";
			}
		}
		my $croakId = $full ? "${ownOClass}\:\:\%s\", \"$id\"" : "\%s\", subName";
		print HEADER "\n\t\tcroak (\"Invalid usage of $croakId);\n";
		if ( $useHandle)

Prima/sys/Gencls.pm  view on Meta::CPAN

				$structCount++;
			} else {
				$stn++
			};
			$idparm++;
		}
		# generating call
		my $lpaus = ( length( $paramAuxSet) > 4) || ( $paramAuxSet eq '****');
		if ( $lpaus || $property) {
			if ( $property && $lpaus) {
				my $label =  "if ( !( $ifpropset)) {\n";
				$label .= "\t\t\tmemset(&$incRes,0,sizeof($incRes));\n" if $reuseStructVar;
				$label .= "\t\t\tgoto CALL_POINT;\n\t\t}\n\t\t";
				$paramAuxSet =~ s/\*\*\*\*/$label/;
			}
			print HEADER $paramAuxSet;
			print HEADER "CALL_POINT : " if $property && $lpaus;
		}
		print HEADER "$incRes = " unless $resSub eq "void";
		if ( $full) {
			print HEADER ( exists $pipeMethods{ $id}) ?

Prima/sys/Gencls.pm  view on Meta::CPAN

			print HEADER "(( $resSub$eptr (*)( $parmz)) func)";
		}
		print HEADER "(\n";
		print HEADER "\t\t\t$incSelf" if $useHandle;

		$stn = 0;
		$stn++ if $useHandle;

		if ( $property) {
			print HEADER ",\n" if $stn > 0;
			print HEADER "\t\t\t$ifpropset";
		}

		$structCount = 0;
		$idparm = 0;
		foreach (@parms) {
			my $ptr  = $_ =~ /^\*/ ? "&" : "";
			my $lVar = $_;
			$lVar =~ s[^\*][];
			$mtVar = $mapTypes{ $lVar} || $lVar;
			my ( $lp, $rp) = $ptr ? ('(',')') : ('','');
			$structCount = '' if $property && $reuseStructVar && $idparm == $#parms;
			print HEADER ",\n" if $stn > 0;
			print HEADER "\t\t\t";
			print HEADER "( $ifpropset) ? ( " if
				$property && !$reuseStructVar && $idparm == $#parms;
			my $defPropParm;
			if ( exists $structs{$lVar} || exists $arrays{$lVar})
			{
				if ( exists $structs{$lVar}) {
					$stn += defined ${$structs{$lVar}[2]}{hash} ?
						1 :
						scalar @{ $structs{ $lVar}[ 0]};
				} else {
					$stn += $arrays{$lVar}[0];

Prima/sys/Gencls.pm  view on Meta::CPAN

				$stn++;
			}
			print HEADER ") : $defPropParm" if
				$property && !$reuseStructVar && $idparm == $#parms;
			$idparm++;
		}
		print HEADER "\n";
		print HEADER "\t\t);\n";
		print HEADER "\t\tSPAGAIN;\n\t\tSP -= items;\n"
			if (!( $resSub eq "void") || $useHV);
		print HEADER "\t\tif ( $ifpropset) {\n\t\t\tXSRETURN_EMPTY;\n\t\t\treturn;\n\t\t}\n"
			if $property;

		my $pphv = 0;
		# result generation
		if ( exists $structs{$resSub} && defined ${$structs{$resSub}[2]}{hash}) {
		# hashed structure -> hash reference
			my $bptr = ( $eptr eq '*') ? '' : '&';
			print HEADER "\t\tXPUSHs( sv_2mortal( sv_${resSub}2HV( $bptr$incRes)));\n";
			$pphv = 1;
		} elsif ( exists( $structs{ $resSub})) {