ARSperl
view release on metacpan or search on metacpan
rev_AR_template.pl view on Meta::CPAN
}
if( SvTYPE((SV*) h) == SVt_PVHV ){
@> if( $obj->{_typeparam} ){
// printf( "<@ $class @>: t = <%s>\n", t );
if( hv_exists(h,t,strlen(t)) ){
SV **type;
char *pcase;
type = hv_fetch( h, t, strlen(t), 0 );
if( type && *type ){
pcase = SvPV_nolen(*type);
@> if( $obj->{_map} ){
<@ $obj->{_switch} @> = caseLookUpTypeNumber( (TypeMapStruct*) <@ $obj->{_map} @>, pcase );
@> }else{
<@ $obj->{_switch} @> = 0;
@> foreach my $key ( keys %{$obj->{_case}} ){
@> my( $pcase, $dummy ) = each %{$obj->{_case}{$key}};
if( !strcmp(pcase,"<@ $pcase @>") ) <@ $obj->{_switch} @> = <@ $key @>;
@> }
@> }
}else{
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, "rev_<@ $class @>: hv_fetch (type) returned null");
return -2;
}
}else{
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, "rev_<@ $class @>: key (type) doesn't exist");
return -2;
}
@> }
// printf( "<@ $class @>: k = <%s>\n", k );
if( hv_exists(h,k,strlen(k)) ){
val = hv_fetch( h, k, strlen(k), 0 );
if( val && *val ){
@> perlToStruct( $obj, $class, "\t\t\t\t" );
}else{
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, "rev_<@ $class @>: hv_fetch returned null");
return -2;
}
}else{
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, "rev_<@ $class @>: key doesn't exist");
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, k );
return -2;
}
}else{
ARError_add(AR_RETURN_ERROR, AP_ERR_GENERAL, "rev_<@ $class @>: first argument is not a hash");
return -1;
}
return 0;
}
<@ versionEndif($obj) @>
@> }
@> sub perlToStruct {
@> my( $obj, $class, $LINE_INDENT ) = @_;
{
@> if( $obj->{_data} ){
@> my( $type, $data ) = ( $obj->{_type}, $obj->{_data} );
@> if( $obj->{_map} ){
int flag = 0;
@> foreach my $key ( keys %{$obj->{_map}} ){
if( !strcmp(SvPV_nolen(*val),"<@ $obj->{_map}{$key} @>") ){
<@ $obj->{_data} @> = <@ $key @>;
flag = 1;
}
@> }
if( flag == 0 ){
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "rev_<@ $class @>: invalid key value" );
ARError_add( AR_RETURN_ERROR, AP_ERR_CONTINUE, SvPV_nolen(*val) );
}
@> }else{
<@ typeCopy($type,$data,'*val') @>;
@> }
@> }
@> if( $obj->{_switch} ){
{
char *pcase = NULL;
char errText[512];
@> if( $obj->{_map} && !ref($obj->{_map}) ){
// pcase = SvPV_nolen(*val);
// <@ $obj->{_switch} @> = caseLookUpTypeNumber( (TypeMapStruct*) <@ $obj->{_map} @>, pcase );
@> if( ! $obj->{_typeparam} ){
HV *h2 = (HV* ) SvRV((SV*) *val);
SV** val = hv_fetch( h2, "<@ $obj->{_map} @>", <@ length($obj->{_map}) @>, 0 );
<@ $obj->{_switch} @> = SvIV(*val);
@> }
@> }else{
HV *h;
SV **hval = NULL;
char *k = NULL;
if( SvTYPE(SvRV(*val)) != SVt_PVHV ){
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "rev_<@ $class @>: not a hash value" );
return -1;
}
h = (HV* ) SvRV((SV*) *val);
@> if( $obj->{_map} && ref($obj->{_map}) eq 'ARRAY' ){
@> my( $switchKey, $hMap ) = @{$obj->{_map}};
@> my @nonNum = grep {/\D/} values %$hMap;
hval = hv_fetch( h, "<@ $switchKey @>", <@ length($switchKey) @>, 0 );
if( hval && *hval ){
pcase = SvPV_nolen(*hval);
if( 0 ){
@> foreach my $key ( sort keys %$hMap ){
<@ versionIf($obj->{_case}{$key}) @>
@> if( @nonNum ){
}else if( !strcmp(pcase,"<@ $hMap->{$key} @>") ){
@> }else{
}else if( SvIV(*hval) == <@ $hMap->{$key} @> ){
@> }
<@ $obj->{_switch} @> = <@ $key @>;
<@ versionEndif($obj->{_case}{$key}) @>
@> }
}else{
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, "rev_<@ $class @>: key doesn't exist");
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, pcase );
return -2;
}
}else{
ARError_add(AR_RETURN_WARNING, AP_ERR_GENERAL, "rev_<@ $class @>: hv_fetch (hval) returned null");
return -2;
}
@> }else{
if( 0 ){
@> foreach my $key ( keyFilter($obj->{_case},'_data') ){
@> # my( $pcase, $dummy ) = each %{$obj->{_case}{$key}};
@> my( $pcase ) = grep {!/^_/} keys %{$obj->{_case}{$key}};
@> my $key2 = $key;
@> $key2 =~ s/\W+$//;
<@ versionIf($obj->{_case}{$key}) @>
}else if( hv_exists(h,"<@ $pcase @>",<@ length($pcase) @>) ){
<@ $obj->{_switch} @> = <@ $key2 @>;
k = "<@ $pcase @>";
<@ versionEndif($obj->{_case}{$key}) @>
@> }
@> foreach my $key ( keyFilter($obj->{_case},'_default') ){
}else if( 1 ){
<@ $obj->{_switch} @> = <@ $key @>;
@> }
}else{
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "rev_<@ $class @>: map error" );
}
@> }
@> }
switch( <@ $obj->{_switch} @> ){
@> foreach my $key ( keyFilter($obj->{_case},'_data') ){
@> my $key2 = $key;
@> $key2 =~ s/\W+$//;
@> my $type = $obj->{_case}{$key}{_type};
@> my $data = $obj->{_case}{$key}{_data};
<@ versionIf($obj->{_case}{$key}) @>
case <@ $key2 @>:
@> perlToStruct( $obj->{_case}{$key}, $class, "$LINE_INDENT\t\t\t\t" );
break;
<@ versionEndif($obj->{_case}{$key}) @>
@> }
@> foreach my $key ( keyFilter($obj->{_case},'_default','_nodata') ){
case <@ $key @>:
break;
@> }
default:
sprintf( errText, "rev_<@ $class @>: invalid switch value %d", <@ $obj->{_switch} @> );
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, errText );
}
}
@> }
@> if( $obj->{_list} ){
@> my( $type, $data ) = ( $obj->{_type}, $obj->{_list}.'[i]' );
{
if( SvTYPE(SvRV(*val)) == SVt_PVAV ){
int i = 0, num = 0;
AV *ar = (AV*) SvRV((SV*) *val);
num = av_len(ar) + 1;
<@ $obj->{_num} @> = num;
if( num == 0 ) return 0;
@> unless( $type =~ s/\[\]// ){
<@ $obj->{_list} @> = (<@ $type @>*) MALLOCNN( sizeof(<@ $type @>) * num );
/* if( <@ $obj->{_list} @> == NULL ){
croak( "rev_<@ $class @>: malloc error\n" );
exit( 1 );
} */
@> }
for( i = 0; i < num; ++i ){
SV **item = av_fetch( ar, i, 0 );
if( item && *item ){
char *k = "_";
HV *h = newHV();
SvREFCNT_inc( *item );
hv_store( h, k, strlen(k), *item, 0 );
<@ typeCopy($type,$data,'*item') @>;
hv_undef( h );
}else{
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "rev_<@ $class @>: invalid inner array value" );
}
}
}else{
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "rev_<@ $class @>: hash value is not an array reference" );
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, k );
return -1;
}
}
@> }
@> if( grep {!/^_/} keys %$obj ){
if( SvTYPE(SvRV(*val)) == SVt_PVHV ){
int i = 0, num = 0;
HV *h = (HV* ) SvRV((SV*) *val);
char k[256];
k[255] = '\0';
@> foreach my $key ( grep {!/^_/} keys %$obj ){
@> my $key2 = $key;
@> $key2 =~ s/\W+$//;
<@ versionIf($obj->{$key}) @>
{
SV **val;
strncpy( k, "<@ $key2 @>", 255 );
val = hv_fetch( h, "<@ $key2 @>", <@ length($key2) @>, 0 );
if( val && *val && <@ ($obj->{$key}{_type} eq 'ARValueStruct')? '(SvOK(*val) || SvTYPE(*val) == SVt_NULL)' : 'SvOK(*val)' @> ){
@> perlToStruct( $obj->{$key}, $class, "$LINE_INDENT\t\t\t" );
}else{
@> if( $obj->{$key}{_default} ){
<@ $obj->{$key}{_data} @> = <@ $obj->{$key}{_default} @>;
@> }else{
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "hv_fetch error: key \"<@ $key2 @>\"" );
return -1;
@> }
}
}
<@ versionEndif($obj->{$key}) @>
@> }
}else{
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "rev_<@ $class @>: hash value is not a hash reference" );
return -1;
}
@> }
}
@> }
void copyIntArray( int size, int *dst, SV* src ){
AV *ar = (AV*) SvRV((SV*) src);
int len = av_len(ar);
int i;
for( i = 0; i < size; ++i ){
dst[i] = 0;
if( i <= len ){
SV** item = av_fetch( ar, i, 0 );
if( item != NULL && *item != NULL && i <= len ){
dst[i] = (SvOK(*item))? SvIV(*item) : 0;
}
}
}
}
void copyUIntArray( int size, ARInternalId *dst, SV* src ){
AV *ar = (AV*) SvRV((SV*) src);
int len = av_len(ar);
int i;
for( i = 0; i < size; ++i ){
dst[i] = 0;
if( i <= len ){
SV** item = av_fetch( ar, i, 0 );
if( item != NULL && *item != NULL && i <= len ){
dst[i] = (SvOK(*item))? SvUV(*item) : 0;
}
}
}
}
@@ > <@ $C_File @>
@> foreach my $class ( @classes_C ){
@> my $obj = $CONVERT{$class};
@> if( $obj->{_typedef} || $obj->{_header_only} ){
@> next;
@> }
SV *
perl_<@ $class @>( ARControlStruct *ctrl, <@ $class @> *p ){
SV *ret;
@> structToPerl( $obj, "\t" );
return ret;
}
@> }
@> sub structToPerl {
@> my( $obj, $LINE_INDENT ) = @_;
{
@> if( $obj->{_data} ){
@> my( $type, $data ) = ( $obj->{_type}, $obj->{_data} );
SV *val;
<@ perlCopy($type,'val',$data) @>;
ret = val;
@> }elsif( $obj->{_switch} ){
SV *val;
switch( <@ $obj->{_switch} @> ){
@> foreach my $key ( keys %{$obj->{_case}} ){
case <@ $key @>:
@> structToPerl( $obj->{_case}{$key}, "$LINE_INDENT\t" );
break;
@> }
default:
ARError_add( AR_RETURN_ERROR, AP_ERR_GENERAL, "<@ $class @>: Invalid case" );
break;
}
ret = val;
@> }elsif( $obj->{_list} ){
@> my( $type, $data ) = ( $obj->{_type}, $obj->{_list}.'[i]' );
AV *array;
SV *val;
I32 i;
array = newAV();
av_extend( array, <@ $obj->{_num} @>-1 );
for( i = 0; i < <@ $obj->{_num} @>; ++i ){
<@ perlCopy($type,'val',$data) @>;
av_store( array, i, val );
}
ret = newRV_noinc((SV *) array);
@> }else{
HV *hash;
SV *val;
hash = newHV();
@> foreach my $key ( keys %$obj ){
@> structToPerl( $obj->{$key}, "$LINE_INDENT\t" );
hv_store( hash, "<@ $key @>", <@ length($key) @>, ret, 0 );
@> }
ret = newRV_noinc((SV *) hash);
@> }
}
@> }
@@ > support_generated.c
#--- END TEMPLATE ---
$ARS::CodeTemplate::DEF_CODE = ARS::CodeTemplate::compile( $ARS::CodeTemplate::TPT_CODE );
ARS::CodeTemplate::procdef( $ARS::CodeTemplate::DEF_CODE );
#use UTAN::Util;
#UTAN::Util::modFileByRegex( 'functions.c', 's/^(\s*)rev_ARQualifierStruct\(.*/$1p->qualifier.operation = AR_OPERATION_NONE;/' );
#--- EDIT HERE ---
sub evalTemplate {
my( $tag, $type, $L, $R ) = @_;
# print STDERR "evalTemplate( $tag, $type, $L, $R )\n"; # _DEBUG_
$tag = lc($tag);
$tag =~ s/^(?=[^_])/_/;
my( $tpDef, $tp ) = ( $TEMPLATES{$tag} );
if( !defined $tpDef ){
die "NO TEMPLATE GROUP\n", "\$tag <$tag> \$type <$type> \$L <$L> \$R <$R>\n"; # _DEBUG_
# exit 1;
}
# foreach my $rx ( keys %$tpDef ){
# if( $type =~ /^$rx$/ ){
# $tp = $tpDef->{$rx};
# last;
# }
my @match;
for( my $i = 0; $i < $#{$tpDef}; $i+=2 ){
$rx = $tpDef->[$i];
# print "\$rx <$rx>\n"; # _DEBUG_
@match = ($type =~ /^$rx$/);
if( @match ){
( run in 0.688 second using v1.01-cache-2.11-cpan-39bf76dae61 )