Prima
78 results

 view release on metacpan or  search on metacpan

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

				next;
			} elsif ( $tok eq 'define') {
				parse_define( $global);
				next;
			}
			putback( $tok2);
			putback( $tok);
		} elsif ( $tok eq 'use') {
			my $fid = getid;
			expect(';');
			save_context;
			my $loaded;
			foreach (@includeDirs) {
				my $f = "$_/$fid.cls";
				next unless -f $f;
				$loaded = $f;
			}
			die "$fid.cls not found\n" unless defined $loaded;
			load_file( $loaded);
			$level++;
			&load_structures;
			$level--;
			restore_context;
		} else {
			putback ( $tok);
			last;
		}
	}
}

#start of parse_file
load_file( shift);
load_structures;
$tok = gettok;
if (( $tok eq "object") || ( $tok eq "package")) {
	load_single_part( $tok);
} elsif ( $tok) {
	error "found $tok but expecting 'object' or 'package'";
} else {
	unless ( $level) {
		#$genInc = 0;
		$ownFile = $fileName;
		$ownFile =~ s/([^.]*)\..*$/$1/;
		my $out = $ownFile;
		$out =~ s[.*\/][];
		$ownCType = uc $out;
	}
}
} # end of parse_file

sub type2sv
{
	my ( $type, $name) = @_;
	$type = $mapTypes{ $type} || $type;
	if ( ref $type) {
		return "sv_$type->[PROPS]->{name}2HV(&($name))";
	} elsif ( $type eq 'Handle') {
		return "( $name ? (( $incInst)$name)-> $hMate : &PL_sv_undef)";
	} elsif ( $type eq 'string') {
		my $fname = $name;
		$fname =~ s/(.*)\b(\w+)$/${1}is_utf8.$2/;
		return "prima_svpv_utf8($name, $fname)";
	} elsif ( $type eq 'SV*') {
		return $name;
	} else {
		return "new${xsConv{$type}[7]}( $name$xsConv{$type}[5])";
	}
}

sub sv2type
{
	my ( $type, $name) = @_;
	$type = $mapTypes{ $type} || $type;
	if ( $type eq 'Handle') {
		return "$incGetMate( $name);";
	} elsif ( $type eq 'SV*') {
		return $name;
	} else {
		return "$xsConv{$type}[1]( $name$xsConv{$type}[8])";
	}
}

sub sv2type_pop
{
	my ( $type) = @_;
	$type = $mapTypes{ $type} || $type;
	if ( $type eq 'Handle') {
		return "$incGetMate( POPs);";
	} elsif ( $type eq 'SV*') {
		return 'POPs';
	} else {
		return "( $xsConv{$type}[0]) $xsConv{$type}[6]";
	}
}


sub mortal
{
	my $type = $mapTypes{ $_[0]} || $_[0];
	if ( $type eq 'SV*') {
		return '';
	} elsif ( $type eq 'Handle') {
		return 'sv_mortalcopy';
	} else {
		return 'sv_2mortal';
	}
}

sub cwrite
{
	my ( $type, $from, $to) = @_;
	$type = $mapTypes{ $type} || $type;
	if ( $type eq 'string') {
		return "strncpy( $to, $from, 255); $to\[255\]=0;";
	} else {
		return "$to = $from;";
	}
}

sub out_method_profile
# common method print sub
{

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

	open HEADER, ">$dirOut$out.h" or die "Cannot open $dirOut$out.h\n";
print HEADER <<LABEL;
/* This file was automatically generated.
 * Do not edit, you\'ll lose your changes anyway.
 * file: $out.h  */
#ifndef ${ownCType}_H_
#define ${ownCType}_H_
#ifndef _APRICOT_H_
#include \"apricot.h\"
#endif
LABEL
																		# struct
print HEADER "#include \"$baseFile.h\"\n" if $baseClass;
{
	my %toInclude = ();
	for ( sort {
		$structs{$a}-> [PROPS]-> {order} <=> $structs{$b}-> [PROPS]-> {order}
	} keys %structs) {
		my $f = ${$structs{$_}[PROPS]}{incl};
		$toInclude{$f}=1 if $f;
	}

	for ( keys %arrays) {
		my $f = ${$arrays{$_}[2]}{incl};
		$toInclude{$f}=1 if $f;
	}

	for ( keys %defines) {
		my $f = $defines{$_}{incl};
		$toInclude{$f}=1 if $f;
	}

	for ( keys %mapTypes) {
		my $f = $typedefs{$_}{incl};
		$toInclude{$f}=1 if $f;
	}

	for ( keys %toInclude) {
		s[.*\/][];
		print HEADER "#include \"$_.h\"\n";
	}
}
print HEADER "\n";
print HEADER <<SD;
#ifdef __cplusplus
extern "C" {
#endif
SD

# generating inplaced structures
for ( sort { $structs{$a}-> [PROPS]-> {order} <=> $structs{$b}-> [PROPS]-> {order}} keys %structs)
{
	my $s = $structs{$_};
	if ( $$s[PROPS]{genh})
	{
		my @types = @{$$s[TYPES]};
		my @ids   = @{$$s[IDS]};
		my @def   = @{$$s[DEFS]};
		print HEADER "typedef struct _$_ {\n";
		my ($maxw_undefs, @undefs) = (0);
		my ($maxw_utfs, @utfs) = (0);
		for ( my $j = 0; $j < @types; $j++) {
			if ( ref $types[$j]) {
				print HEADER "\t$types[$j]->[PROPS]->{name} $ids[$j];\n";
			} elsif ( $types[$j] eq "string") {
				print HEADER "\tchar $ids[$j]\[256\];\n";
				push @utfs, $ids[$j];
				$maxw_utfs = length $ids[$j] if length($ids[$j]) > $maxw_utfs;
			} else {
				print HEADER "\t$types[$j] $ids[$j];\n";
			}

			if (($def[$j] // '') =~ /^undef:/) {
				push @undefs, $ids[$j];
				$maxw_undefs = length $ids[$j] if length($ids[$j]) > $maxw_undefs;
			}
		}
		my $wtab = $maxw_undefs // 0;
		$wtab = $maxw_utfs if ($maxw_utfs // 0) > $wtab;
		if ( @undefs ) {
			print HEADER "\tstruct {\n";
			printf HEADER "\t\tunsigned %\-${wtab}s : 1;\n", $_ for @undefs;
			print HEADER "\t} undef;\n";
		}
		if ( @utfs ) {
			print HEADER "\tstruct {\n";
			printf HEADER "\t\tunsigned %\-${wtab}s : 1;\n", $_ for @utfs;
			print HEADER "\t} is_utf8;\n";
		}
		print HEADER "} $_, *P$_;\n\n";
		if ( $$s[PROPS]{hash})
		{
			print HEADER "extern $_ * SvHV_$_( SV * hashRef, $_ * strucRef, const char * errorAt);\n";
			print HEADER "extern SV * sv_${_}2HV( $_ * strucRef);\n";
		}
		print HEADER "extern $_ ${_}_buffer;\n\n";
	}
}
# generating inplaced arrays
for ( keys %arrays)
{
	if ( ${$arrays{$_}[2]}{genh})
	{
		print HEADER "typedef $arrays{$_}[1] $_\[ $arrays{$_}[0]\];\n";
		print HEADER "extern $_ ${_}_buffer;\n\n";
	}
}
# and typedefs
for ( keys %mapTypes)
{
	if ( $typedefs{$_}{genh})
	{
		print HEADER "typedef $mapTypes{$_} $_;\n" unless $typedefs{$_}{cast};
	}
}
# defines
for ( keys %defines)
{
	if ( $defines{$_}{genh})
	{
		print HEADER "#define $_ $defines{$_}{type}\n";
	}
}

if ( $genObject)
{
	print HEADER <<LABEL;

typedef struct _${ownCType}_vmt {
/* internal runtime classifiers */
	char *$hClassName;
	void *$hSuper;
	void *$hBase;
	int $hSize;
	VmtPatch *patch;
	int patchLength;
	int vmtSize;
/* methods definition */
LABEL

		for ( my $i = 0; $i <= $#allMethods; $i++)
		{
			my $body = $allMethodsBodies[ $i];
			my $id = $allMethods[ $i];
			$body =~ s/\b$id\b/\( \*$id\)/;
			print HEADER "\t$body\n";
		}
print HEADER <<LABEL;

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

LABEL
print HEADER "#include \"guts.h\"\n" if ( !$genDyna && $genObject);
print HEADER <<SD;
#ifdef __cplusplus
extern "C" {
#endif

SD

	out_FROMPERL_methods( \@portableMethods, 1);                # portable methods, bodies

	my %newH = (%structs, %arrays);
	for ( keys %newH)
	{
		print HEADER "$_ ${_}_buffer;\n" if ( ${$newH{$_}[2]}{genh});
	}
	print HEADER "\n\n";

	# generating SvHV_hash & sv_hash2HV, if any
	for ( sort { $structs{$a}-> [PROPS]-> {order} <=> $structs{$b}-> [PROPS]-> {order}} keys %structs)
	{
		my $S = $_;
		my $s = $structs{$S};
		if ( $s->[PROPS]->{genh} && $s->[PROPS]->{hash})
		{
			print HEADER "$S * SvHV_$S( SV * hashRef, $S * strucRef, const char * errorAt)\n{\n";
			print HEADER "\tconst char * err = errorAt ? errorAt : \"$S\";\n";
			print HEADER "\tHV * $incHV = ( HV*)\n\t".
				"(( SvROK( hashRef) && ( SvTYPE( SvRV( hashRef)) == SVt_PVHV)) ? SvRV( hashRef)\n\t\t".
				": ( croak( \"Illegal hash reference passed to %s\", err), NULL));\n";
			print HEADER "\tSV ** $incSV;\n\n\t(void)$incSV;\n\n";
			for ( my $j = 0; $j < scalar @{$s->[TYPES]}; $j++)
			{
				my $lType = @{ $s->[TYPES]}[$j];
				my $lName = @{ $s->[IDS]}[$j];
				my $def   = @{ $s->[DEFS]}[$j];
				my $inter;
				my $lNameLen = length $lName;

				if ( ref $lType) {
					print HEADER <<CONTAINED_STRUCTURE;
	{
		SV *sv = NULL;
		SV **svp = hv_fetch( $incHV, "$lName", $lNameLen, 0);
		if ( !svp) {
			sv = newRV_noinc(( SV*) newHV());
			svp = &sv;
		}
		SvHV_$lType->[PROPS]->{name}( *svp, &(strucRef-> $lName), errorAt);
		if ( sv)
			sv_free( sv);
	}
CONTAINED_STRUCTURE
				} else {
					print HEADER "\t$incSV = hv_fetch( $incHV, \"$lName\", $lNameLen, 0);\n";
					if ($def =~ /^undef:(.*)$/) {
						print HEADER "\tstrucRef-> undef.$lName = ($incSV == NULL);\n";
						$def = $1;
					}
					if ( $lType eq 'string') {
						print HEADER "\tstrucRef->is_utf8.$lName = ($incSV && prima_is_utf8_sv(*$incSV)) ? 1 : 0;\n";
					}
					$inter = "$incSV ? " . sv2type( $lType, "*$incSV") . " : $def";
					print HEADER "\t", cwrite( $lType, $inter, "strucRef-> $lName"), "\n\n";
				}
			}
			print HEADER "\treturn strucRef;\n";
			print HEADER "}\n\n";

			print HEADER "SV * sv_${_}2HV( $_ * strucRef)\n{\t\n";
			print HEADER "\tHV * $incHV = newHV();\n";
			for ( my $k = 0; $k < @{ $s->[TYPES]}; $k++)
			{
				my $lName = @{$s->[IDS]}[$k];
				my $lNameLen = length $lName;
				my $lType = @{$s->[TYPES]}[$k];
				my $inter = type2sv( $lType, "strucRef->$lName");
				my $prefix =
					($s->[DEFS]->[$k] =~ /^undef:/) ?
						"if (!strucRef->undef.$lName)" :
						"";
				print HEADER "\t$prefix (void) hv_store( $incHV, \"$lName\", $lNameLen, $inter, 0);\n";
			}
			print HEADER "\treturn newRV_noinc(( SV*) $incHV);\n";
			print HEADER "}\n\n";
		}
	}

	if ( $genObject)
	{
		out_method_profile( \@newMethods,      '${ownCType}_${id}_REDEFINED', 0, 1);
		out_method_profile( \@portableImports, '${ownCType}_${id}',           1, 1);

																# constructor & destructor
		print HEADER "\n";
		print HEADER "/* patches */\n";
		print HEADER "extern ${baseCType}_vmt ${baseCType}Vmt;\n" if ( $baseClass && !$genDyna);
		print HEADER "extern ${ownCType}_vmt ${ownCType}Vmt;\n\n";
		print HEADER "static VmtPatch ${ownCType}VmtPatch[] =\n";    # patches
		print HEADER "{";
		for (my $j = 0; $j <= $#newMethods; $j++)
		{
			my @locp = split (" ", $newMethods[ $j]);
			my $id = $locp[0];
			if ( $j) { print HEADER ','} ;
			print HEADER "\n\t{ &(${ownCType}Vmt. $id), (void*)${ownCType}_${id}_REDEFINED, \"$id\"}";
		}
		print HEADER "\n\t{NULL,NULL,NULL} /* M\$C empty struct error */" unless scalar @newMethods;
		print HEADER "\n};\n\n";

		my $lpCount = $#newMethods + 1;
		print HEADER <<LABEL;

/* Class virtual methods table */
${ownCType}_vmt ${ownCType}Vmt = {
	\"${ownOClass}\",
	${\($baseClass && !$genDyna ? "\&${baseCType}Vmt" : "NULL")},
	${\($baseClass && !$genDyna ? "\&${baseCType}Vmt" : "NULL")},
	sizeof( $ownCType ),
	${ownCType}VmtPatch,
	$lpCount,



( run in 0.232 second using v1.01-cache-2.11-cpan-0d8aa00de5b )